From 093e37647ccd0526520d611fef1baadd748694d8 Mon Sep 17 00:00:00 2001 From: Alex Richert Date: Tue, 18 Jun 2024 09:50:42 -0700 Subject: [PATCH] add 2.12.0 docs --- aea_8f.html | 64 +- aea_8f.js | 2 +- aea_8f_source.html | 269 +- annotated.html | 53 +- annotated_dup.js | 9 +- args__mod_8f.html | 137 - args__mod_8f.js | 7 - args__mod_8f_source.html | 136 - bc_sd.png | Bin 0 -> 635 bytes bdwn.png | Bin 147 -> 0 bytes classes.html | 55 +- dir_49e56c817e5e54854c35e136979f97ca.html | 44 +- dir_68267d1309a1af8e8297ef4c3efbcdba.html | 484 +- dir_68267d1309a1af8e8297ef4c3efbcdba.js | 213 + doc.png | Bin 746 -> 0 bytes doc.svg | 12 + docd.svg | 12 + doxygen.css | 1082 +- doxygen.png | Bin 3779 -> 0 bytes doxygen.svg | 28 + dynsections.js | 73 +- errexit_8f.html | 58 +- errexit_8f.js | 2 +- errexit_8f_source.html | 101 +- errmsg_8f.html | 58 +- errmsg_8f.js | 2 +- errmsg_8f_source.html | 97 +- files.html | 470 +- files_dup.js | 214 +- folderclosed.png | Bin 616 -> 0 bytes folderclosed.svg | 11 + folderclosedd.svg | 11 + folderopen.png | Bin 597 -> 0 bytes folderopen.svg | 17 + folderopend.svg | 12 + fparsei_8f.html | 62 +- fparsei_8f.js | 2 +- fparsei_8f_source.html | 113 +- fparser_8f.html | 62 +- fparser_8f.js | 2 +- fparser_8f_source.html | 113 +- functions.html | 114 + functions_func.html | 114 + gbyte_8f.html | 64 +- gbyte_8f.js | 2 +- gbyte_8f_source.html | 225 +- gbytec_8f.html | 70 +- gbytec_8f.js | 2 +- gbytec_8f_source.html | 91 +- gbytes_8f.html | 68 +- gbytes_8f.js | 2 +- gbytes_8f_source.html | 279 +- gbytesc_8f.html | 68 +- gbytesc_8f.js | 2 +- gbytesc_8f_source.html | 163 +- getbit_8f.html | 141 +- getbit_8f.js | 2 +- getbit_8f_source.html | 212 +- getgb1_8f.html | 84 +- getgb1_8f.js | 2 +- getgb1_8f_source.html | 419 +- getgb1r_8f.html | 78 +- getgb1r_8f.js | 2 +- getgb1r_8f_source.html | 181 +- getgb1re_8f.html | 84 +- getgb1re_8f.js | 2 +- getgb1re_8f_source.html | 191 +- getgb1s_8f.html | 84 +- getgb1s_8f.js | 2 +- getgb1s_8f_source.html | 395 +- getgb_8f.html | 82 +- getgb_8f.js | 2 +- getgb_8f_source.html | 439 +- getgbe_8f.html | 86 +- getgbe_8f.js | 2 +- getgbe_8f_source.html | 461 +- getgbeh_8f.html | 82 +- getgbeh_8f.js | 2 +- getgbeh_8f_source.html | 439 +- getgbem_8f.html | 96 +- getgbem_8f.js | 2 +- getgbem_8f_source.html | 555 +- getgbemh_8f.html | 92 +- getgbemh_8f.js | 2 +- getgbemh_8f_source.html | 535 +- getgbemn_8f.html | 98 +- getgbemn_8f.js | 2 +- getgbemn_8f_source.html | 561 +- getgbemp_8f.html | 94 +- getgbemp_8f.js | 2 +- getgbemp_8f_source.html | 545 +- getgbens_8f.html | 86 +- getgbens_8f.js | 2 +- getgbens_8f_source.html | 429 +- getgbep_8f.html | 84 +- getgbep_8f.js | 2 +- getgbep_8f_source.html | 451 +- getgbex_8f.html | 94 +- getgbex_8f.js | 2 +- getgbex_8f_source.html | 483 +- getgbexm_8f.html | 104 +- getgbexm_8f.js | 2 +- getgbexm_8f_source.html | 569 +- getgbh_8f.html | 78 +- getgbh_8f.js | 2 +- getgbh_8f_source.html | 425 +- getgbm_8f.html | 92 +- getgbm_8f.js | 2 +- getgbm_8f_source.html | 545 +- getgbmh_8f.html | 88 +- getgbmh_8f.js | 2 +- getgbmh_8f_source.html | 519 +- getgbmp_8f.html | 90 +- getgbmp_8f.js | 2 +- getgbmp_8f_source.html | 529 +- getgbp_8f.html | 80 +- getgbp_8f.js | 2 +- getgbp_8f_source.html | 431 +- getgi_8f.html | 70 +- getgi_8f.js | 2 +- getgi_8f_source.html | 207 +- getgir_8f.html | 74 +- getgir_8f.js | 2 +- getgir_8f_source.html | 213 +- globals.html | 79 +- globals_b.html | 47 +- globals_c.html | 55 +- globals_e.html | 59 +- globals_f.html | 279 +- globals_func.html | 81 +- globals_func_b.html | 49 +- globals_func_c.html | 57 +- globals_func_e.html | 61 +- globals_func_f.html | 281 +- globals_func_g.html | 154 +- globals_func_i.html | 90 +- globals_func_l.html | 61 +- globals_func_m.html | 78 +- globals_func_o.html | 49 +- globals_func_p.html | 81 +- globals_func_q.html | 57 +- globals_func_r.html | 69 +- globals_func_s.html | 81 +- globals_func_u.html | 81 +- globals_func_v.html | 49 +- globals_func_w.html | 610 +- globals_func_x.html | 57 +- globals_g.html | 152 +- globals_i.html | 88 +- globals_l.html | 59 +- globals_m.html | 76 +- globals_o.html | 47 +- globals_p.html | 79 +- globals_q.html | 55 +- globals_r.html | 67 +- globals_s.html | 79 +- globals_u.html | 79 +- globals_v.html | 47 +- globals_w.html | 608 +- globals_x.html | 55 +- gtbits_8f.html | 74 +- gtbits_8f.js | 2 +- gtbits_8f_source.html | 199 +- idsdef_8f.html | 60 +- idsdef_8f.js | 2 +- idsdef_8f_source.html | 609 +- index.html | 230 +- instrument_8f.html | 68 +- instrument_8f.js | 2 +- instrument_8f_source.html | 203 +- interfaceargs__mod_1_1getarg.html | 117 - interfaceargs__mod_1_1getarg.js | 5 - interfaceargs__mod_1_1iargc.html | 114 - interfaceargs__mod_1_1iargc.js | 4 - ...acemersenne__twister_1_1random__gauss.html | 239 + ...rfacemersenne__twister_1_1random__gauss.js | 6 + ...acemersenne__twister_1_1random__index.html | 264 + ...rfacemersenne__twister_1_1random__index.js | 6 + ...cemersenne__twister_1_1random__number.html | 239 + ...facemersenne__twister_1_1random__number.js | 6 + ...emersenne__twister_1_1random__setseed.html | 195 + ...acemersenne__twister_1_1random__setseed.js | 5 + isrchne_8f.html | 64 +- isrchne_8f.js | 2 +- isrchne_8f_source.html | 117 +- iw3jdn_8f.html | 62 +- iw3jdn_8f.js | 2 +- iw3jdn_8f_source.html | 149 +- iw3mat_8f.html | 62 +- iw3mat_8f.js | 2 +- iw3mat_8f_source.html | 115 +- iw3pds_8f.html | 107 +- iw3pds_8f.js | 2 +- iw3pds_8f_source.html | 344 +- iw3unp29_8f.html | 616 +- iw3unp29_8f.js | 30 +- iw3unp29_8f_source.html | 9291 +++++++++-------- ixgb_8f.html | 70 +- ixgb_8f.js | 2 +- ixgb_8f_source.html | 343 +- jquery.js | 11 +- lengds_8f.html | 58 +- lengds_8f.js | 2 +- lengds_8f_source.html | 115 +- makgds_8f90.html | 195 + makgds_8f90.js | 4 + makgds_8f90_source.html | 133 +- makwmo_8f.html | 66 +- makwmo_8f.js | 2 +- makwmo_8f_source.html | 209 +- menu.js | 97 +- menudata.js | 7 +- mersenne__twister_8f.html | 87 +- mersenne__twister_8f.js | 30 +- mersenne__twister_8f_source.html | 740 +- minus.svg | 8 + minusd.svg | 8 + mkfldsep_8f.html | 63 +- mkfldsep_8f_source.html | 246 +- mova2i_8f.html | 54 +- mova2i_8f_source.html | 123 +- namespaceargs__mod.html | 127 - namespaceargs__mod.js | 7 - namespacemembers.html | 57 +- namespacemembers_func.html | 59 +- namespacemersenne__twister.html | 155 +- namespacemersenne__twister.js | 12 + namespaces.html | 54 +- namespaces_dup.js | 30 +- nav_fd.png | Bin 0 -> 169 bytes nav_hd.png | Bin 0 -> 114 bytes navtree.css | 23 +- navtree.js | 37 +- navtreedata.js | 42 +- navtreeindex0.js | 496 +- navtreeindex1.js | 498 +- navtreeindex2.js | 500 +- navtreeindex3.js | 343 +- orders_8f.html | 285 +- orders_8f.js | 5 +- orders_8f_source.html | 823 +- pdsens_8f.html | 72 +- pdsens_8f.js | 2 +- pdsens_8f_source.html | 189 +- pdseup_8f.html | 72 +- pdseup_8f.js | 2 +- pdseup_8f_source.html | 185 +- plus.svg | 9 + plusd.svg | 9 + putgb_8f.html | 70 +- putgb_8f.js | 2 +- putgb_8f_source.html | 418 +- putgbe_8f.html | 74 +- putgbe_8f.js | 2 +- putgbe_8f_source.html | 446 +- putgben_8f.html | 78 +- putgben_8f.js | 2 +- putgben_8f_source.html | 464 +- putgbens_8f.html | 72 +- putgbens_8f.js | 2 +- putgbens_8f_source.html | 351 +- putgbex_8f.html | 80 +- putgbex_8f.js | 2 +- putgbex_8f_source.html | 460 +- putgbn_8f.html | 74 +- putgbn_8f.js | 2 +- putgbn_8f_source.html | 432 +- q9ie32_8f.html | 64 +- q9ie32_8f.js | 2 +- q9ie32_8f_source.html | 313 +- r63w72_8f.html | 78 +- r63w72_8f.js | 2 +- r63w72_8f_source.html | 285 +- resize.js | 97 +- sbyte_8f.html | 66 +- sbyte_8f.js | 2 +- sbyte_8f_source.html | 209 +- sbytec_8f.html | 70 +- sbytec_8f.js | 2 +- sbytec_8f_source.html | 91 +- sbytes_8f.html | 108 +- sbytes_8f.js | 4 - sbytes_8f_source.html | 267 +- sbytesc_8f.html | 68 +- sbytesc_8f.js | 2 +- sbytesc_8f_source.html | 185 +- search/all_0.html | 37 - search/all_0.js | 14 +- search/all_1.html | 37 - search/all_1.js | 3 +- search/all_10.html | 37 - search/all_10.js | 290 +- search/all_11.html | 37 - search/all_11.js | 16 +- search/all_12.js | 33 + search/all_13.js | 7 + search/all_14.js | 36 + search/all_15.js | 30 + search/all_16.js | 17 + search/all_17.js | 14 + search/all_18.js | 6 + search/all_19.js | 298 + search/all_1a.js | 9 + search/all_2.html | 37 - search/all_2.js | 4 +- search/all_3.html | 37 - search/all_3.js | 7 +- search/all_4.html | 37 - search/all_4.js | 62 +- search/all_5.html | 37 - search/all_5.js | 79 +- search/all_6.html | 37 - search/all_6.js | 26 +- search/all_7.html | 37 - search/all_7.js | 16 +- search/all_8.html | 37 - search/all_8.js | 27 +- search/all_9.html | 37 - search/all_9.js | 12 +- search/all_a.html | 37 - search/all_a.js | 95 +- search/all_b.html | 37 - search/all_b.js | 64 +- search/all_c.html | 37 - search/all_c.js | 15 +- search/all_d.html | 37 - search/all_d.js | 45 +- search/all_e.html | 37 - search/all_e.js | 23 +- search/all_f.html | 37 - search/all_f.js | 18 +- search/classes_0.html | 37 - search/classes_0.js | 6 +- search/classes_1.html | 37 - search/classes_1.js | 4 - search/close.png | Bin 273 -> 0 bytes search/close.svg | 18 + search/files_0.html | 37 - search/files_0.js | 3 +- search/files_1.html | 37 - search/files_1.js | 4 +- search/files_2.html | 37 - search/files_2.js | 4 +- search/files_3.html | 37 - search/files_3.js | 56 +- search/files_4.html | 37 - search/files_4.js | 16 +- search/files_5.html | 37 - search/files_5.js | 2 +- search/files_6.html | 37 - search/files_6.js | 9 +- search/files_7.html | 37 - search/files_7.js | 2 +- search/files_8.html | 37 - search/files_8.js | 16 +- search/files_9.html | 37 - search/files_9.js | 2 +- search/files_a.html | 37 - search/files_a.js | 2 +- search/files_b.html | 37 - search/files_b.js | 12 +- search/files_c.html | 37 - search/files_c.js | 286 +- search/files_d.html | 37 - search/files_d.js | 6 +- search/functions_0.html | 37 - search/functions_0.js | 18 +- search/functions_1.html | 37 - search/functions_1.js | 2 +- search/functions_10.html | 37 - search/functions_10.js | 283 +- search/functions_11.html | 37 - search/functions_11.js | 6 +- search/functions_2.html | 37 - search/functions_2.js | 6 +- search/functions_3.html | 37 - search/functions_3.js | 8 +- search/functions_4.html | 37 - search/functions_4.js | 118 +- search/functions_5.html | 37 - search/functions_5.js | 55 +- search/functions_6.html | 37 - search/functions_6.js | 23 +- search/functions_7.html | 37 - search/functions_7.js | 8 +- search/functions_8.html | 37 - search/functions_8.js | 17 +- search/functions_9.html | 37 - search/functions_9.js | 2 +- search/functions_a.html | 37 - search/functions_a.js | 18 +- search/functions_b.html | 37 - search/functions_b.js | 6 +- search/functions_c.html | 37 - search/functions_c.js | 31 +- search/functions_d.html | 37 - search/functions_d.js | 18 +- search/functions_e.html | 37 - search/functions_e.js | 18 +- search/functions_f.html | 37 - search/functions_f.js | 2 +- search/mag.svg | 24 + search/mag_d.svg | 24 + search/mag_sel.png | Bin 465 -> 0 bytes search/mag_sel.svg | 31 + search/mag_seld.svg | 31 + search/namespaces_0.html | 37 - search/namespaces_0.js | 2 +- search/namespaces_1.html | 37 - search/namespaces_1.js | 4 - search/nomatches.html | 13 - search/pages_0.js | 4 + search/pages_1.js | 4 + search/search.css | 122 +- search/search.js | 188 +- search/search_l.png | Bin 567 -> 0 bytes search/search_m.png | Bin 158 -> 0 bytes search/search_r.png | Bin 553 -> 0 bytes search/searchdata.js | 15 +- skgb_8f.html | 66 +- skgb_8f.js | 2 +- skgb_8f_source.html | 189 +- splitbard.png | Bin 0 -> 282 bytes structmersenne__twister_1_1random__stat.html | 172 + summary_8c.html | 2790 ++++- summary_8c.js | 143 +- summary_8c_source.html | 905 +- tab_ad.png | Bin 0 -> 135 bytes tab_bd.png | Bin 0 -> 173 bytes tab_hd.png | Bin 0 -> 180 bytes tab_sd.png | Bin 0 -> 188 bytes tabs.css | 2 +- ver-2.10.0/index.html | 6 - ver-2.11.0/index.html | 7 - ver-2.9.3/index.html | 5 - w3ai00_8f.html | 98 +- w3ai00_8f.js | 6 +- w3ai00_8f_source.html | 955 +- w3ai01_8f.html | 62 +- w3ai01_8f.js | 2 +- w3ai01_8f_source.html | 251 +- w3ai08_8f.html | 228 +- w3ai08_8f.js | 18 +- w3ai08_8f_source.html | 5629 +++++----- w3ai15_8f.html | 66 +- w3ai15_8f.js | 2 +- w3ai15_8f_source.html | 289 +- w3ai18_8f.html | 70 +- w3ai18_8f.js | 2 +- w3ai18_8f_source.html | 261 +- w3ai19_8f.html | 66 +- w3ai19_8f.js | 2 +- w3ai19_8f_source.html | 287 +- w3ai24_8f.html | 62 +- w3ai24_8f.js | 2 +- w3ai24_8f_source.html | 123 +- w3ai38_8f.html | 60 +- w3ai38_8f.js | 2 +- w3ai38_8f_source.html | 203 +- w3ai39_8f.html | 60 +- w3ai39_8f.js | 2 +- w3ai39_8f_source.html | 197 +- w3ai40_8f.html | 66 +- w3ai40_8f.js | 2 +- w3ai40_8f_source.html | 231 +- w3ai41_8f.html | 68 +- w3ai41_8f.js | 2 +- w3ai41_8f_source.html | 209 +- w3aq15_8f.html | 58 +- w3aq15_8f.js | 2 +- w3aq15_8f_source.html | 147 +- w3as00_8f.html | 100 +- w3as00_8f.js | 2 - w3as00_8f_source.html | 652 +- w3ctzdat_8f.html | 54 +- w3ctzdat_8f_source.html | 119 +- w3difdat_8f.html | 54 +- w3difdat_8f_source.html | 83 +- w3doxdat_8f.html | 54 +- w3doxdat_8f_source.html | 73 +- w3fa01_8f.html | 68 +- w3fa01_8f.js | 2 +- w3fa01_8f_source.html | 215 +- w3fa03_8f.html | 64 +- w3fa03_8f.js | 2 +- w3fa03_8f_source.html | 189 +- w3fa03v_8f.html | 111 +- w3fa03v_8f.js | 2 +- w3fa03v_8f_source.html | 214 +- w3fa04_8f.html | 64 +- w3fa04_8f.js | 2 +- w3fa04_8f_source.html | 201 +- w3fa06_8f.html | 66 +- w3fa06_8f.js | 2 +- w3fa06_8f_source.html | 265 +- w3fa09_8f.html | 58 +- w3fa09_8f.js | 2 +- w3fa09_8f_source.html | 163 +- w3fa11_8f.html | 60 +- w3fa11_8f.js | 2 +- w3fa11_8f_source.html | 145 +- w3fa12_8f.html | 104 +- w3fa12_8f.js | 2 +- w3fa12_8f_source.html | 188 +- w3fa13_8f.html | 66 +- w3fa13_8f.js | 2 +- w3fa13_8f_source.html | 201 +- w3fb00_8f.html | 68 +- w3fb00_8f.js | 2 +- w3fb00_8f_source.html | 141 +- w3fb01_8f.html | 70 +- w3fb01_8f.js | 2 +- w3fb01_8f_source.html | 169 +- w3fb02_8f.html | 66 +- w3fb02_8f.js | 2 +- w3fb02_8f_source.html | 167 +- w3fb03_8f.html | 66 +- w3fb03_8f.js | 2 +- w3fb03_8f_source.html | 161 +- w3fb04_8f.html | 70 +- w3fb04_8f.js | 2 +- w3fb04_8f_source.html | 177 +- w3fb05_8f.html | 121 +- w3fb05_8f.js | 2 +- w3fb05_8f_source.html | 196 +- w3fb06_8f.html | 74 +- w3fb06_8f.js | 2 +- w3fb06_8f_source.html | 231 +- w3fb07_8f.html | 74 +- w3fb07_8f.js | 2 +- w3fb07_8f_source.html | 265 +- w3fb08_8f.html | 74 +- w3fb08_8f.js | 2 +- w3fb08_8f_source.html | 165 +- w3fb09_8f.html | 74 +- w3fb09_8f.js | 2 +- w3fb09_8f_source.html | 163 +- w3fb10_8f.html | 70 +- w3fb10_8f.js | 2 +- w3fb10_8f_source.html | 509 +- w3fb11_8f.html | 76 +- w3fb11_8f.js | 2 +- w3fb11_8f_source.html | 277 +- w3fb12_8f.html | 78 +- w3fb12_8f.js | 2 +- w3fb12_8f_source.html | 385 +- w3fc02_8f.html | 68 +- w3fc02_8f.js | 2 +- w3fc02_8f_source.html | 173 +- w3fc05_8f.html | 64 +- w3fc05_8f.js | 2 +- w3fc05_8f_source.html | 149 +- w3fc06_8f.html | 64 +- w3fc06_8f.js | 2 +- w3fc06_8f_source.html | 121 +- w3fc07_8f.html | 68 +- w3fc07_8f.js | 2 +- w3fc07_8f_source.html | 161 +- w3fc08_8f.html | 68 +- w3fc08_8f.js | 2 +- w3fc08_8f_source.html | 165 +- w3fi01_8f.html | 58 +- w3fi01_8f.js | 2 +- w3fi01_8f_source.html | 101 +- w3fi02_8f.html | 62 +- w3fi02_8f.js | 2 +- w3fi02_8f_source.html | 113 +- w3fi03_8f.html | 66 +- w3fi03_8f.js | 2 +- w3fi03_8f_source.html | 123 +- w3fi04_8f.html | 62 +- w3fi04_8f.js | 2 +- w3fi04_8f_source.html | 279 +- w3fi18_8f.html | 62 +- w3fi18_8f.js | 2 +- w3fi18_8f_source.html | 147 +- w3fi19_8f.html | 62 +- w3fi19_8f.js | 2 +- w3fi19_8f_source.html | 139 +- w3fi20_8f.html | 60 +- w3fi20_8f.js | 2 +- w3fi20_8f_source.html | 173 +- w3fi32_8f.html | 62 +- w3fi32_8f.js | 2 +- w3fi32_8f_source.html | 333 +- w3fi47_8f.html | 60 +- w3fi47_8f.js | 2 +- w3fi47_8f_source.html | 189 +- w3fi48_8f.html | 60 +- w3fi48_8f.js | 2 +- w3fi48_8f_source.html | 195 +- w3fi52_8f.html | 178 - w3fi52_8f.js | 4 - w3fi52_8f_source.html | 436 - w3fi58_8f.html | 72 +- w3fi58_8f.js | 2 +- w3fi58_8f_source.html | 249 +- w3fi59_8f.html | 74 +- w3fi59_8f.js | 2 +- w3fi59_8f_source.html | 295 +- w3fi61_8f.html | 68 +- w3fi61_8f.js | 2 +- w3fi61_8f_source.html | 453 +- w3fi62_8f.html | 64 +- w3fi62_8f.js | 2 +- w3fi62_8f_source.html | 465 +- w3fi63_8f.html | 234 +- w3fi63_8f.js | 18 +- w3fi63_8f_source.html | 7793 +++++++------- w3fi64_8f.html | 72 +- w3fi64_8f.js | 2 +- w3fi64_8f_source.html | 1581 +-- w3fi65_8f.html | 68 +- w3fi65_8f.js | 2 +- w3fi65_8f_source.html | 817 +- w3fi66_8f.html | 76 +- w3fi66_8f.js | 2 +- w3fi66_8f_source.html | 299 +- w3fi67_8f.html | 380 +- w3fi67_8f.js | 22 +- w3fi67_8f_source.html | 5407 +++++----- w3fi68_8f.html | 60 +- w3fi68_8f.js | 2 +- w3fi68_8f_source.html | 397 +- w3fi69_8f.html | 60 +- w3fi69_8f.js | 2 +- w3fi69_8f_source.html | 331 +- w3fi70_8f.html | 64 +- w3fi70_8f.js | 2 +- w3fi70_8f_source.html | 1723 +-- w3fi71_8f.html | 64 +- w3fi71_8f.js | 2 +- w3fi71_8f_source.html | 3365 +++--- w3fi72_8f.html | 106 +- w3fi72_8f.js | 2 +- w3fi72_8f_source.html | 865 +- w3fi73_8f.html | 68 +- w3fi73_8f.js | 2 +- w3fi73_8f_source.html | 233 +- w3fi74_8f.html | 70 +- w3fi74_8f.js | 2 +- w3fi74_8f_source.html | 855 +- w3fi75_8f.html | 294 +- w3fi75_8f.js | 18 +- w3fi75_8f_source.html | 3213 +++--- w3fi76_8f.html | 64 +- w3fi76_8f.js | 2 +- w3fi76_8f_source.html | 297 +- w3fi78_8f.html | 467 +- w3fi78_8f.js | 22 +- w3fi78_8f_source.html | 5615 +++++----- w3fi82_8f.html | 68 +- w3fi82_8f.js | 2 +- w3fi82_8f_source.html | 231 +- w3fi83_8f.html | 72 +- w3fi83_8f.js | 2 +- w3fi83_8f_source.html | 251 +- w3fi85_8f.html | 510 +- w3fi85_8f.js | 22 +- w3fi85_8f_source.html | 5025 ++++----- w3fi88_8f.html | 1290 ++- w3fi88_8f.js | 31 +- w3fi88_8f_source.html | 9273 ++++++++-------- w3fi92_8f.html | 70 +- w3fi92_8f.js | 2 +- w3fi92_8f_source.html | 461 +- w3fm07_8f.html | 68 +- w3fm07_8f.js | 2 +- w3fm07_8f_source.html | 265 +- w3fm08_8f.html | 64 +- w3fm08_8f.js | 2 +- w3fm08_8f_source.html | 159 +- w3fp04_8f.html | 80 +- w3fp04_8f.js | 2 +- w3fp04_8f_source.html | 968 +- w3fp05_8f.html | 72 +- w3fp05_8f.js | 2 +- w3fp05_8f_source.html | 1239 +-- w3fp06_8f.html | 164 +- w3fp06_8f.js | 14 +- w3fp06_8f_source.html | 2143 ++-- w3fp10_8f.html | 76 +- w3fp10_8f.js | 2 +- w3fp10_8f_source.html | 1441 +-- w3fp11_8f.html | 66 +- w3fp11_8f.js | 2 +- w3fp11_8f_source.html | 1685 +-- w3fp12_8f.html | 72 +- w3fp12_8f.js | 2 +- w3fp12_8f_source.html | 1245 +-- w3fp13_8f.html | 66 +- w3fp13_8f.js | 2 +- w3fp13_8f_source.html | 1881 ++-- w3fq07_8f.html | 235 - w3fq07_8f.js | 4 - w3fq07_8f_source.html | 559 - w3fs13_8f.html | 66 +- w3fs13_8f.js | 2 +- w3fs13_8f_source.html | 117 +- w3fs15_8f.html | 64 +- w3fs15_8f.js | 2 +- w3fs15_8f_source.html | 441 +- w3fs21_8f.html | 62 +- w3fs21_8f.js | 2 +- w3fs21_8f_source.html | 177 +- w3fs26_8f.html | 70 +- w3fs26_8f.js | 2 +- w3fs26_8f_source.html | 195 +- w3ft00_8f.html | 84 +- w3ft00_8f.js | 2 +- w3ft00_8f_source.html | 345 +- w3ft01_8f.html | 74 +- w3ft01_8f.js | 2 +- w3ft01_8f_source.html | 381 +- w3ft02_8f.html | 72 +- w3ft02_8f.js | 2 +- w3ft02_8f_source.html | 449 +- w3ft03_8f.html | 72 +- w3ft03_8f.js | 2 +- w3ft03_8f_source.html | 209 +- w3ft05_8f.html | 70 +- w3ft05_8f.js | 2 +- w3ft05_8f_source.html | 507 +- w3ft05v_8f.html | 66 +- w3ft05v_8f.js | 2 +- w3ft05v_8f_source.html | 559 +- w3ft06_8f.html | 70 +- w3ft06_8f.js | 2 +- w3ft06_8f_source.html | 493 +- w3ft06v_8f.html | 64 +- w3ft06v_8f.js | 2 +- w3ft06v_8f_source.html | 559 +- w3ft07_8f.html | 90 +- w3ft07_8f.js | 2 +- w3ft07_8f_source.html | 497 +- w3ft08_8f.html | 78 +- w3ft08_8f.js | 2 +- w3ft08_8f_source.html | 216 +- w3ft09_8f.html | 80 +- w3ft09_8f.js | 2 +- w3ft09_8f_source.html | 234 +- w3ft10_8f.html | 78 +- w3ft10_8f.js | 2 +- w3ft10_8f_source.html | 220 +- w3ft11_8f.html | 82 +- w3ft11_8f.js | 2 +- w3ft11_8f_source.html | 236 +- w3ft12_8f.html | 68 +- w3ft12_8f.js | 2 +- w3ft12_8f_source.html | 503 +- w3ft16_8f.html | 64 +- w3ft16_8f.js | 2 +- w3ft16_8f_source.html | 455 +- w3ft17_8f.html | 64 +- w3ft17_8f.js | 2 +- w3ft17_8f_source.html | 457 +- w3ft201_8f.html | 68 +- w3ft201_8f.js | 2 +- w3ft201_8f_source.html | 551 +- w3ft202_8f.html | 66 +- w3ft202_8f.js | 2 +- w3ft202_8f_source.html | 441 +- w3ft203_8f.html | 66 +- w3ft203_8f.js | 2 +- w3ft203_8f_source.html | 553 +- w3ft204_8f.html | 64 +- w3ft204_8f.js | 2 +- w3ft204_8f_source.html | 409 +- w3ft205_8f.html | 66 +- w3ft205_8f.js | 2 +- w3ft205_8f_source.html | 477 +- w3ft206_8f.html | 66 +- w3ft206_8f.js | 2 +- w3ft206_8f_source.html | 373 +- w3ft207_8f.html | 66 +- w3ft207_8f.js | 2 +- w3ft207_8f_source.html | 541 +- w3ft208_8f.html | 64 +- w3ft208_8f.js | 2 +- w3ft208_8f_source.html | 411 +- w3ft209_8f.html | 66 +- w3ft209_8f.js | 2 +- w3ft209_8f_source.html | 377 +- w3ft210_8f.html | 64 +- w3ft210_8f.js | 2 +- w3ft210_8f_source.html | 407 +- w3ft211_8f.html | 66 +- w3ft211_8f.js | 2 +- w3ft211_8f_source.html | 373 +- w3ft212_8f.html | 66 +- w3ft212_8f.js | 2 +- w3ft212_8f_source.html | 375 +- w3ft213_8f.html | 66 +- w3ft213_8f.js | 2 +- w3ft213_8f_source.html | 539 +- w3ft214_8f.html | 64 +- w3ft214_8f.js | 2 +- w3ft214_8f_source.html | 541 +- w3ft21_8f.html | 86 +- w3ft21_8f.js | 2 +- w3ft21_8f_source.html | 226 +- w3ft26_8f.html | 70 +- w3ft26_8f.js | 2 +- w3ft26_8f_source.html | 291 +- w3ft32_8f.html | 70 +- w3ft32_8f.js | 2 +- w3ft32_8f_source.html | 2507 ++--- w3ft33_8f.html | 64 +- w3ft33_8f.js | 2 +- w3ft33_8f_source.html | 327 +- w3ft38_8f.html | 93 +- w3ft38_8f.js | 2 +- w3ft38_8f_source.html | 225 +- w3ft39_8f.html | 97 +- w3ft39_8f.js | 2 +- w3ft39_8f_source.html | 251 +- w3ft40_8f.html | 93 +- w3ft40_8f.js | 2 +- w3ft40_8f_source.html | 235 +- w3ft41_8f.html | 97 +- w3ft41_8f.js | 2 +- w3ft41_8f_source.html | 253 +- w3ft43v_8f.html | 64 +- w3ft43v_8f.js | 2 +- w3ft43v_8f_source.html | 551 +- w3kind_8f.html | 56 +- w3kind_8f_source.html | 77 +- w3locdat_8f.html | 56 +- w3locdat_8f_source.html | 75 +- w3log_8f_source.html | 53 +- w3miscan_8f.html | 254 +- w3miscan_8f.js | 18 +- w3miscan_8f_source.html | 3419 +++--- w3movdat_8f.html | 56 +- w3movdat_8f_source.html | 97 +- w3nogds_8f.html | 100 +- w3nogds_8f.js | 2 +- w3nogds_8f_source.html | 901 +- w3pradat_8f.html | 56 +- w3pradat_8f_source.html | 141 +- w3reddat_8f.html | 56 +- w3reddat_8f_source.html | 155 +- w3tagb_8f.html | 70 +- w3tagb_8f.js | 2 +- w3tagb_8f_source.html | 257 +- w3trnarg_8f.html | 81 +- w3trnarg_8f.js | 2 +- w3trnarg_8f_source.html | 377 +- w3unpk77_8f.html | 236 +- w3unpk77_8f.js | 20 +- w3unpk77_8f_source.html | 4831 ++++----- w3utcdat_8f.html | 56 +- w3utcdat_8f_source.html | 123 +- w3valdat_8f.html | 56 +- w3valdat_8f_source.html | 101 +- w3ymdh4_8f.html | 70 +- w3ymdh4_8f.js | 2 +- w3ymdh4_8f_source.html | 243 +- xdopen_8f.html | 56 +- xdopen_8f_source.html | 157 +- xmovex_8f.html | 62 +- xmovex_8f.js | 2 +- xmovex_8f_source.html | 115 +- xstore_8f.html | 64 +- xstore_8f.js | 2 +- xstore_8f_source.html | 127 +- 866 files changed, 91828 insertions(+), 86459 deletions(-) delete mode 100644 args__mod_8f.html delete mode 100644 args__mod_8f.js delete mode 100644 args__mod_8f_source.html create mode 100644 bc_sd.png delete mode 100644 bdwn.png create mode 100644 dir_68267d1309a1af8e8297ef4c3efbcdba.js delete mode 100644 doc.png create mode 100644 doc.svg create mode 100644 docd.svg delete mode 100644 doxygen.png create mode 100644 doxygen.svg delete mode 100644 folderclosed.png create mode 100644 folderclosed.svg create mode 100644 folderclosedd.svg delete mode 100644 folderopen.png create mode 100644 folderopen.svg create mode 100644 folderopend.svg create mode 100644 functions.html create mode 100644 functions_func.html delete mode 100644 interfaceargs__mod_1_1getarg.html delete mode 100644 interfaceargs__mod_1_1getarg.js delete mode 100644 interfaceargs__mod_1_1iargc.html delete mode 100644 interfaceargs__mod_1_1iargc.js create mode 100644 interfacemersenne__twister_1_1random__gauss.html create mode 100644 interfacemersenne__twister_1_1random__gauss.js create mode 100644 interfacemersenne__twister_1_1random__index.html create mode 100644 interfacemersenne__twister_1_1random__index.js create mode 100644 interfacemersenne__twister_1_1random__number.html create mode 100644 interfacemersenne__twister_1_1random__number.js create mode 100644 interfacemersenne__twister_1_1random__setseed.html create mode 100644 interfacemersenne__twister_1_1random__setseed.js create mode 100644 makgds_8f90.html create mode 100644 makgds_8f90.js create mode 100644 minus.svg create mode 100644 minusd.svg delete mode 100644 namespaceargs__mod.html delete mode 100644 namespaceargs__mod.js create mode 100644 namespacemersenne__twister.js create mode 100644 nav_fd.png create mode 100644 nav_hd.png create mode 100644 plus.svg create mode 100644 plusd.svg delete mode 100644 sbytes_8f.js delete mode 100644 search/all_0.html delete mode 100644 search/all_1.html delete mode 100644 search/all_10.html delete mode 100644 search/all_11.html create mode 100644 search/all_12.js create mode 100644 search/all_13.js create mode 100644 search/all_14.js create mode 100644 search/all_15.js create mode 100644 search/all_16.js create mode 100644 search/all_17.js create mode 100644 search/all_18.js create mode 100644 search/all_19.js create mode 100644 search/all_1a.js delete mode 100644 search/all_2.html delete mode 100644 search/all_3.html delete mode 100644 search/all_4.html delete mode 100644 search/all_5.html delete mode 100644 search/all_6.html delete mode 100644 search/all_7.html delete mode 100644 search/all_8.html delete mode 100644 search/all_9.html delete mode 100644 search/all_a.html delete mode 100644 search/all_b.html delete mode 100644 search/all_c.html delete mode 100644 search/all_d.html delete mode 100644 search/all_e.html delete mode 100644 search/all_f.html delete mode 100644 search/classes_0.html delete mode 100644 search/classes_1.html delete mode 100644 search/classes_1.js delete mode 100644 search/close.png create mode 100644 search/close.svg delete mode 100644 search/files_0.html delete mode 100644 search/files_1.html delete mode 100644 search/files_2.html delete mode 100644 search/files_3.html delete mode 100644 search/files_4.html delete mode 100644 search/files_5.html delete mode 100644 search/files_6.html delete mode 100644 search/files_7.html delete mode 100644 search/files_8.html delete mode 100644 search/files_9.html delete mode 100644 search/files_a.html delete mode 100644 search/files_b.html delete mode 100644 search/files_c.html delete mode 100644 search/files_d.html delete mode 100644 search/functions_0.html delete mode 100644 search/functions_1.html delete mode 100644 search/functions_10.html delete mode 100644 search/functions_11.html delete mode 100644 search/functions_2.html delete mode 100644 search/functions_3.html delete mode 100644 search/functions_4.html delete mode 100644 search/functions_5.html delete mode 100644 search/functions_6.html delete mode 100644 search/functions_7.html delete mode 100644 search/functions_8.html delete mode 100644 search/functions_9.html delete mode 100644 search/functions_a.html delete mode 100644 search/functions_b.html delete mode 100644 search/functions_c.html delete mode 100644 search/functions_d.html delete mode 100644 search/functions_e.html delete mode 100644 search/functions_f.html create mode 100644 search/mag.svg create mode 100644 search/mag_d.svg delete mode 100644 search/mag_sel.png create mode 100644 search/mag_sel.svg create mode 100644 search/mag_seld.svg delete mode 100644 search/namespaces_0.html delete mode 100644 search/namespaces_1.html delete mode 100644 search/namespaces_1.js delete mode 100644 search/nomatches.html create mode 100644 search/pages_0.js create mode 100644 search/pages_1.js delete mode 100644 search/search_l.png delete mode 100644 search/search_m.png delete mode 100644 search/search_r.png create mode 100644 splitbard.png create mode 100644 structmersenne__twister_1_1random__stat.html create mode 100644 tab_ad.png create mode 100644 tab_bd.png create mode 100644 tab_hd.png create mode 100644 tab_sd.png delete mode 100644 w3fi52_8f.html delete mode 100644 w3fi52_8f.js delete mode 100644 w3fi52_8f_source.html delete mode 100644 w3fq07_8f.html delete mode 100644 w3fq07_8f.js delete mode 100644 w3fq07_8f_source.html diff --git a/aea_8f.html b/aea_8f.html index e6a7c94a..7b72f0ac 100644 --- a/aea_8f.html +++ b/aea_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: aea.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
aea.f File Reference
+
aea.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

subroutine aea (IA, IE, NC)
 Program history log: More...
 
subroutine aea (ia, ie, nc)
 Program history log:
 

Detailed Description

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

@@ -107,8 +113,8 @@

Definition in file aea.f.

Function/Subroutine Documentation

- -

◆ aea()

+ +

◆ aea()

@@ -117,19 +123,19 @@

subroutine aea ( character*1, dimension(*)  - IA, + ia, character*1, dimension(*)  - IE, + ie,   - NC  + nc  @@ -178,7 +184,7 @@

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.
    • +
  • 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.
    • @@ -198,7 +204,7 @@

    • src
    • aea.f
      • -
    • Generated by doxygen 1.9.1
      • +
    • Generated by doxygen 1.9.8

diff --git a/aea_8f.js b/aea_8f.js index bcdecc09..39abb4ea 100644 --- a/aea_8f.js +++ b/aea_8f.js @@ -1,4 +1,4 @@ var aea_8f = [ - [ "aea", "aea_8f.html#a9c58c678406a71b9db512ab40864666c", null ] + [ "aea", "aea_8f.html#a7658132d90c68ca690e04be7d7ef6681", null ] ]; \ No newline at end of file diff --git a/aea_8f_source.html b/aea_8f_source.html index 65123ca6..beb4fc1d 100644 --- a/aea_8f_source.html +++ b/aea_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: aea.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,132 +81,140 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
aea.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief This subroutine converts ascii to ebcdic, or ebcdic to ascii
+
3C> @author desmarais @date 11-29-1982
+
4
+
5C> Program history log:
+
6C> - 11-29-1982 Desmarais
+
7C> - 03-31-1988 R. E. Jones
+
8C> - change logic so it works like a ibm370 translate instruction.
+
9C> - 08-22-1988 R. E. Jones
+
10C> - changes for microsoft fortran 4.10
+
11C> - 09-04-1988 R. E. Jones
+
12C> - change tables to 128 character set
+
13C> - 01-31-1990 R. E. Jones
+
14C> - convert to cray cft77 fortran cray does not allow char*1 to be set to hex
+
15C> - 12-21-1998 Stephen Gilbert
+
16C> - replaced function ichar with mova2i.
+
17C>
+
18C> @param[in, out] IA character*1 array of ascii data if nc < 0
+
19C> @param[in, out] IE character*1 array of ebcdic data if nc > 0
+
20C> @param[in] NC integer, contains character count to convert.
+
21C> - if nc .lt. 0, convert ascii to ebcdic
+
22C> - if nc .gt. 0, convert ebcdic to ascii
+
23C>
+
24C> @note This subroutine can be replaced by cray utility subroutines
+
25C> uscctc and uscctt. See manual sr-2079 page 3-15. Cray utility tr
+
26C> can also be used for ascii, ebcdic conversion. See manual sr-2079
+
27C> page 9-35.
+
28C> @note Software version of ibm370 translate instruction, by
+
29C> changing the two tables we could do a 64, 96, 128 ascii
+
30C> character set, change lower case to upper, etc.
+
31C> - aea() converts data at a rate of 1.5 million characters per sec.
+
32C> - cray utility usccti convert ibm ebcdic to ascii
+
33C> - cray utility uscctc convert ascii to ibm ebcdic
+
34C> - they convert data at a rate of 2.1 million characters per sec.
+
35C> - cray utility tr will also do a ascii, ebcdic conversion.
+
36C> tr convert data at a rate of 5.4 million characters per sec.
+
37C> tr is in library /usr/lib/libcos.a add to segldr card.
+
38C>
+
39C> @author desmarais @date 11-29-1982
+
+
40 SUBROUTINE aea (IA, IE, NC )
+
41C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029
+
42C
+
43 INTEGER(8) IASCII(32)
+
44 INTEGER(8) IEBCDC(32)
+
45C
+
46 CHARACTER*1 IA(*)
+
47 CHARACTER*1 IE(*)
+
48 CHARACTER*1 ASCII(0:255)
+
49 CHARACTER*1 EBCDIC(0:255)
+
50C
+
51 equivalence(iascii(1),ascii(0))
+
52 equivalence(iebcdc(1),ebcdic(0))
+
53C
+
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'/
+
71C
+
72C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS
+
73C
+
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'/
+
84C
+
85 num = iabs(nc)
+
86C
+
87 IF (nc .EQ. 0) RETURN
+
88C
+
89 IF (nc .GT. 0) THEN
+
90C
+
91C*** CONVERT STRING ... EBCDIC TO ASCII, NUM CHARACTERS
+
92C
+
93 DO 10 j = 1, num
+
94 ia(j) = ascii(mova2i(ie(j)))
+
95 10 CONTINUE
+
96C
+
97 ELSE
+
98C
+
99C*** CONVERT STRING ... ASCII TO EBCDIC, NUM CHARACTERS
+
100C
+
101 DO 20 j = 1, num
+
102 ie(j) = ebcdic(mova2i(ia(j)))
+
103 20 CONTINUE
+
104 END IF
+
105C
+
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/annotated.html b/annotated.html index b904a410..a3428e6f 100644 --- a/annotated.html +++ b/annotated.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Data Types List @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,21 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
Data Types List
+
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
 ▼Mmersenne_twisterThis module calculates random numbers using the Mersenne twister
 Crandom_gauss
 Crandom_index
 Crandom_number
 Crandom_setseed
 Crandom_stat
@@ -98,7 +107,7 @@ diff --git a/annotated_dup.js b/annotated_dup.js index 44779e19..43ee464e 100644 --- a/annotated_dup.js +++ b/annotated_dup.js @@ -1,7 +1,10 @@ var annotated_dup = [ - [ "args_mod", "namespaceargs__mod.html", [ - [ "getarg", "interfaceargs__mod_1_1getarg.html", "interfaceargs__mod_1_1getarg" ], - [ "iargc", "interfaceargs__mod_1_1iargc.html", "interfaceargs__mod_1_1iargc" ] + [ "mersenne_twister", "namespacemersenne__twister.html", [ + [ "random_gauss", "interfacemersenne__twister_1_1random__gauss.html", "interfacemersenne__twister_1_1random__gauss" ], + [ "random_index", "interfacemersenne__twister_1_1random__index.html", "interfacemersenne__twister_1_1random__index" ], + [ "random_number", "interfacemersenne__twister_1_1random__number.html", "interfacemersenne__twister_1_1random__number" ], + [ "random_setseed", "interfacemersenne__twister_1_1random__setseed.html", "interfacemersenne__twister_1_1random__setseed" ], + [ "random_stat", "structmersenne__twister_1_1random__stat.html", null ] ] ] ]; \ No newline at end of file diff --git a/args__mod_8f.html b/args__mod_8f.html deleted file mode 100644 index f7646ef0..00000000 --- a/args__mod_8f.html +++ /dev/null @@ -1,137 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: args_mod.f File Reference - - - - - - - - - - - - - -
-
- - - - - - -
-
NCEPLIBS-w3emc -  2.11.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/args__mod_8f.js b/args__mod_8f.js deleted file mode 100644 index 72c9234e..00000000 --- a/args__mod_8f.js +++ /dev/null @@ -1,7 +0,0 @@ -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/args__mod_8f_source.html b/args__mod_8f_source.html deleted file mode 100644 index 5ebdc77f..00000000 --- a/args__mod_8f_source.html +++ /dev/null @@ -1,136 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: args_mod.f Source File - - - - - - - - - - - - - -
-
- - - - - - -
-
NCEPLIBS-w3emc -  2.11.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::getarg
Definition: args_mod.f:14
-
args_mod::iargc
Definition: args_mod.f:11
-
args_mod
This Fortran Module acts as a wrapper to the system routines IARGC and GETARG.
Definition: args_mod.f:10
-
-
- - - - diff --git a/bc_sd.png b/bc_sd.png new file mode 100644 index 0000000000000000000000000000000000000000..31ca888dc71049713b35c351933a8d0f36180bf1 GIT binary patch literal 635 zcmV->0)+jEP)Jwi0r1~gdSq#w{Bu1q z`craw(p2!hu$4C_$Oc3X(sI6e=9QSTwPt{G) z=htT&^~&c~L2~e{r5_5SYe7#Is-$ln>~Kd%$F#tC65?{LvQ}8O`A~RBB0N~`2M+waajO;5>3B&-viHGJeEK2TQOiPRa zfDKyqwMc4wfaEh4jt>H`nW_Zidwk@Bowp`}(VUaj-pSI(-1L>FJVsX}Yl9~JsqgsZ zUD9(rMwf23Gez6KPa|wwInZodP-2}9@fK0Ga_9{8SOjU&4l`pH4@qlQp83>>HT$xW zER^U>)MyV%t(Lu=`d=Y?{k1@}&r7ZGkFQ%z%N+sE9BtYjovzxyxCPxN6&@wLK{soQ zSmkj$aLI}miuE^p@~4}mg9OjDfGEkgY4~^XzLRUBB*O{+&vq<3v(E%+k_i%=`~j%{ Vj14gnt9}3g002ovPDHLkV1n!oC4m3{ literal 0 HcmV?d00001 diff --git a/bdwn.png b/bdwn.png deleted file mode 100644 index 940a0b950443a0bb1b216ac03c45b8a16c955452..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 147 zcmeAS@N?(olHy`uVBq!ia0vp^>_E)H!3HEvS)PKZC{Gv1kP61Pb5HX&C2wk~_T - + - - + + -NCEPLIBS-w3emc: Data Types +NCEPLIBS-w3emc: Data Type Index @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,34 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
Data Types
+
Data Type Index
-
G | I
+
R
-
G
-
getarg (args_mod)
-
-
I
-
iargc (args_mod)
+
R
+
random_gauss (mersenne_twister)
random_index (mersenne_twister)
random_number (mersenne_twister)
random_setseed (mersenne_twister)
random_stat (mersenne_twister)
diff --git a/dir_49e56c817e5e54854c35e136979f97ca.html b/dir_49e56c817e5e54854c35e136979f97ca.html index ac034fad..10baa18f 100644 --- a/dir_49e56c817e5e54854c35e136979f97ca.html +++ b/dir_49e56c817e5e54854c35e136979f97ca.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: docs Directory Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,14 +76,20 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
docs Directory Reference
+
docs Directory Reference
@@ -92,7 +98,7 @@ diff --git a/dir_68267d1309a1af8e8297ef4c3efbcdba.html b/dir_68267d1309a1af8e8297ef4c3efbcdba.html index edd4e907..d9749e1b 100644 --- a/dir_68267d1309a1af8e8297ef4c3efbcdba.html +++ b/dir_68267d1309a1af8e8297ef4c3efbcdba.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: src Directory Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,650 +76,652 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
src Directory Reference
+
src Directory Reference
- - + - - - - + - + - + - + - + - - + + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + + + + - + - + - + - + - + - + - + - + - + - + - + - + - + - - + + - - + + - - + + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - - - - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - - - - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + + + - + - + - + - + - + - + - + - + - + - + - + - + - +

+

Files

file  aea.f [code]
 aea.f
 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]
 errexit.f
 Exit with a return code.
 
file  errmsg.f [code]
 errmsg.f
 Write a message to stderr.
 
file  fparsei.f [code]
 fparsei.f
 Extract integers from a free-format character string.
 
file  fparser.f [code]
 fparser.f
 Extracts real numbers from a free-format character string.
 
file  gbyte.f [code]
 gbyte.f
 This is the fortran version of gbyte.
 
file  gbytec.f [code]
 Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
 gbytec.f
 Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
 
file  gbytes.f [code]
 gbytes.f
 This is the fortran version of gbytes.
 
file  gbytesc.f [code]
 gbytesc.f
 Get bytes - unpack bits.
 
file  getbit.f [code]
 getbit.f
 Compute number of bits and round field.
 
file  getgb.f [code]
 getgb.f
 Find and unpack a grib message.
 
file  getgb1.f [code]
 getgb1.f
 Find and unpacks a grib message.
 
file  getgb1r.f [code]
 getgb1r.f
 Reads and unpacks a grib message.
 
file  getgb1re.f [code]
 getgb1re.f
 Reads and unpacks a grib message.
 
file  getgb1s.f [code]
 getgb1s.f
 Find a grib message.
 
file  getgbe.f [code]
 getgbe.f
 Finds and unpacks a grib message.
 
file  getgbeh.f [code]
 getgbeh.f
 Find a grib message.
 
file  getgbem.f [code]
 getgbem.f
 Find and unpack a grib message.
 
file  getgbemh.f [code]
 getgbemh.f
 Find a grib message.
 
file  getgbemn.f [code]
 getgbemn.f
 Finds and unpacks a grib message.
 
file  getgbemp.f [code]
 getgbemp.f
 Find a grib message.
 
file  getgbens.f [code]
 getgbens.f
 Find and unpack a grib message.
 
file  getgbep.f [code]
 getgbep.f
 Find a grib message.
 
file  getgbex.f [code]
 getgbex.f
 Find and unpack a grib message.
 
file  getgbexm.f [code]
 getgbexm.f
 Find and unpack a grib message.
 
file  getgbh.f [code]
 getgbh.f
 Find a grib message.
 
file  getgbm.f [code]
 getgbm.f
 Find and unpack a grib message.
 
file  getgbmh.f [code]
 getgbmh.f
 Finds a grib message.
 
file  getgbmp.f [code]
 getgbmp.f
 Finds a grib message.
 
file  getgbp.f [code]
 getgbp.f
 Finds a grib message.
 
file  getgi.f [code]
 getgi.f
 Read a grib index file and return its contents.
 
file  getgir.f [code]
 getgir.f
 Read a grib index file and return its index contents.
 
file  gtbits.f [code]
 gtbits.f
 The number of bits required to pack a given field.
 
file  idsdef.f [code]
 idsdef.f
 Sets decimal scalings defaults for various parameters.
 
file  instrument.f [code]
 instrument.f
 Monitor wall-clock times, etc.
 
file  isrchne.f [code]
 isrchne.f
 Searches a vector for the first element not equal to a target.
 
file  iw3jdn.f [code]
 iw3jdn.f
 Computes julian day number from year (4 digits), month, and day.
 
file  iw3mat.f [code]
 iw3mat.f
 Test n words starting at l1, l2 for equality, return .true.
 
file  iw3pds.f [code]
 iw3pds.f
 Test two pds (grib product definition section) to see if all equal; otherwise .false.
 
file  iw3unp29.f [code]
 iw3unp29.f
 Reads and unpacks one report into the unpacked office note 29/124 format.
 
file  ixgb.f [code]
 ixgb.f
 This subprogram makes one index record.
 
file  lengds.f [code]
 lengds.f
 GIven a grid description section (in w3fi63 format), return its size in terms of number of data points.
 
file  makwmo.f [code]
 makgds.f90
 Make or break a grid description section.
 
 makwmo.f
 FORMS THE WMO HEADER FOR A GIVEN BULLETIN.
 
file  mersenne_twister.f [code]
 mersenne_twister.f
 Modern random number generator.
 
file  mkfldsep.f [code]
 mkfldsep.f
 Makes TOC Flag Field Separator Block.
 
file  mova2i.f [code]
 mova2i.f
 This Function copies a bit string from a Character*1 variable to an integer variable.
 
file  orders.f [code]
 orders.f
 A Fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers.
 
file  pdsens.f [code]
 pdsens.f
 Packs grib pds extension 41- for ensemble.
 
file  pdseup.f [code]
 pdseup.f
 Unpacks grib pds extension 41- for ensemble.
 
file  putgb.f [code]
 putgb.f
 Packs and writes a grib message.
 
file  putgbe.f [code]
 putgbe.f
 Packs and writes a grib message.
 
file  putgben.f [code]
 putgben.f
 Packs and writes a grib message.
 
file  putgbens.f [code]
 putgbens.f
 Packs and writes a grib message.
 
file  putgbex.f [code]
 putgbex.f
 Packs and writes a grib message.
 
file  putgbn.f [code]
 putgbn.f
 Packs and writes a grib message.
 
file  q9ie32.f [code]
 q9ie32.f
 Convert IBM370 F.P.
 
file  r63w72.f [code]
 Convert w3fi63() parms to w3fi72() parms.
 r63w72.f
 Convert w3fi63() parms to w3fi72() parms.
 
file  sbyte.f [code]
 This is the fortran 32 bit version of sbyte().
 sbyte.f
 This is the fortran 32 bit version of sbyte().
 
file  sbytec.f [code]
 Wrapper for sbytesc()
 sbytec.f
 Wrapper for sbytesc()
 
file  sbytes.f [code]
 sbytes.f
 This is the fortran versions of sbytes().
 
file  sbytesc.f [code]
 sbytesc.f
 Put arbitrary size values into a packed bit string.
 
file  skgb.f [code]
 skgb.f
 Search for next grib message.
 
file  summary.c [code]
 summary.c
 Make a system call to return various useful parameters.
 
file  w3ai00.f [code]
 w3ai00.f
 Real array to 16 bit packed format.
 
file  w3ai01.f [code]
 w3ai01.f
 Unpack record into IEEE F.P.
 
file  w3ai08.f [code]
 w3ai08.f
 Unpack grib field to grib grid.
 
file  w3ai15.f [code]
 w3ai15.f
 Converts a set of binary numbers to an equivalent set of ascii number fields in core.
 
file  w3ai18.f [code]
 w3ai18.f
 Line builder subroutine.
 
file  w3ai19.f [code]
 w3ai19.f
 Blocker Subroutine.
 
file  w3ai24.f [code]
 w3ai24.f
 Test for match of two strings.
 
file  w3ai38.f [code]
 w3ai38.f
 EBCDIC to ASCII.
 
file  w3ai39.f [code]
 w3ai39.f
 Translate 'ASCII' field to 'EBCDIC'.
 
file  w3ai40.f [code]
 w3ai40.f
 Constant size binary string packer.
 
file  w3ai41.f [code]
 w3ai41.f
 Constant size binary string unpacker.
 
file  w3aq15.f [code]
 w3aq15.f
 GMT time packer.
 
file  w3as00.f [code]
 w3as00.f
 Get parm field from command-line.
 
file  w3ctzdat.f [code]
 w3ctzdat.f
 Converts an ncep absolute date and time to another time zone.
 
file  w3difdat.f [code]
 w3difdat.f
 Return a time interval between two dates.
 
file  w3doxdat.f [code]
 w3doxdat.f
 Returns the integer day of week, the day of year, and julian day given an NCEP absolute date and time.
 
file  w3fa01.f [code]
 w3fa01.f
 Compute lifting condendsation level.
 
file  w3fa03.f [code]
 w3fa03.f
 Compute standard height, temp, and pot temp.
 
file  w3fa03v.f [code]
 w3fa03v.f
 Compute standard height, temp, and pot temp.
 
file  w3fa04.f [code]
 w3fa04.f
 Compute standard pressure, temp, pot temp.
 
file  w3fa06.f [code]
 w3fa06.f
 Calculation of the lifted index.
 
file  w3fa09.f [code]
 w3fa09.f
 Temperature to saturation vapor pressure.
 
file  w3fa11.f [code]
 w3fa11.f
 Computes coefficients for use in w3fa12.
 
file  w3fa12.f [code]
 w3fa12.f
 Computes legendre polynomials at a given latitude.
 
file  w3fa13.f [code]
 w3fa13.f
 Computes Trig Functions.
 
file  w3fb00.f [code]
 w3fb00.f
 Convert latitude, longitude to i,j.
 
file  w3fb01.f [code]
 w3fb01.f
 I,J TO LATITUDE, LONGITUDE.
 
file  w3fb02.f [code]
 w3fb02.f
 COnvert s.
 
file  w3fb03.f [code]
 w3fb03.f
 Convert i,j grid coordinates to lat/lon.
 
file  w3fb04.f [code]
 w3fb04.f
 Latitude, longitude to grid coordinates.
 
file  w3fb05.f [code]
 w3fb05.f
 Grid coordinates to latitude, longitude.
 
file  w3fb06.f [code]
 w3fb06.f
 Lat/lon to pola (i,j) for grib.
 
file  w3fb07.f [code]
 w3fb07.f
 Grid coords to lat/lon for grib.
 
file  w3fb08.f [code]
 w3fb08.f
 Lat/lon to merc (i,j) for grib.
 
file  w3fb09.f [code]
 w3fb09.f
 Merc (i,j) to lat/lon for grib.
 
file  w3fb10.f [code]
 w3fb10.f
 Lat/long pair to compass bearing, gcd.
 
file  w3fb11.f [code]
 w3fb11.f
 Lat/lon to lambert(i,j) for grib.
 
file  w3fb12.f [code]
 w3fb12.f
 Lambert(i,j) to lat/lon for grib.
 
file  w3fc02.f [code]
 w3fc02.f
 Grid U,V wind comps.
 
file  w3fc05.f [code]
 w3fc05.f
 Earth U,V wind components to dir and spd.
 
file  w3fc06.f [code]
 w3fc06.f
 Wind dir and spd to Earth U,V components.
 
file  w3fc07.f [code]
 w3fc07.f
 Grid U-V to Earth U-V in north hem.
 
file  w3fc08.f [code]
 w3fc08.f
 U-V Comps from Earth to north hem grid.
 
file  w3fi01.f [code]
 w3fi01.f
 Determines machine word length in bytes.
 
file  w3fi02.f [code]
 w3fi02.f
 Transfers array from 16 to 64 bit words.
 
file  w3fi03.f [code]
 w3fi03.f
 Transfers default integers to 16 bit ints.
 
file  w3fi04.f [code]
 w3fi04.f
 Find word size, endian, character set.
 
file  w3fi18.f [code]
 w3fi18.f
 NMC octagon boundary finding subroutine.
 
file  w3fi19.f [code]
 w3fi19.f
 NMC Rectangle boundary finding subroutine.
 
file  w3fi20.f [code]
 w3fi20.f
 Cut a 65 x 65 grid to a nmc 1977 point grid.
 
file  w3fi32.f [code]
 w3fi32.f
 Pack id's into office note 84 format.
 
file  w3fi47.f [code]
 w3fi47.f
 Convert label to off.
 
file  w3fi48.f [code]
 w3fi48.f
 Convert office note 85 label to IBM.
 
file  w3fi52.f [code]
 Computes scaling constants used by grdprt().
 
file  w3fi58.f [code]
 w3fi58.f
 Pack positive differences in least bits.
 
file  w3fi59.f [code]
 w3fi59.f
 Form and pack positive, scaled differences.
 
file  w3fi61.f [code]
 w3fi61.f
 Build 40 char communications prefix.
 
file  w3fi62.f [code]
 w3fi62.f
 Build 80-char on295 queue descriptor.
 
file  w3fi63.f [code]
 w3fi63.f
 Unpack GRIB field to a GRIB grid.
 
file  w3fi64.f [code]
 w3fi64.f
 NMC office note 29 report unpacker.
 
file  w3fi65.f [code]
 w3fi65.f
 NMC office note 29 report packer.
 
file  w3fi66.f [code]
 w3fi66.f
 Office note 29 report blocker.
 
file  w3fi67.f [code]
 w3fi67.f
 BUFR message decoder.
 
file  w3fi68.f [code]
 w3fi68.f
 Convert 25 word array to GRIB pds.
 
file  w3fi69.f [code]
 w3fi69.f
 Convert pds to 25, or 27 word array.
 
file  w3fi70.f [code]
 w3fi70.f
 Computes scaling constants used by grdprt().
 
file  w3fi71.f [code]
 w3fi71.f
 Make array used by GRIB packer for GDS.
 
file  w3fi72.f [code]
 w3fi72.f
 Make a complete GRIB message.
 
file  w3fi73.f [code]
 w3fi73.f
 Construct grib bit map section (BMS).
 
file  w3fi74.f [code]
 w3fi74.f
 Construct Grid Definition Section (GDS).
 
file  w3fi75.f [code]
 w3fi75.f
 GRIB pack data and form bds octets(1-11)
 
file  w3fi76.f [code]
 w3fi76.f
 Convert to ibm370 floating point.
 
file  w3fi78.f [code]
 w3fi78.f
 BUFR Message decoder.
 
file  w3fi82.f [code]
 w3fi82.f
 Convert to second diff array.
 
file  w3fi83.f [code]
 w3fi83.f
 Restore delta packed data to original.
 
file  w3fi85.f [code]
 w3fi85.f
 Generate bufr message.
 
file  w3fi88.f [code]
 w3fi88.f
 BUFR message decoder.
 
file  w3fi92.f [code]
 w3fi92.f
 Build 80-char on 295 grib queue descriptor.
 
file  w3fm07.f [code]
 w3fm07.f
 Nine-point smoother for rectangular grids.
 
file  w3fm08.f [code]
 w3fm08.f
 Nine point smoother/desmoother.
 
file  w3fp04.f [code]
 w3fp04.f
 Print array of data points at lat/lon points.
 
file  w3fp05.f [code]
 w3fp05.f
 Printer contour subroutine.
 
file  w3fp06.f [code]
 w3fp06.f
 NMC title subroutine.
 
file  w3fp10.f [code]
 w3fp10.f
 Printer contour subroutine.
 
file  w3fp11.f [code]
 w3fp11.f
 One-line GRIB titler from pds section.
 
file  w3fp12.f [code]
 w3fp12.f
 Creates the product definition section.
 
file  w3fp13.f [code]
 w3fp13.f
 Convert GRIB PDS edition 1 to O.N.
 
file  w3fq07.f [code]
 Sends fax,varian,afos,awips, maps & bulls.
 
file  w3fs13.f [code]
 w3fs13.f
 Year, month, and day to day of year.
 
file  w3fs15.f [code]
 w3fs15.f
 Updating office note 85 date/time word.
 
file  w3fs21.f [code]
 w3fs21.f
 Number of minutes since jan 1, 1978.
 
file  w3fs26.f [code]
 w3fs26.f
 Year, month, day from julian day number.
 
file  w3ft00.f [code]
 w3ft00.f
 Data field tranformation subroutine.
 
file  w3ft01.f [code]
 w3ft01.f
 Interpolate values in a data field.
 
file  w3ft02.f [code]
 w3ft02.f
 Interpolate precipitation to specific point.
 
file  w3ft03.f [code]
 w3ft03.f
 A point interpolater.
 
file  w3ft05.f [code]
 w3ft05.f
 Convert (145,37) to (65,65) n.
 
file  w3ft05v.f [code]
 w3ft05v.f
 Convert (145,37) grid to (65,65) n.
 
file  w3ft06.f [code]
 w3ft06.f
 Convert (145,37) to (65,65) s.
 
file  w3ft06v.f [code]
 w3ft06v.f
 Convert (145,37) grid to (65,65) s.
 
file  w3ft07.f [code]
 w3ft07.f
 Transform gridpoint fld by interpolation.
 
file  w3ft08.f [code]
 w3ft08.f
 Computes 2.5 x 2.5 n.
 
file  w3ft09.f [code]
 w3ft09.f
 Computes 2.5x2.5 n.
 
file  w3ft10.f [code]
 w3ft10.f
 Computes 2.5 x 2.5 s.
 
file  w3ft11.f [code]
 w3ft11.f
 Computes 2.5x2.5 s.
 
file  w3ft12.f [code]
 w3ft12.f
 Fast fourier for 2.5 degree grid.
 
file  w3ft16.f [code]
 w3ft16.f
 Convert (95,91) grid to (3447) grid.
 
file  w3ft17.f [code]
 w3ft17.f
 Convert (95,91) grid to (3447) grid.
 
file  w3ft201.f [code]
 w3ft201.f
 Convert (361,181) grid to (65,65) n.
 
file  w3ft202.f [code]
 w3ft202.f
 Convert (361,91) grid to (65,43) n.
 
file  w3ft203.f [code]
 w3ft203.f
 Convert (361,91) grid to (45,39) n.
 
file  w3ft204.f [code]
 w3ft204.f
 Convert (361,181) grid to (93,68) mercator grid.
 
file  w3ft205.f [code]
 w3ft205.f
 Convert (361,91) grid to (45,39) n.
 
file  w3ft206.f [code]
 w3ft206.f
 Convert (361,91) grid to (51,41) lambert grid.
 
file  w3ft207.f [code]
 w3ft207.f
 Convert (361,91) grid to (49,35) n.
 
file  w3ft208.f [code]
 w3ft208.f
 Convert (361,91) grid to (29,27) mercator grid.
 
file  w3ft209.f [code]
 w3ft209.f
 Convert (361,91) grid to (101,81) lambert grid.
 
file  w3ft21.f [code]
 w3ft21.f
 Computes 2.5 x 2.5 n.
 
file  w3ft210.f [code]
 w3ft210.f
 Convert (361,91) grid to (25,25) mercator grid.
 
file  w3ft211.f [code]
 w3ft211.f
 Convert (361,91) grid to (93,65) lambert grid.
 
file  w3ft212.f [code]
 w3ft212.f
 Convert (361,91) grid to (185,129) lambert grid.
 
file  w3ft213.f [code]
 w3ft213.f
 Convert (361,91) grid to (129,85) n.
 
file  w3ft214.f [code]
 w3ft214.f
 Convert (361,91) grid to (97,69) n.
 
file  w3ft26.f [code]
 w3ft26.f
 Creates wafs 1.25x1.25 thinned grids.
 
file  w3ft32.f [code]
 w3ft32.f
 General interpolator between nmc flds.
 
file  w3ft33.f [code]
 w3ft33.f
 Thicken thinned wafs grib grid 37-44.
 
file  w3ft38.f [code]
 w3ft38.f
 Computes 2.5 x 2.5 n.
 
file  w3ft39.f [code]
 w3ft39.f
 Computes 2.5x2.5 n.
 
file  w3ft40.f [code]
 w3ft40.f
 Computes 2.5 x 2.5 s.
 
file  w3ft41.f [code]
 w3ft41.f
 Computes 2.5x2.5 s.
 
file  w3ft43v.f [code]
 w3ft43v.f
 Convert (361,181) grid to (65,65) n.
 
file  w3kind.f [code]
 w3kind.f
 Return the real kind and integer kind used in w3 lib.
 
file  w3locdat.f [code]
 w3locdat.f
 Return the local date and time.
 
file  w3miscan.f [code]
 w3log.f
 
 w3miscan.f
 Reads 1 ssm/i scan line from bufr d-set.
 
file  w3movdat.f [code]
 w3movdat.f
 Return a date from a time interval and date.
 
file  w3nogds.f [code]
 w3nogds.f
 Make a complete grib message.
 
file  w3pradat.f [code]
 w3pradat.f
 Format a date and time into characters.
 
file  w3reddat.f [code]
 w3reddat.f
 Reduce a time interval to a canonical form.
 
file  w3tagb.f [code]
 w3tagb.f
 Operational job identifier.
 
file  w3trnarg.f [code]
 w3trnarg.f
 Translates arg line from standard input.
 
file  w3unpk77.f [code]
 w3unpk77.f
 Decodes single report from bufr messages.
 
file  w3utcdat.f [code]
 w3utcdat.f
 Return the utc date and time.
 
file  w3valdat.f [code]
 w3valdat.f
 Determine the validity of a date and time.
 
file  w3ymdh4.f [code]
 w3ymdh4.f
 4-byte date word unpacker and packer.
 
file  xdopen.f [code]
 xdopen.f
 Dummy subroutine.
 
file  xmovex.f [code]
 xmovex.f
 Assembler language to move data.
 
file  xstore.f [code]
 xstore.f
 Stores a constant value into an array.
 
@@ -729,7 +731,7 @@ diff --git a/dir_68267d1309a1af8e8297ef4c3efbcdba.js b/dir_68267d1309a1af8e8297ef4c3efbcdba.js new file mode 100644 index 00000000..6e7e110e --- /dev/null +++ b/dir_68267d1309a1af8e8297ef4c3efbcdba.js @@ -0,0 +1,213 @@ +var dir_68267d1309a1af8e8297ef4c3efbcdba = +[ + [ "aea.f", "aea_8f.html", "aea_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.html", "makgds_8f90" ], + [ "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", null ], + [ "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" ], + [ "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" ], + [ "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/doc.png b/doc.png deleted file mode 100644 index 17edabff95f7b8da13c9516a04efe05493c29501..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 746 zcmV7=@pnbNXRFEm&G8P!&WHG=d)>K?YZ1bzou)2{$)) zumDct!>4SyxL;zgaG>wy`^Hv*+}0kUfCrz~BCOViSb$_*&;{TGGn2^x9K*!Sf0=lV zpP=7O;GA0*Jm*tTYj$IoXvimpnV4S1Z5f$p*f$Db2iq2zrVGQUz~yq`ahn7ck(|CE z7Gz;%OP~J6)tEZWDzjhL9h2hdfoU2)Nd%T<5Kt;Y0XLt&<@6pQx!nw*5`@bq#?l*?3z{Hlzoc=Pr>oB5(9i6~_&-}A(4{Q$>c>%rV&E|a(r&;?i5cQB=} zYSDU5nXG)NS4HEs0it2AHe2>shCyr7`6@4*6{r@8fXRbTA?=IFVWAQJL&H5H{)DpM#{W(GL+Idzf^)uRV@oB8u$ z8v{MfJbTiiRg4bza<41NAzrl{=3fl_D+$t+^!xlQ8S}{UtY`e z;;&9UhyZqQRN%2pot{*Ei0*4~hSF_3AH2@fKU!$NSflS>{@tZpDT4`M2WRTTVH+D? z)GFlEGGHe?koB}i|1w45!BF}N_q&^HJ&-tyR{(afC6H7|aml|tBBbv}55C5DNP8p3 z)~jLEO4Z&2hZmP^i-e%(@d!(E|KRafiU8Q5u(wU((j8un3OR*Hvj+t diff --git a/doc.svg b/doc.svg new file mode 100644 index 00000000..0b928a53 --- /dev/null +++ b/doc.svg @@ -0,0 +1,12 @@ + + + + + + + + + + + diff --git a/docd.svg b/docd.svg new file mode 100644 index 00000000..ac18b275 --- /dev/null +++ b/docd.svg @@ -0,0 +1,12 @@ + + + + + + + + + + + diff --git a/doxygen.css b/doxygen.css index ffbff022..009a9b55 100644 --- a/doxygen.css +++ b/doxygen.css @@ -1,29 +1,378 @@ -/* The standard CSS for doxygen 1.9.1 */ - -body, table, div, p, dl { - font: 400 14px/22px Roboto,sans-serif; +/* The standard CSS for doxygen 1.9.8*/ + +html { +/* page base colors */ +--page-background-color: white; +--page-foreground-color: black; +--page-link-color: #3D578C; +--page-visited-link-color: #4665A2; + +/* index */ +--index-odd-item-bg-color: #F8F9FC; +--index-even-item-bg-color: white; +--index-header-color: black; +--index-separator-color: #A0A0A0; + +/* header */ +--header-background-color: #F9FAFC; +--header-separator-color: #C4CFE5; +--header-gradient-image: url('nav_h.png'); +--group-header-separator-color: #879ECB; +--group-header-color: #354C7B; +--inherit-header-color: gray; + +--footer-foreground-color: #2A3D61; +--footer-logo-width: 104px; +--citation-label-color: #334975; +--glow-color: cyan; + +--title-background-color: white; +--title-separator-color: #5373B4; +--directory-separator-color: #9CAFD4; +--separator-color: #4A6AAA; + +--blockquote-background-color: #F7F8FB; +--blockquote-border-color: #9CAFD4; + +--scrollbar-thumb-color: #9CAFD4; +--scrollbar-background-color: #F9FAFC; + +--icon-background-color: #728DC1; +--icon-foreground-color: white; +--icon-doc-image: url('doc.svg'); +--icon-folder-open-image: url('folderopen.svg'); +--icon-folder-closed-image: url('folderclosed.svg'); + +/* brief member declaration list */ +--memdecl-background-color: #F9FAFC; +--memdecl-separator-color: #DEE4F0; +--memdecl-foreground-color: #555; +--memdecl-template-color: #4665A2; + +/* detailed member list */ +--memdef-border-color: #A8B8D9; +--memdef-title-background-color: #E2E8F2; +--memdef-title-gradient-image: url('nav_f.png'); +--memdef-proto-background-color: #DFE5F1; +--memdef-proto-text-color: #253555; +--memdef-proto-text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); +--memdef-doc-background-color: white; +--memdef-param-name-color: #602020; +--memdef-template-color: #4665A2; + +/* tables */ +--table-cell-border-color: #2D4068; +--table-header-background-color: #374F7F; +--table-header-foreground-color: #FFFFFF; + +/* labels */ +--label-background-color: #728DC1; +--label-left-top-border-color: #5373B4; +--label-right-bottom-border-color: #C4CFE5; +--label-foreground-color: white; + +/** navigation bar/tree/menu */ +--nav-background-color: #F9FAFC; +--nav-foreground-color: #364D7C; +--nav-gradient-image: url('tab_b.png'); +--nav-gradient-hover-image: url('tab_h.png'); +--nav-gradient-active-image: url('tab_a.png'); +--nav-gradient-active-image-parent: url("../tab_a.png"); +--nav-separator-image: url('tab_s.png'); +--nav-breadcrumb-image: url('bc_s.png'); +--nav-breadcrumb-border-color: #C2CDE4; +--nav-splitbar-image: url('splitbar.png'); +--nav-font-size-level1: 13px; +--nav-font-size-level2: 10px; +--nav-font-size-level3: 9px; +--nav-text-normal-color: #283A5D; +--nav-text-hover-color: white; +--nav-text-active-color: white; +--nav-text-normal-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); +--nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-menu-button-color: #364D7C; +--nav-menu-background-color: white; +--nav-menu-foreground-color: #555555; +--nav-menu-toggle-color: rgba(255, 255, 255, 0.5); +--nav-arrow-color: #9CAFD4; +--nav-arrow-selected-color: #9CAFD4; + +/* table of contents */ +--toc-background-color: #F4F6FA; +--toc-border-color: #D8DFEE; +--toc-header-color: #4665A2; +--toc-down-arrow-image: url("data:image/svg+xml;utf8,&%238595;"); + +/** search field */ +--search-background-color: white; +--search-foreground-color: #909090; +--search-magnification-image: url('mag.svg'); +--search-magnification-select-image: url('mag_sel.svg'); +--search-active-color: black; +--search-filter-background-color: #F9FAFC; +--search-filter-foreground-color: black; +--search-filter-border-color: #90A5CE; +--search-filter-highlight-text-color: white; +--search-filter-highlight-bg-color: #3D578C; +--search-results-foreground-color: #425E97; +--search-results-background-color: #EEF1F7; +--search-results-border-color: black; +--search-box-shadow: inset 0.5px 0.5px 3px 0px #555; + +/** code fragments */ +--code-keyword-color: #008000; +--code-type-keyword-color: #604020; +--code-flow-keyword-color: #E08000; +--code-comment-color: #800000; +--code-preprocessor-color: #806020; +--code-string-literal-color: #002080; +--code-char-literal-color: #008080; +--code-xml-cdata-color: black; +--code-vhdl-digit-color: #FF00FF; +--code-vhdl-char-color: #000000; +--code-vhdl-keyword-color: #700070; +--code-vhdl-logic-color: #FF0000; +--code-link-color: #4665A2; +--code-external-link-color: #4665A2; +--fragment-foreground-color: black; +--fragment-background-color: #FBFCFD; +--fragment-border-color: #C4CFE5; +--fragment-lineno-border-color: #00FF00; +--fragment-lineno-background-color: #E8E8E8; +--fragment-lineno-foreground-color: black; +--fragment-lineno-link-fg-color: #4665A2; +--fragment-lineno-link-bg-color: #D8D8D8; +--fragment-lineno-link-hover-fg-color: #4665A2; +--fragment-lineno-link-hover-bg-color: #C8C8C8; +--tooltip-foreground-color: black; +--tooltip-background-color: white; +--tooltip-border-color: gray; +--tooltip-doc-color: grey; +--tooltip-declaration-color: #006318; +--tooltip-link-color: #4665A2; +--tooltip-shadow: 1px 1px 7px gray; +--fold-line-color: #808080; +--fold-minus-image: url('minus.svg'); +--fold-plus-image: url('plus.svg'); +--fold-minus-image-relpath: url('../../minus.svg'); +--fold-plus-image-relpath: url('../../plus.svg'); + +/** font-family */ +--font-family-normal: Roboto,sans-serif; +--font-family-monospace: 'JetBrains Mono',Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace,fixed; +--font-family-nav: 'Lucida Grande',Geneva,Helvetica,Arial,sans-serif; +--font-family-title: Tahoma,Arial,sans-serif; +--font-family-toc: Verdana,'DejaVu Sans',Geneva,sans-serif; +--font-family-search: Arial,Verdana,sans-serif; +--font-family-icon: Arial,Helvetica; +--font-family-tooltip: Roboto,sans-serif; + +} + +@media (prefers-color-scheme: dark) { + html:not(.dark-mode) { + color-scheme: dark; + +/* page base colors */ +--page-background-color: black; +--page-foreground-color: #C9D1D9; +--page-link-color: #90A5CE; +--page-visited-link-color: #A3B4D7; + +/* index */ +--index-odd-item-bg-color: #0B101A; +--index-even-item-bg-color: black; +--index-header-color: #C4CFE5; +--index-separator-color: #334975; + +/* header */ +--header-background-color: #070B11; +--header-separator-color: #141C2E; +--header-gradient-image: url('nav_hd.png'); +--group-header-separator-color: #283A5D; +--group-header-color: #90A5CE; +--inherit-header-color: #A0A0A0; + +--footer-foreground-color: #5B7AB7; +--footer-logo-width: 60px; +--citation-label-color: #90A5CE; +--glow-color: cyan; + +--title-background-color: #090D16; +--title-separator-color: #354C79; +--directory-separator-color: #283A5D; +--separator-color: #283A5D; + +--blockquote-background-color: #101826; +--blockquote-border-color: #283A5D; + +--scrollbar-thumb-color: #283A5D; +--scrollbar-background-color: #070B11; + +--icon-background-color: #334975; +--icon-foreground-color: #C4CFE5; +--icon-doc-image: url('docd.svg'); +--icon-folder-open-image: url('folderopend.svg'); +--icon-folder-closed-image: url('folderclosedd.svg'); + +/* brief member declaration list */ +--memdecl-background-color: #0B101A; +--memdecl-separator-color: #2C3F65; +--memdecl-foreground-color: #BBB; +--memdecl-template-color: #7C95C6; + +/* detailed member list */ +--memdef-border-color: #233250; +--memdef-title-background-color: #1B2840; +--memdef-title-gradient-image: url('nav_fd.png'); +--memdef-proto-background-color: #19243A; +--memdef-proto-text-color: #9DB0D4; +--memdef-proto-text-shadow: 0px 1px 1px rgba(0, 0, 0, 0.9); +--memdef-doc-background-color: black; +--memdef-param-name-color: #D28757; +--memdef-template-color: #7C95C6; + +/* tables */ +--table-cell-border-color: #283A5D; +--table-header-background-color: #283A5D; +--table-header-foreground-color: #C4CFE5; + +/* labels */ +--label-background-color: #354C7B; +--label-left-top-border-color: #4665A2; +--label-right-bottom-border-color: #283A5D; +--label-foreground-color: #CCCCCC; + +/** navigation bar/tree/menu */ +--nav-background-color: #101826; +--nav-foreground-color: #364D7C; +--nav-gradient-image: url('tab_bd.png'); +--nav-gradient-hover-image: url('tab_hd.png'); +--nav-gradient-active-image: url('tab_ad.png'); +--nav-gradient-active-image-parent: url("../tab_ad.png"); +--nav-separator-image: url('tab_sd.png'); +--nav-breadcrumb-image: url('bc_sd.png'); +--nav-breadcrumb-border-color: #2A3D61; +--nav-splitbar-image: url('splitbard.png'); +--nav-font-size-level1: 13px; +--nav-font-size-level2: 10px; +--nav-font-size-level3: 9px; +--nav-text-normal-color: #B6C4DF; +--nav-text-hover-color: #DCE2EF; +--nav-text-active-color: #DCE2EF; +--nav-text-normal-shadow: 0px 1px 1px black; +--nav-text-hover-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-text-active-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +--nav-menu-button-color: #B6C4DF; +--nav-menu-background-color: #05070C; +--nav-menu-foreground-color: #BBBBBB; +--nav-menu-toggle-color: rgba(255, 255, 255, 0.2); +--nav-arrow-color: #334975; +--nav-arrow-selected-color: #90A5CE; + +/* table of contents */ +--toc-background-color: #151E30; +--toc-border-color: #202E4A; +--toc-header-color: #A3B4D7; +--toc-down-arrow-image: url("data:image/svg+xml;utf8,&%238595;"); + +/** search field */ +--search-background-color: black; +--search-foreground-color: #C5C5C5; +--search-magnification-image: url('mag_d.svg'); +--search-magnification-select-image: url('mag_seld.svg'); +--search-active-color: #C5C5C5; +--search-filter-background-color: #101826; +--search-filter-foreground-color: #90A5CE; +--search-filter-border-color: #7C95C6; +--search-filter-highlight-text-color: #BCC9E2; +--search-filter-highlight-bg-color: #283A5D; +--search-results-background-color: #101826; +--search-results-foreground-color: #90A5CE; +--search-results-border-color: #7C95C6; +--search-box-shadow: inset 0.5px 0.5px 3px 0px #2F436C; + +/** code fragments */ +--code-keyword-color: #CC99CD; +--code-type-keyword-color: #AB99CD; +--code-flow-keyword-color: #E08000; +--code-comment-color: #717790; +--code-preprocessor-color: #65CABE; +--code-string-literal-color: #7EC699; +--code-char-literal-color: #00E0F0; +--code-xml-cdata-color: #C9D1D9; +--code-vhdl-digit-color: #FF00FF; +--code-vhdl-char-color: #C0C0C0; +--code-vhdl-keyword-color: #CF53C9; +--code-vhdl-logic-color: #FF0000; +--code-link-color: #79C0FF; +--code-external-link-color: #79C0FF; +--fragment-foreground-color: #C9D1D9; +--fragment-background-color: black; +--fragment-border-color: #30363D; +--fragment-lineno-border-color: #30363D; +--fragment-lineno-background-color: black; +--fragment-lineno-foreground-color: #6E7681; +--fragment-lineno-link-fg-color: #6E7681; +--fragment-lineno-link-bg-color: #303030; +--fragment-lineno-link-hover-fg-color: #8E96A1; +--fragment-lineno-link-hover-bg-color: #505050; +--tooltip-foreground-color: #C9D1D9; +--tooltip-background-color: #202020; +--tooltip-border-color: #C9D1D9; +--tooltip-doc-color: #D9E1E9; +--tooltip-declaration-color: #20C348; +--tooltip-link-color: #79C0FF; +--tooltip-shadow: none; +--fold-line-color: #808080; +--fold-minus-image: url('minusd.svg'); +--fold-plus-image: url('plusd.svg'); +--fold-minus-image-relpath: url('../../minusd.svg'); +--fold-plus-image-relpath: url('../../plusd.svg'); + +/** font-family */ +--font-family-normal: Roboto,sans-serif; +--font-family-monospace: 'JetBrains Mono',Consolas,Monaco,'Andale Mono','Ubuntu Mono',monospace,fixed; +--font-family-nav: 'Lucida Grande',Geneva,Helvetica,Arial,sans-serif; +--font-family-title: Tahoma,Arial,sans-serif; +--font-family-toc: Verdana,'DejaVu Sans',Geneva,sans-serif; +--font-family-search: Arial,Verdana,sans-serif; +--font-family-icon: Arial,Helvetica; +--font-family-tooltip: Roboto,sans-serif; + +}} +body { + background-color: var(--page-background-color); + color: var(--page-foreground-color); } -p.reference, p.definition { - font: 400 14px/22px Roboto,sans-serif; +body, table, div, p, dl { + font-weight: 400; + font-size: 14px; + font-family: var(--font-family-normal); + line-height: 22px; } /* @group Heading Levels */ -h1.groupheader { - font-size: 150%; -} - .title { - font: 400 14px/28px Roboto,sans-serif; + font-weight: 400; + font-size: 14px; + font-family: var(--font-family-normal); + line-height: 28px; font-size: 150%; font-weight: bold; margin: 10px 2px; } +h1.groupheader { + font-size: 150%; +} + h2.groupheader { - border-bottom: 1px solid #879ECB; - color: #354C7B; + border-bottom: 1px solid var(--group-header-separator-color); + color: var(--group-header-color); font-size: 150%; font-weight: normal; margin-top: 1.75em; @@ -46,22 +395,13 @@ h1, h2, h3, h4, h5, h6 { } h1.glow, h2.glow, h3.glow, h4.glow, h5.glow, h6.glow { - text-shadow: 0 0 15px cyan; + text-shadow: 0 0 15px var(--glow-color); } 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; } @@ -113,7 +453,6 @@ h3.version { } div.navtab { - border-right: 1px solid #A3B4D7; padding-right: 15px; text-align: right; line-height: 110%; @@ -127,16 +466,17 @@ td.navtab { padding-right: 6px; padding-left: 6px; } + td.navtabHL { - background-image: url('tab_a.png'); + background-image: var(--nav-gradient-active-image); background-repeat:repeat-x; padding-right: 6px; padding-left: 6px; } td.navtabHL a, td.navtabHL a:visited { - color: #fff; - text-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); + color: var(--nav-text-hover-color); + text-shadow: var(--nav-text-hover-shadow); } a.navtab { @@ -148,7 +488,13 @@ div.qindex{ width: 100%; line-height: 140%; font-size: 130%; - color: #A0A0A0; + color: var(--index-separator-color); +} + +#main-menu a:focus { + outline: auto; + z-index: 10; + position: relative; } dt.alphachar{ @@ -157,7 +503,7 @@ dt.alphachar{ } .alphachar a{ - color: black; + color: var(--index-header-color); } .alphachar a:hover, .alphachar a:visited{ @@ -176,8 +522,12 @@ dt.alphachar{ line-height: 1.15em; } +.classindex dl.even { + background-color: var(--index-even-item-bg-color); +} + .classindex dl.odd { - background-color: #F8F9FC; + background-color: var(--index-odd-item-bg-color); } @media(min-width: 1120px) { @@ -196,23 +546,19 @@ dt.alphachar{ /* @group Link Styling */ a { - color: #3D578C; + color: var(--page-link-color); font-weight: normal; text-decoration: none; } .contents a:visited { - color: #4665A2; + color: var(--page-visited-link-color); } a:hover { text-decoration: underline; } -.contents a.qindexHL:visited { - color: #FFFFFF; -} - a.el { font-weight: bold; } @@ -221,12 +567,39 @@ a.elRef { } a.code, a.code:visited, a.line, a.line:visited { - color: #4665A2; + color: var(--code-link-color); } a.codeRef, a.codeRef:visited, a.lineRef, a.lineRef:visited { - color: #4665A2; -} + color: var(--code-external-link-color); +} + +a.code.hl_class { /* style for links to class names in code snippets */ } +a.code.hl_struct { /* style for links to struct names in code snippets */ } +a.code.hl_union { /* style for links to union names in code snippets */ } +a.code.hl_interface { /* style for links to interface names in code snippets */ } +a.code.hl_protocol { /* style for links to protocol names in code snippets */ } +a.code.hl_category { /* style for links to category names in code snippets */ } +a.code.hl_exception { /* style for links to exception names in code snippets */ } +a.code.hl_service { /* style for links to service names in code snippets */ } +a.code.hl_singleton { /* style for links to singleton names in code snippets */ } +a.code.hl_concept { /* style for links to concept names in code snippets */ } +a.code.hl_namespace { /* style for links to namespace names in code snippets */ } +a.code.hl_package { /* style for links to package names in code snippets */ } +a.code.hl_define { /* style for links to macro names in code snippets */ } +a.code.hl_function { /* style for links to function names in code snippets */ } +a.code.hl_variable { /* style for links to variable names in code snippets */ } +a.code.hl_typedef { /* style for links to typedef names in code snippets */ } +a.code.hl_enumvalue { /* style for links to enum value names in code snippets */ } +a.code.hl_enumeration { /* style for links to enumeration names in code snippets */ } +a.code.hl_signal { /* style for links to Qt signal names in code snippets */ } +a.code.hl_slot { /* style for links to Qt slot names in code snippets */ } +a.code.hl_friend { /* style for links to friend names in code snippets */ } +a.code.hl_dcop { /* style for links to KDE3 DCOP names in code snippets */ } +a.code.hl_property { /* style for links to property names in code snippets */ } +a.code.hl_event { /* style for links to event names in code snippets */ } +a.code.hl_sequence { /* style for links to sequence names in code snippets */ } +a.code.hl_dictionary { /* style for links to dictionary names in code snippets */ } /* @end */ @@ -235,7 +608,17 @@ dl.el { } ul { - overflow: hidden; /*Fixed: list item bullets overlap floating elements*/ + overflow: visible; +} + +ul.multicol { + -moz-column-gap: 1em; + -webkit-column-gap: 1em; + column-gap: 1em; + -moz-column-count: 3; + -webkit-column-count: 3; + column-count: 3; + list-style-type: none; } #side-nav ul { @@ -254,30 +637,32 @@ ul { } pre.fragment { - border: 1px solid #C4CFE5; - background-color: #FBFCFD; + border: 1px solid var(--fragment-border-color); + background-color: var(--fragment-background-color); + color: var(--fragment-foreground-color); 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-family: var(--font-family-monospace); 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; + padding: 0 0 1px 0; /*Fixed: last line underline overlap border*/ + margin: 4px 8px 4px 2px; + color: var(--fragment-foreground-color); + background-color: var(--fragment-background-color); + border: 1px solid var(--fragment-border-color); } div.line { - font-family: monospace, fixed; + font-family: var(--font-family-monospace); font-size: 13px; min-height: 13px; - line-height: 1.0; + line-height: 1.2; text-wrap: unrestricted; white-space: -moz-pre-wrap; /* Moz */ white-space: -pre-wrap; /* Opera 4-6 */ @@ -306,24 +691,40 @@ div.line:after { } div.line.glow { - background-color: cyan; - box-shadow: 0 0 10px cyan; + background-color: var(--glow-color); + box-shadow: 0 0 10px var(--glow-color); } +span.fold { + margin-left: 5px; + margin-right: 1px; + margin-top: 0px; + margin-bottom: 0px; + padding: 0px; + display: inline-block; + width: 12px; + height: 12px; + background-repeat:no-repeat; + background-position:center; +} span.lineno { padding-right: 4px; + margin-right: 9px; text-align: right; - border-right: 2px solid #0F0; - background-color: #E8E8E8; + border-right: 2px solid var(--fragment-lineno-border-color); + color: var(--fragment-lineno-foreground-color); + background-color: var(--fragment-lineno-background-color); white-space: pre; } -span.lineno a { - background-color: #D8D8D8; +span.lineno a, span.lineno a:visited { + color: var(--fragment-lineno-link-fg-color); + background-color: var(--fragment-lineno-link-bg-color); } span.lineno a:hover { - background-color: #C8C8C8; + color: var(--fragment-lineno-link-hover-fg-color); + background-color: var(--fragment-lineno-link-hover-bg-color); } .lineno { @@ -335,24 +736,6 @@ span.lineno a:hover { 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; @@ -374,8 +757,7 @@ div.groupText { } body { - background-color: white; - color: black; + color: var(--page-foreground-color); margin: 0; } @@ -385,29 +767,15 @@ div.contents { 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; +p.formulaDsp { + text-align: center; } -tr.memlist { - background-color: #EEF1F7; +img.dark-mode-visible { + display: none; } - -p.formulaDsp { - text-align: center; +img.light-mode-visible { + display: none; } img.formulaDsp { @@ -437,89 +805,74 @@ address.footer { img.footer { border: 0px; vertical-align: middle; + width: var(--footer-logo-width); +} + +.compoundTemplParams { + color: var(--memdecl-template-color); + font-size: 80%; + line-height: 120%; } /* @group Code Colorization */ span.keyword { - color: #008000 + color: var(--code-keyword-color); } span.keywordtype { - color: #604020 + color: var(--code-type-keyword-color); } span.keywordflow { - color: #e08000 + color: var(--code-flow-keyword-color); } span.comment { - color: #800000 + color: var(--code-comment-color); } span.preprocessor { - color: #806020 + color: var(--code-preprocessor-color); } span.stringliteral { - color: #002080 + color: var(--code-string-literal-color); } span.charliteral { - color: #008080 + color: var(--code-char-literal-color); +} + +span.xmlcdata { + color: var(--code-xml-cdata-color); } span.vhdldigit { - color: #ff00ff + color: var(--code-vhdl-digit-color); } span.vhdlchar { - color: #000000 + color: var(--code-vhdl-char-color); } span.vhdlkeyword { - color: #700070 + color: var(--code-vhdl-keyword-color); } span.vhdllogic { - color: #ff0000 + color: var(--code-vhdl-logic-color); } blockquote { - background-color: #F7F8FB; - border-left: 2px solid #9CAFD4; + background-color: var(--blockquote-background-color); + border-left: 2px solid var(--blockquote-border-color); 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%; } @@ -527,18 +880,19 @@ td.tiny { .dirtab { padding: 4px; border-collapse: collapse; - border: 1px solid #A3B4D7; + border: 1px solid var(--table-cell-border-color); } th.dirtab { - background: #EBEFF6; + background-color: var(--table-header-background-color); + color: var(--table-header-foreground-color); font-weight: bold; } hr { height: 0px; border: none; - border-top: 1px solid #4A6AAA; + border-top: 1px solid var(--separator-color); } hr.footer { @@ -566,14 +920,14 @@ table.memberdecls { } .memberdecls td.glow, .fieldtable tr.glow { - background-color: cyan; - box-shadow: 0 0 15px cyan; + background-color: var(--glow-color); + box-shadow: 0 0 15px var(--glow-color); } .mdescLeft, .mdescRight, .memItemLeft, .memItemRight, .memTemplItemLeft, .memTemplItemRight, .memTemplParams { - background-color: #F9FAFC; + background-color: var(--memdecl-background-color); border: none; margin: 4px; padding: 1px 0 0 8px; @@ -581,11 +935,11 @@ table.memberdecls { .mdescLeft, .mdescRight { padding: 0px 8px 4px 8px; - color: #555; + color: var(--memdecl-foreground-color); } .memSeparator { - border-bottom: 1px solid #DEE4F0; + border-bottom: 1px solid var(--memdecl-separator-color); line-height: 1px; margin: 0px; padding: 0px; @@ -600,7 +954,7 @@ table.memberdecls { } .memTemplParams { - color: #4665A2; + color: var(--memdecl-template-color); white-space: nowrap; font-size: 80%; } @@ -613,15 +967,15 @@ table.memberdecls { .memtitle { padding: 8px; - border-top: 1px solid #A8B8D9; - border-left: 1px solid #A8B8D9; - border-right: 1px solid #A8B8D9; + border-top: 1px solid var(--memdef-border-color); + border-left: 1px solid var(--memdef-border-color); + border-right: 1px solid var(--memdef-border-color); border-top-right-radius: 4px; border-top-left-radius: 4px; margin-bottom: -1px; - background-image: url('nav_f.png'); + background-image: var(--memdef-title-gradient-image); background-repeat: repeat-x; - background-color: #E2E8F2; + background-color: var(--memdef-title-background-color); line-height: 1.25; font-weight: 300; float:left; @@ -636,20 +990,11 @@ table.memberdecls { .memtemplate { font-size: 80%; - color: #4665A2; + color: var(--memdef-template-color); 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%; } @@ -668,7 +1013,7 @@ table.memberdecls { } .memitem.glow { - box-shadow: 0 0 15px cyan; + box-shadow: 0 0 15px var(--glow-color); } .memname { @@ -681,41 +1026,32 @@ table.memberdecls { } .memproto, dl.reflist dt { - border-top: 1px solid #A8B8D9; - border-left: 1px solid #A8B8D9; - border-right: 1px solid #A8B8D9; + border-top: 1px solid var(--memdef-border-color); + border-left: 1px solid var(--memdef-border-color); + border-right: 1px solid var(--memdef-border-color); padding: 6px 0px 6px 0px; - color: #253555; + color: var(--memdef-proto-text-color); font-weight: bold; - text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); - background-color: #DFE5F1; - /* opera specific markup */ + text-shadow: var(--memdef-proto-text-shadow); + background-color: var(--memdef-proto-background-color); 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-family: var(--font-family-monospace); font-size: 65%; } .memdoc, dl.reflist dd { - border-bottom: 1px solid #A8B8D9; - border-left: 1px solid #A8B8D9; - border-right: 1px solid #A8B8D9; + border-bottom: 1px solid var(--memdef-border-color); + border-left: 1px solid var(--memdef-border-color); + border-right: 1px solid var(--memdef-border-color); 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; + background-color: var(--memdef-doc-background-color); /* opera specific markup */ border-bottom-left-radius: 4px; border-bottom-right-radius: 4px; @@ -748,7 +1084,7 @@ dl.reflist dd { } .paramname { - color: #602020; + color: var(--memdef-param-name-color); white-space: nowrap; } .paramname em { @@ -761,20 +1097,20 @@ dl.reflist dd { .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; + font-family: var(--font-family-monospace); vertical-align: top; } @@ -798,13 +1134,13 @@ span.mlabels { } 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; + background-color: var(--label-background-color); + border-top:1px solid var(--label-left-top-border-color); + border-left:1px solid var(--label-left-top-border-color); + border-right:1px solid var(--label-right-bottom-border-color); + border-bottom:1px solid var(--label-right-bottom-border-color); text-shadow: none; - color: white; + color: var(--label-foreground-color); margin-right: 4px; padding: 2px 3px; border-radius: 3px; @@ -821,8 +1157,8 @@ span.mlabel { div.directory { margin: 10px 0px; - border-top: 1px solid #9CAFD4; - border-bottom: 1px solid #9CAFD4; + border-top: 1px solid var(--directory-separator-color); + border-bottom: 1px solid var(--directory-separator-color); width: 100%; } @@ -858,9 +1194,14 @@ div.directory { border-left: 1px solid rgba(0,0,0,0.05); } +.directory tr.odd { + padding-left: 6px; + background-color: var(--index-odd-item-bg-color); +} + .directory tr.even { padding-left: 6px; - background-color: #F7F8FB; + background-color: var(--index-even-item-bg-color); } .directory img { @@ -878,11 +1219,11 @@ div.directory { cursor: pointer; padding-left: 2px; padding-right: 2px; - color: #3D578C; + color: var(--page-link-color); } .arrow { - color: #9CAFD4; + color: var(--nav-arrow-color); -webkit-user-select: none; -khtml-user-select: none; -moz-user-select: none; @@ -896,14 +1237,15 @@ div.directory { } .icon { - font-family: Arial, Helvetica; + font-family: var(--font-family-icon); + line-height: normal; font-weight: bold; font-size: 12px; height: 14px; width: 16px; display: inline-block; - background-color: #728DC1; - color: white; + background-color: var(--icon-background-color); + color: var(--icon-foreground-color); text-align: center; border-radius: 4px; margin-left: 2px; @@ -920,8 +1262,7 @@ div.directory { width: 24px; height: 18px; margin-bottom: 4px; - background-image:url('folderopen.png'); - background-position: 0px -4px; + background-image:var(--icon-folder-open-image); background-repeat: repeat-y; vertical-align:top; display: inline-block; @@ -931,8 +1272,7 @@ div.directory { width: 24px; height: 18px; margin-bottom: 4px; - background-image:url('folderclosed.png'); - background-position: 0px -4px; + background-image:var(--icon-folder-closed-image); background-repeat: repeat-y; vertical-align:top; display: inline-block; @@ -942,17 +1282,13 @@ div.directory { width: 24px; height: 18px; margin-bottom: 4px; - background-image:url('doc.png'); + background-image:var(--icon-doc-image); 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 { @@ -967,7 +1303,7 @@ div.dynheader { address { font-style: normal; - color: #2A3D61; + color: var(--footer-foreground-color); } table.doxtable caption { @@ -981,28 +1317,23 @@ table.doxtable { } table.doxtable td, table.doxtable th { - border: 1px solid #2D4068; + border: 1px solid var(--table-cell-border-color); padding: 3px 7px 2px; } table.doxtable th { - background-color: #374F7F; - color: #FFFFFF; + background-color: var(--table-header-background-color); + color: var(--table-header-foreground-color); font-size: 110%; padding-bottom: 4px; padding-top: 5px; } table.fieldtable { - /*width: 100%;*/ margin-bottom: 10px; - border: 1px solid #A8B8D9; + border: 1px solid var(--memdef-border-color); 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); } @@ -1012,8 +1343,8 @@ table.fieldtable { .fieldtable td.fieldtype, .fieldtable td.fieldname { white-space: nowrap; - border-right: 1px solid #A8B8D9; - border-bottom: 1px solid #A8B8D9; + border-right: 1px solid var(--memdef-border-color); + border-bottom: 1px solid var(--memdef-border-color); vertical-align: top; } @@ -1022,14 +1353,13 @@ table.fieldtable { } .fieldtable td.fielddoc { - border-bottom: 1px solid #A8B8D9; - /*width: 100%;*/ + border-bottom: 1px solid var(--memdef-border-color); } .fieldtable td.fielddoc p:first-child { margin-top: 0px; -} - +} + .fieldtable td.fielddoc p:last-child { margin-bottom: 2px; } @@ -1039,22 +1369,18 @@ table.fieldtable { } .fieldtable th { - background-image:url('nav_f.png'); + background-image: var(--memdef-title-gradient-image); background-repeat:repeat-x; - background-color: #E2E8F2; + background-color: var(--memdef-title-background-color); font-size: 90%; - color: #253555; + color: var(--memdef-proto-text-color); 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; + border-bottom: 1px solid var(--memdef-border-color); } @@ -1062,7 +1388,7 @@ table.fieldtable { top: 0px; left: 10px; height: 36px; - background-image: url('tab_b.png'); + background-image: var(--nav-gradient-image); z-index: 101; overflow: hidden; font-size: 13px; @@ -1071,13 +1397,13 @@ table.fieldtable { .navpath ul { font-size: 11px; - background-image:url('tab_b.png'); + background-image: var(--nav-gradient-image); background-repeat:repeat-x; background-position: 0 -5px; height:30px; line-height:30px; - color:#8AA0CC; - border:solid 1px #C2CDE4; + color:var(--nav-text-normal-color); + border:solid 1px var(--nav-breadcrumb-border-color); overflow:hidden; margin:0px; padding:0px; @@ -1089,10 +1415,10 @@ table.fieldtable { float:left; padding-left:10px; padding-right:15px; - background-image:url('bc_s.png'); + background-image:var(--nav-breadcrumb-image); background-repeat:no-repeat; background-position:right; - color:#364D7C; + color: var(--nav-foreground-color); } .navpath li.navelem a @@ -1101,15 +1427,16 @@ table.fieldtable { 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; + color: var(--nav-text-normal-color); + font-family: var(--font-family-nav); + text-shadow: var(--nav-text-normal-shadow); + text-decoration: none; } .navpath li.navelem a:hover { - color:#6884BD; + color: var(--nav-text-hover-color); + text-shadow: var(--nav-text-hover-shadow); } .navpath li.footer @@ -1121,7 +1448,7 @@ table.fieldtable { background-image:none; background-repeat:no-repeat; background-position:right; - color:#364D7C; + color: var(--footer-foreground-color); font-size: 8pt; } @@ -1133,7 +1460,7 @@ div.summary padding-right: 5px; width: 50%; text-align: right; -} +} div.summary a { @@ -1148,7 +1475,7 @@ table.classindex margin-right: 3%; width: 94%; border: 0; - border-spacing: 0; + border-spacing: 0; padding: 0; } @@ -1166,11 +1493,11 @@ div.ingroups a div.header { - background-image:url('nav_h.png'); + background-image: var(--header-gradient-image); background-repeat:repeat-x; - background-color: #F9FAFC; + background-color: var(--header-background-color); margin: 0px; - border-bottom: 1px solid #C4CFE5; + border-bottom: 1px solid var(--header-separator-color); } div.headertitle @@ -1193,11 +1520,6 @@ dl.section { padding-left: 0px; } -dl.section.DocNodeRTL { - margin-right: 0px; - padding-right: 0px; -} - dl.note { margin-left: -7px; padding-left: 3px; @@ -1205,16 +1527,6 @@ dl.note { 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; @@ -1222,16 +1534,6 @@ dl.warning, dl.attention { 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; @@ -1239,16 +1541,6 @@ dl.pre, dl.post, dl.invariant { 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; @@ -1256,16 +1548,6 @@ dl.deprecated { 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; @@ -1273,16 +1555,6 @@ dl.todo { 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; @@ -1290,16 +1562,6 @@ dl.test { 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; @@ -1307,21 +1569,16 @@ dl.bug { 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; } +#projectrow +{ + height: 56px; +} + #projectlogo { text-align: center; @@ -1337,25 +1594,29 @@ dl.section dd { #projectalign { vertical-align: middle; + padding-left: 0.5em; } #projectname { - font: 300% Tahoma, Arial,sans-serif; + font-size: 200%; + font-family: var(--font-family-title); margin: 0px; padding: 2px 0px; } - + #projectbrief { - font: 120% Tahoma, Arial,sans-serif; + font-size: 90%; + font-family: var(--font-family-title); margin: 0px; padding: 0px; } #projectnumber { - font: 50% Tahoma, Arial,sans-serif; + font-size: 50%; + font-family: 50% var(--font-family-title); margin: 0px; padding: 0px; } @@ -1365,7 +1626,8 @@ dl.section dd { padding: 0px; margin: 0px; width: 100%; - border-bottom: 1px solid #5373B4; + border-bottom: 1px solid var(--title-separator-color); + background-color: var(--title-background-color); } .image @@ -1398,17 +1660,12 @@ dl.section dd { font-weight: bold; } -div.zoom -{ - border: 1px solid #90A5CE; -} - dl.citelist { margin-bottom:50px; } dl.citelist dt { - color:#334975; + color:var(--citation-label-color); float:left; font-weight:bold; margin-right:10px; @@ -1424,8 +1681,8 @@ dl.citelist dd { div.toc { padding: 14px 25px; - background-color: #F4F6FA; - border: 1px solid #D8DFEE; + background-color: var(--toc-background-color); + border: 1px solid var(--toc-border-color); border-radius: 7px 7px 7px 7px; float: right; height: auto; @@ -1433,28 +1690,17 @@ div.toc { 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; + background: var(--toc-down-arrow-image) no-repeat scroll 0 5px transparent; + font: 10px/1.2 var(--font-family-toc); 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; + font: bold 12px/1.2 var(--font-family-toc); + color: var(--toc-header-color); border-bottom: 0 none; margin: 0; } @@ -1463,7 +1709,7 @@ div.toc ul { list-style: none outside none; border: medium none; padding: 0px; -} +} div.toc li.level1 { margin-left: 0px; @@ -1474,11 +1720,11 @@ div.toc li.level2 { } div.toc li.level3 { - margin-left: 30px; + margin-left: 15px; } div.toc li.level4 { - margin-left: 45px; + margin-left: 15px; } span.emoji { @@ -1487,29 +1733,13 @@ span.emoji { */ } -.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; +span.obfuscator { + display: none; } .inherit_header { font-weight: bold; - color: gray; + color: var(--inherit-header-color); cursor: pointer; -webkit-touch-callout: none; -webkit-user-select: none; @@ -1541,11 +1771,12 @@ tr.heading h2 { #powerTip { cursor: default; - white-space: nowrap; - background-color: white; - border: 1px solid gray; + /*white-space: nowrap;*/ + color: var(--tooltip-foreground-color); + background-color: var(--tooltip-background-color); + border: 1px solid var(--tooltip-border-color); border-radius: 4px 4px 4px 4px; - box-shadow: 1px 1px 7px gray; + box-shadow: var(--tooltip-shadow); display: none; font-size: smaller; max-width: 80%; @@ -1556,7 +1787,7 @@ tr.heading h2 { } #powerTip div.ttdoc { - color: grey; + color: var(--tooltip-doc-color); font-style: italic; } @@ -1564,18 +1795,24 @@ tr.heading h2 { font-weight: bold; } +#powerTip a { + color: var(--tooltip-link-color); +} + #powerTip div.ttname { font-weight: bold; } #powerTip div.ttdeci { - color: #006318; + color: var(--tooltip-declaration-color); } #powerTip div { margin: 0px; padding: 0px; - font: 12px/16px Roboto,sans-serif; + font-size: 12px; + font-family: var(--font-family-tooltip); + line-height: 16px; } #powerTip:before, #powerTip:after { @@ -1620,12 +1857,12 @@ tr.heading h2 { } #powerTip.n:after, #powerTip.ne:after, #powerTip.nw:after { - border-top-color: #FFFFFF; + border-top-color: var(--tooltip-background-color); border-width: 10px; margin: 0px -10px; } -#powerTip.n:before { - border-top-color: #808080; +#powerTip.n:before, #powerTip.ne:before, #powerTip.nw:before { + border-top-color: var(--tooltip-border-color); border-width: 11px; margin: 0px -11px; } @@ -1648,13 +1885,13 @@ tr.heading h2 { } #powerTip.s:after, #powerTip.se:after, #powerTip.sw:after { - border-bottom-color: #FFFFFF; + border-bottom-color: var(--tooltip-background-color); border-width: 10px; margin: 0px -10px; } #powerTip.s:before, #powerTip.se:before, #powerTip.sw:before { - border-bottom-color: #808080; + border-bottom-color: var(--tooltip-border-color); border-width: 11px; margin: 0px -11px; } @@ -1675,13 +1912,13 @@ tr.heading h2 { left: 100%; } #powerTip.e:after { - border-left-color: #FFFFFF; + border-left-color: var(--tooltip-border-color); border-width: 10px; top: 50%; margin-top: -10px; } #powerTip.e:before { - border-left-color: #808080; + border-left-color: var(--tooltip-border-color); border-width: 11px; top: 50%; margin-top: -11px; @@ -1691,13 +1928,13 @@ tr.heading h2 { right: 100%; } #powerTip.w:after { - border-right-color: #FFFFFF; + border-right-color: var(--tooltip-border-color); border-width: 10px; top: 50%; margin-top: -10px; } #powerTip.w:before { - border-right-color: #808080; + border-right-color: var(--tooltip-border-color); border-width: 11px; top: 50%; margin-top: -11px; @@ -1731,7 +1968,7 @@ table.markdownTable { } table.markdownTable td, table.markdownTable th { - border: 1px solid #2D4068; + border: 1px solid var(--table-cell-border-color); padding: 3px 7px 2px; } @@ -1739,8 +1976,8 @@ table.markdownTable tr { } th.markdownTableHeadLeft, th.markdownTableHeadRight, th.markdownTableHeadCenter, th.markdownTableHeadNone { - background-color: #374F7F; - color: #FFFFFF; + background-color: var(--table-header-background-color); + color: var(--table-header-foreground-color); font-size: 110%; padding-bottom: 4px; padding-top: 5px; @@ -1758,36 +1995,51 @@ th.markdownTableHeadCenter, td.markdownTableBodyCenter { text-align: center } -.DocNodeRTL { - text-align: right; - direction: rtl; +tt, code, kbd, samp +{ + display: inline-block; } +/* @end */ -.DocNodeLTR { - text-align: left; - direction: ltr; +u { + text-decoration: underline; } -table.DocNodeRTL { - width: auto; - margin-right: 0; - margin-left: auto; +details>summary { + list-style-type: none; } -table.DocNodeLTR { - width: auto; - margin-right: auto; - margin-left: 0; +details > summary::-webkit-details-marker { + display: none; } -tt, code, kbd, samp -{ - display: inline-block; - direction:ltr; +details>summary::before { + content: "\25ba"; + padding-right:4px; + font-size: 80%; } -/* @end */ -u { - text-decoration: underline; +details[open]>summary::before { + content: "\25bc"; + padding-right:4px; + font-size: 80%; +} + +body { + scrollbar-color: var(--scrollbar-thumb-color) var(--scrollbar-background-color); +} + +::-webkit-scrollbar { + background-color: var(--scrollbar-background-color); + height: 12px; + width: 12px; +} +::-webkit-scrollbar-thumb { + border-radius: 6px; + box-shadow: inset 0 0 12px 12px var(--scrollbar-thumb-color); + border: solid 2px transparent; +} +::-webkit-scrollbar-corner { + background-color: var(--scrollbar-background-color); } diff --git a/doxygen.png b/doxygen.png deleted file mode 100644 index 3ff17d807fd8aa003bed8bb2a69e8f0909592fd1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3779 zcmV;!4m|ORP)tMIv#Q0*~7*`IBSO7_x;@a8#Zk6_PeKR_s92J&)(m+);m9Iz3blw)z#Gi zP!9lj4$%+*>Hz@HCmM9L9|8c+0u=!H$O3?R0Kgx|#WP<6fKfC8fM-CQZT|_r@`>VO zX^Hgb|9cJqpdJA5$MCEK`F_2@2Y@s>^+;pF`~jdI0Pvr|vl4`=C)EH@1IFe7pdJ8F zH(qGi004~QnF)Ggga~8v08kGAs2hKTATxr7pwfNk|4#_AaT>w8P6TV+R2kbS$v==} zAjf`s0g#V8lB+b3)5oEI*q+{Yt$MZDruD2^;$+(_%Qn+%v0X-bJO=;@kiJ^ygLBnC z?1OVv_%aex1M@jKU|Z~$eI?PoF4Vj>fDzyo zAiLfpXY*a^Sj-S5D0S3@#V$sRW)g)_1e#$%8xdM>Jm7?!h zu0P2X=xoN>^!4DoPRgph2(2va07yfpXF+WH7EOg1GY%Zn z7~1A<(z7Q$ktEXhW_?GMpHp9l_UL18F3KOsxu81pqoBiNbFSGsof-W z6~eloMoz=4?OOnl2J268x5rOY`dCk0us(uS#Ud4yqOr@?=Q57a}tit|BhY>}~frH1sP`ScHS_d)oqH^lYy zZ%VP`#10MlE~P?cE(%(#(AUSv_T{+;t@$U}El}(1ig`vZo`Rm;+5&(AYzJ^Ae=h2X z@Re%vHwZU>|f0NI&%$*4eJweC5OROQrpPMA@*w|o z()A==l}(@bv^&>H1Ob3C=<^|hob?0+xJ?QQ3-ueQC}zy&JQNib!OqSO@-=>XzxlSF zAZ^U*1l6EEmg3r};_HY>&Jo_{dOPEFTWPmt=U&F#+0(O59^UIlHbNX+eF8UzyDR*T z(=5X$VF3!gm@RooS-&iiUYGG^`hMR(07zr_xP`d!^BH?uD>Phl8Rdifx3Af^Zr`Ku ztL+~HkVeL#bJ)7;`=>;{KNRvjmc}1}c58Sr#Treq=4{xo!ATy|c>iRSp4`dzMMVd@ zL8?uwXDY}Wqgh4mH`|$BTXpUIu6A1-cSq%hJw;@^Zr8TP=GMh*p(m(tN7@!^D~sl$ zz^tf4II4|};+irE$Fnm4NTc5%p{PRA`%}Zk`CE5?#h3|xcyQsS#iONZ z6H(@^i9td!$z~bZiJLTax$o>r(p}3o@< zyD7%(>ZYvy=6$U3e!F{Z`uSaYy`xQyl?b{}eg|G3&fz*`QH@mDUn)1%#5u`0m$%D} z?;tZ0u(mWeMV0QtzjgN!lT*pNRj;6510Wwx?Yi_=tYw|J#7@(Xe7ifDzXuK;JB;QO z#bg~K$cgm$@{QiL_3yr}y&~wuv=P=#O&Tj=Sr)aCUlYmZMcw?)T?c%0rUe1cS+o!qs_ zQ6Gp)-{)V!;=q}llyK3|^WeLKyjf%y;xHku;9(vM!j|~<7w1c*Mk-;P{T&yG) z@C-8E?QPynNQ<8f01D`2qexcVEIOU?y}MG)TAE6&VT5`rK8s(4PE;uQ92LTXUQ<>^ ztyQ@=@kRdh@ebUG^Z6NWWIL;_IGJ2ST>$t!$m$qvtj0Qmw8moN6GUV^!QKNK zHBXCtUH8)RY9++gH_TUV4^=-j$t}dD3qsN7GclJ^Zc&(j6&a_!$jCf}%c5ey`pm~1)@{yI3 zTdWyB+*X{JFw#z;PwRr5evb2!ueWF;v`B0HoUu4-(~aL=z;OXUUEtG`_$)Oxw6FKg zEzY`CyKaSBK3xt#8gA|r_|Kehn_HYVBMpEwbn9-fI*!u*eTA1ef8Mkl1=!jV4oYwWYM}i`A>_F4nhmlCIC6WLa zY%;4&@AlnaG11ejl61Jev21|r*m+?Kru3;1tFDl}#!OzUp6c>go4{C|^erwpG*&h6bspUPJag}oOkN2912Y3I?(eRc@U9>z#HPBHC?nps7H5!zP``90!Q1n80jo+B3TWXp!8Pe zwuKuLLI6l3Gv@+QH*Y}2wPLPQ1^EZhT#+Ed8q8Wo z1pTmIBxv14-{l&QVKxAyQF#8Q@NeJwWdKk>?cpiJLkJr+aZ!Me+Cfp!?FWSRf^j2k z73BRR{WSKaMkJ>1Nbx5dan5hg^_}O{Tj6u%iV%#QGz0Q@j{R^Ik)Z*+(YvY2ziBG)?AmJa|JV%4UT$k`hcOg5r9R?5>?o~JzK zJCrj&{i#hG>N7!B4kNX(%igb%kDj0fOQThC-8mtfap82PNRXr1D>lbgg)dYTQ(kbx z`Ee5kXG~Bh+BHQBf|kJEy6(ga%WfhvdQNDuOfQoe377l#ht&DrMGeIsI5C<&ai zWG$|hop2@@q5YDa)_-A?B02W;#fH!%k`daQLEItaJJ8Yf1L%8x;kg?)k)00P-lH+w z)5$QNV6r2$YtnV(4o=0^3{kmaXn*Dm0F*fU(@o)yVVjk|ln8ea6BMy%vZAhW9|wvA z8RoDkVoMEz1d>|5(k0Nw>22ZT){V<3$^C-cN+|~hKt2)){+l-?3m@-$c?-dlzQ)q- zZ)j%n^gerV{|+t}9m1_&&Ly!9$rtG4XX|WQ8`xYzGC~U@nYh~g(z9)bdAl#xH)xd5a=@|qql z|FzEil{P5(@gy!4ek05i$>`E^G~{;pnf6ftpLh$h#W?^#4UkPfa;;?bsIe&kz!+40 zI|6`F2n020)-r`pFaZ38F!S-lJM-o&inOw|66=GMeP@xQU5ghQH{~5Uh~TMTd;I9` z>YhVB`e^EVj*S7JF39ZgNf}A-0DwOcTT63ydN$I3b?yBQtUI*_fae~kPvzoD$zjX3 zoqBe#>12im4WzZ=f^4+u=!lA|#r%1`WB0-6*3BL#at`47#ebPpR|D1b)3BjT34nYY z%Ds%d?5$|{LgOIaRO{{oC&RK`O91$fqwM0(C_TALcozu*fWHb%%q&p-q{_8*2Zsi^ zh1ZCnr^UYa;4vQEtHk{~zi>wwMC5o{S=$P0X681y`SXwFH?Ewn{x-MOZynmc)JT5v zuHLwh;tLfxRrr%|k370}GofLl7thg>ACWWY&msqaVu&ry+`7+Ss>NL^%T1|z{IGMA zW-SKl=V-^{(f!Kf^#3(|T2W47d(%JVCI4JgRrT1pNz>+ietmFToNv^`gzC@&O-)+i zPQ~RwK8%C_vf%;%e>NyTp~dM5;!C|N0Q^6|CEb7Bw=Vz~$1#FA;Z*?mKSC)Hl-20s t8QyHj(g6VK0RYbl8UjE)0O0w=e*@m04r>stuEhWV002ovPDHLkV1hl;dM*F} diff --git a/doxygen.svg b/doxygen.svg new file mode 100644 index 00000000..79a76354 --- /dev/null +++ b/doxygen.svg @@ -0,0 +1,28 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dynsections.js b/dynsections.js index 88f2c27e..9b281563 100644 --- a/dynsections.js +++ b/dynsections.js @@ -47,6 +47,8 @@ function updateStripes() { $('table.directory tr'). removeClass('even').filter(':visible:even').addClass('even'); + $('table.directory tr'). + removeClass('odd').filter(':visible:odd').addClass('odd'); } function toggleLevel(level) @@ -118,11 +120,80 @@ function toggleInherit(id) $(img).attr('src',src.substring(0,src.length-10)+'open.png'); } } -/* @license-end */ +var opened=true; +// in case HTML_COLORSTYLE is LIGHT or DARK the vars will be replaced, so we write them out explicitly and use double quotes +var plusImg = [ "var(--fold-plus-image)", "var(--fold-plus-image-relpath)" ]; +var minusImg = [ "var(--fold-minus-image)", "var(--fold-minus-image-relpath)" ]; + +// toggle all folding blocks +function codefold_toggle_all(relPath) { + if (opened) { + $('#fold_all').css('background-image',plusImg[relPath]); + $('div[id^=foldopen]').hide(); + $('div[id^=foldclosed]').show(); + } else { + $('#fold_all').css('background-image',minusImg[relPath]); + $('div[id^=foldopen]').show(); + $('div[id^=foldclosed]').hide(); + } + opened=!opened; +} + +// toggle single folding block +function codefold_toggle(id) { + $('#foldopen'+id).toggle(); + $('#foldclosed'+id).toggle(); +} +function init_codefold(relPath) { + $('span[class=lineno]').css( + {'padding-right':'4px', + 'margin-right':'2px', + 'display':'inline-block', + 'width':'54px', + 'background':'linear-gradient(var(--fold-line-color),var(--fold-line-color)) no-repeat 46px/2px 100%' + }); + // add global toggle to first line + $('span[class=lineno]:first').append(''); + // add vertical lines to other rows + $('span[class=lineno]').not(':eq(0)').append(''); + // add toggle controls to lines with fold divs + $('div[class=foldopen]').each(function() { + // extract specific id to use + var id = $(this).attr('id').replace('foldopen',''); + // extract start and end foldable fragment attributes + var start = $(this).attr('data-start'); + var end = $(this).attr('data-end'); + // replace normal fold span with controls for the first line of a foldable fragment + $(this).find('span[class=fold]:first').replaceWith(''); + // append div for folded (closed) representation + $(this).after(''); + // extract the first line from the "open" section to represent closed content + var line = $(this).children().first().clone(); + // remove any glow that might still be active on the original line + $(line).removeClass('glow'); + if (start) { + // if line already ends with a start marker (e.g. trailing {), remove it + $(line).html($(line).html().replace(new RegExp('\\s*'+start+'\\s*$','g'),'')); + } + // replace minus with plus symbol + $(line).find('span[class=fold]').css('background-image',plusImg[relPath]); + // append ellipsis + $(line).append(' '+start+'…'+end); + // insert constructed line into closed div + $('#foldclosed'+id).html(line); + }); +} + +/* @license-end */ $(document).ready(function() { $('.code,.codeRef').each(function() { $(this).data('powertip',$('#a'+$(this).attr('href').replace(/.*\//,'').replace(/[^a-z_A-Z0-9]/g,'_')).html()); + $.fn.powerTip.smartPlacementLists.s = [ 's', 'n', 'ne', 'se' ]; $(this).powerTip({ placement: 's', smartPlacement: true, mouseOnToPopup: true }); }); }); diff --git a/errexit_8f.html b/errexit_8f.html index ddce4e36..2e512e33 100644 --- a/errexit_8f.html +++ b/errexit_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: errexit.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
errexit.f File Reference
+
errexit.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

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

Detailed Description

Exit with a return code.

@@ -107,8 +113,8 @@

Definition in file errexit.f.

Function/Subroutine Documentation

- -

◆ errexit()

+ +

◆ errexit()

@@ -117,7 +123,7 @@

subroutine errexit ( integer  - IRET) + iret) @@ -150,7 +156,7 @@

diff --git a/errexit_8f.js b/errexit_8f.js index 3d580922..eec02440 100644 --- a/errexit_8f.js +++ b/errexit_8f.js @@ -1,4 +1,4 @@ var errexit_8f = [ - [ "errexit", "errexit_8f.html#abcd4c3fc1b8b684d5dc7b9412891de91", null ] + [ "errexit", "errexit_8f.html#acdfe2a7413809994b26b8cbc335326d8", null ] ]; \ No newline at end of file diff --git a/errexit_8f_source.html b/errexit_8f_source.html index a291a54f..f0f8b1e8 100644 --- a/errexit_8f_source.html +++ b/errexit_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: errexit.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,48 +81,56 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
errexit.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Exit with a return code.
+
3C> @author Mark Iredell @date 1998-06-04
+
4
+
5C> Exit with a return code.
+
6C>
+
7C> Program history log:
+
8C> - 1998-06-04 Mark Iredell
+
9C> - 1999-01-26 Stephen Gilbert
+
10C> - Changed to use XLF utility routine exit_(n) instead of exit(n).
+
11C> exit_(n) will return the proper value (n must be 4 byte int)
+
12C> to the sh/ksh shell status variable $? ($status for csh)
+
13C> on the IBM SP.
+
14C>
+
15C> @param[in] IRET Integer return code.
+
16C>
+
17C> @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/errmsg_8f.html b/errmsg_8f.html index 3c75f07f..0a910f14 100644 --- a/errmsg_8f.html +++ b/errmsg_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: errmsg.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
errmsg.f File Reference
+
errmsg.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

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

Detailed Description

Write a message to stderr.

@@ -107,8 +113,8 @@

Definition in file errmsg.f.

Function/Subroutine Documentation

- -

◆ errmsg()

+ +

◆ errmsg()

@@ -117,7 +123,7 @@

subroutine errmsg ( character*(*)  - CMSG) + cmsg) @@ -147,7 +153,7 @@

diff --git a/errmsg_8f.js b/errmsg_8f.js index 237b50ba..af94ae50 100644 --- a/errmsg_8f.js +++ b/errmsg_8f.js @@ -1,4 +1,4 @@ var errmsg_8f = [ - [ "errmsg", "errmsg_8f.html#acb908fdaebb814b3210e63ecae74c996", null ] + [ "errmsg", "errmsg_8f.html#aa029ec617c24e6ff25756009764a254a", null ] ]; \ No newline at end of file diff --git a/errmsg_8f_source.html b/errmsg_8f_source.html index f0ec0026..d6981c00 100644 --- a/errmsg_8f_source.html +++ b/errmsg_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: errmsg.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,46 +81,54 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
errmsg.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Write a message to stderr.
+
3C> @author Mark Iredell @date 1995-10-31
+
4
+
5C> Write a message to stderr.
+
6C>
+
7C> Program history log:
+
8C> - 1995-10-31 Mark Iredell
+
9C>
+
10C> @param[in] CMSG character*(*) message to write.
+
11C>
+
12C> @note This is a machine-dependent subprogram for Cray.
+
13C>
+
14C> @author Mark Iredell @date 1995-10-31
+
15C-----------------------------------------------------------------------
+
+
16 SUBROUTINE errmsg(CMSG)
+
17 CHARACTER*(*) CMSG
+
18C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
19 WRITE(0,'(A)') cmsg
+
20C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
21 RETURN
+
+
22 END
+
errmsg
subroutine errmsg(cmsg)
Write a message to stderr.
Definition errmsg.f:17
diff --git a/files.html b/files.html index e395fbbc..14271739 100644 --- a/files.html +++ b/files.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: File List @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,231 +76,235 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
File List
+
File List
Here is a list of all documented files with brief descriptions:
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
[detail level 12]
 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
 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
 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
 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
 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
 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
 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
 w3ft05v.fConvert (145,37) grid to (65,65) n
 w3ft06.fConvert (145,37) to (65,65) s
 w3ft06v.fConvert (145,37) grid to (65,65) s
 w3ft07.fTransform gridpoint fld by interpolation
 w3ft08.fComputes 2.5 x 2.5 n
 w3ft09.fComputes 2.5x2.5 n
 w3ft10.fComputes 2.5 x 2.5 s
 w3ft11.fComputes 2.5x2.5 s
 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
 w3ft202.fConvert (361,91) grid to (65,43) n
 w3ft203.fConvert (361,91) grid to (45,39) n
 w3ft204.fConvert (361,181) grid to (93,68) mercator grid
 w3ft205.fConvert (361,91) grid to (45,39) n
 w3ft206.fConvert (361,91) grid to (51,41) lambert grid
 w3ft207.fConvert (361,91) grid to (49,35) n
 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
 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
 w3ft214.fConvert (361,91) grid to (97,69) n
 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
 w3ft39.fComputes 2.5x2.5 n
 w3ft40.fComputes 2.5 x 2.5 s
 w3ft41.fComputes 2.5x2.5 s
 w3ft43v.fConvert (361,181) grid to (65,65) n
 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
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
 ► src
@@ -308,7 +312,7 @@ diff --git a/files_dup.js b/files_dup.js index d3b2f947..c3b39c49 100644 --- a/files_dup.js +++ b/files_dup.js @@ -1,216 +1,4 @@ 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" ] + [ "src", "dir_68267d1309a1af8e8297ef4c3efbcdba.html", "dir_68267d1309a1af8e8297ef4c3efbcdba" ] ]; \ No newline at end of file diff --git a/folderclosed.png b/folderclosed.png deleted file mode 100644 index bb8ab35edce8e97554e360005ee9fc5bffb36e66..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 616 zcmV-u0+;=XP)a9#ETzayK)T~Jw&MMH>OIr#&;dC}is*2Mqdf&akCc=O@`qC+4i z5Iu3w#1M@KqXCz8TIZd1wli&kkl2HVcAiZ8PUn5z_kG@-y;?yK06=cA0U%H0PH+kU zl6dp}OR(|r8-RG+YLu`zbI}5TlOU6ToR41{9=uz^?dGTNL;wIMf|V3`d1Wj3y!#6` zBLZ?xpKR~^2x}?~zA(_NUu3IaDB$tKma*XUdOZN~c=dLt_h_k!dbxm_*ibDM zlFX`g{k$X}yIe%$N)cn1LNu=q9_CS)*>A zsX_mM4L@`(cSNQKMFc$RtYbx{79#j-J7hk*>*+ZZhM4Hw?I?rsXCi#mRWJ=-0LGV5a-WR0Qgt<|Nqf)C-@80`5gIz45^_20000 + + + + + + + + + diff --git a/folderclosedd.svg b/folderclosedd.svg new file mode 100644 index 00000000..52f0166a --- /dev/null +++ b/folderclosedd.svg @@ -0,0 +1,11 @@ + + + + + + + + + + diff --git a/folderopen.png b/folderopen.png deleted file mode 100644 index d6c7f676a3b3ef8c2c307d319dff3c6a604eb227..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 597 zcmV-b0;>IqP)X=#(TiCT&PiIIVc55T}TU}EUh*{q$|`3@{d>{Tc9Bo>e= zfmF3!f>fbI9#GoEHh0f`i5)wkLpva0ztf%HpZneK?w-7AK@b4Itw{y|Zd3k!fH?q2 zlhckHd_V2M_X7+)U&_Xcfvtw60l;--DgZmLSw-Y?S>)zIqMyJ1#FwLU*%bl38ok+! zh78H87n`ZTS;uhzAR$M`zZ`bVhq=+%u9^$5jDplgxd44}9;IRqUH1YHH|@6oFe%z( zo4)_>E$F&^P-f(#)>(TrnbE>Pefs9~@iN=|)Rz|V`sGfHNrJ)0gJb8xx+SBmRf@1l zvuzt=vGfI)<-F9!o&3l?>9~0QbUDT(wFdnQPv%xdD)m*g%!20>Bc9iYmGAp<9YAa( z0QgYgTWqf1qN++Gqp z8@AYPTB3E|6s=WLG?xw0tm|U!o=&zd+H0oRYE;Dbx+Na9s^STqX|Gnq%H8s(nGDGJ j8vwW|`Ts`)fSK|Kx=IK@RG@g200000NkvXXu0mjfauFEA diff --git a/folderopen.svg b/folderopen.svg new file mode 100644 index 00000000..f6896dd2 --- /dev/null +++ b/folderopen.svg @@ -0,0 +1,17 @@ + + + + + + + + + + diff --git a/folderopend.svg b/folderopend.svg new file mode 100644 index 00000000..2d1f06e7 --- /dev/null +++ b/folderopend.svg @@ -0,0 +1,12 @@ + + + + + + + + + + + diff --git a/fparsei_8f.html b/fparsei_8f.html index 8774ddfe..1a9cfdc9 100644 --- a/fparsei_8f.html +++ b/fparsei_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: fparsei.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
fparsei.f File Reference
+
fparsei.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine fparsei (carg, marg, karg)
 This subprogram extracts integers from a free-format character string.
 

Detailed Description

Extract integers from a free-format character string.

@@ -107,8 +113,8 @@

Definition in file fparsei.f.

Function/Subroutine Documentation

- -

◆ fparsei()

+ +

◆ fparsei()

@@ -117,19 +123,19 @@

subroutine fparsei ( character*(*)  - CARG, + carg,   - MARG, + marg, integer, dimension(marg)  - KARG  + karg  @@ -166,7 +172,7 @@

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

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...
 
subroutine fparser (carg, marg, rarg)
 This subprogram extracts real numbers from a free-format character string.
 

Detailed Description

Extracts real numbers from a free-format character string.

@@ -107,8 +113,8 @@

Definition in file fparser.f.

Function/Subroutine Documentation

- -

◆ fparser()

+ +

◆ fparser()

@@ -117,19 +123,19 @@

subroutine fparser ( character*(*)  - CARG, + carg,   - MARG, + marg, real, dimension(marg)  - RARG  + rarg  @@ -166,7 +172,7 @@

diff --git a/fparser_8f.js b/fparser_8f.js index 01254742..5ed83ca1 100644 --- a/fparser_8f.js +++ b/fparser_8f.js @@ -1,4 +1,4 @@ var fparser_8f = [ - [ "fparser", "fparser_8f.html#afd0eece805c9f9aa1afa5b5496298aa5", null ] + [ "fparser", "fparser_8f.html#a614ee9606f217b051a2643684051df50", null ] ]; \ No newline at end of file diff --git a/fparser_8f_source.html b/fparser_8f_source.html index 42f7a7ff..7b889973 100644 --- a/fparser_8f_source.html +++ b/fparser_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: fparser.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,54 +81,62 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
fparser.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Extracts real numbers from a free-format character string.
+
3C> @author Mark Iredell @date 1998-09-03
+
4
+
5C> This subprogram extracts real numbers from a free-format
+
6C> character string. It is useful for parsing command arguments.
+
7C>
+
8C> Program history log:
+
9C> - 1998-09-03 Mark Iredell
+
10C>
+
11C> @param[in] CARG character*(*) string of ascii digits to parse.
+
12C> Real numbers may be separated by a comma or by blanks.
+
13C> @param[in] MARG integer maximum number of real numbers to parse.
+
14C>
+
15C> @param[out] RARG real (MARG) numbers parsed.
+
16C> (from 0 to MARG values may be returned.)
+
17C>
+
18C> @note To determine the actual number of real numbers found in the string,
+
19C> RARG should be set to fill values before the call to FPARSER() and
+
20C> the number of non-fill values should be counted after the call.
+
21C>
+
22C> @author Mark Iredell @date 1998-09-03
+
23C-----------------------------------------------------------------------
+
+
24 SUBROUTINE fparser(CARG,MARG,RARG)
+
25 CHARACTER*(*) CARG
+
26 REAL RARG(MARG)
+
27C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
28 READ(carg,*,iostat=ios) rarg
+
29C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
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/functions.html b/functions.html new file mode 100644 index 00000000..dded8c2f --- /dev/null +++ b/functions.html @@ -0,0 +1,114 @@ + + + + + + + +NCEPLIBS-w3emc: Data Fields + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
Here is a list of all documented data types members with links to the data structure documentation for each member
+
+
+ + + + diff --git a/functions_func.html b/functions_func.html new file mode 100644 index 00000000..bdea2cb3 --- /dev/null +++ b/functions_func.html @@ -0,0 +1,114 @@ + + + + + + + +NCEPLIBS-w3emc: Data Fields - Functions/Subroutines + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
Here is a list of all documented functions with links to the struct/union documentation for each field:
+
+
+ + + + diff --git a/gbyte_8f.html b/gbyte_8f.html index edb17e5b..748e3611 100644 --- a/gbyte_8f.html +++ b/gbyte_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gbyte.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
gbyte.f File Reference
+
gbyte.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

subroutine gbyte (IPACKD, IUNPKD, NOFF, NBITS)
 This is the fortran version of gbyte. More...
 
subroutine gbyte (ipackd, iunpkd, noff, nbits)
 This is the fortran version of gbyte.
 

Detailed Description

This is the fortran version of gbyte.

@@ -107,8 +113,8 @@

Definition in file gbyte.f.

Function/Subroutine Documentation

- -

◆ gbyte()

+ +

◆ gbyte()

@@ -117,25 +123,25 @@

subroutine gbyte ( integer, dimension(*)  - IPACKD, + ipackd, integer  - IUNPKD, + iunpkd,   - NOFF, + noff,   - NBITS  + nbits  @@ -172,7 +178,7 @@

diff --git a/gbyte_8f.js b/gbyte_8f.js index f4d3943f..4b654c9f 100644 --- a/gbyte_8f.js +++ b/gbyte_8f.js @@ -1,4 +1,4 @@ var gbyte_8f = [ - [ "gbyte", "gbyte_8f.html#ad73b69048043b0e9876125b1d839e5c6", null ] + [ "gbyte", "gbyte_8f.html#ad8ac424552647ef42f4b054733f7b7b1", null ] ]; \ No newline at end of file diff --git a/gbyte_8f_source.html b/gbyte_8f_source.html index 83861f5d..a0d1d6f0 100644 --- a/gbyte_8f_source.html +++ b/gbyte_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gbyte.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,110 +81,118 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
gbyte.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief This is the fortran version of gbyte.
+
3C> @author Dr. Robert C. Gammill @date 1972-05-DD
+
4
+
5C> This is the fortran version of gbyte
+
6C>
+
7C> Program history log:
+
8C> - Russell E. Jones 1991-03-DD
+
9C> Changes for SiliconGraphics IRIS-4D/25
+
10C> SiliconGraphics 3.3 FORTRAN 77.
+
11C>
+
12C> To unpack a byte into a target word. The unpacked byte is right-justified
+
13C> in the target word, and the remainder of the word is zero-filled.
+
14C>
+
15C> @param[in] IPACKD The word or array containing the byte to be unpacked.
+
16C>
+
17C> @param[out] IUNPKD The word which will contain the unpacked byte.
+
18C>
+
19C> @param[in] NOFF The number of bits to skip, left to right, in IPACKD
+
20C> in order to locate the byte to be unpacked.
+
21C>
+
22C> @param[in] NBITS Number of bits in the byte to be unpacked. Maximum of
+
23C> 64 bits on 64 bit machine, 32 bits on 32 bit machine.
+
24C>
+
25C> @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)
+
30C
+
31 SAVE
+
32C
+
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
+
45C
+
46C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW
+
47C
+
48 icon = nbitsw - nbits
+
49 IF (icon.LT.0) RETURN
+
50 mask = masks(nbits)
+
51C
+
52C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE
+
53C APPEARS.
+
54C
+
55 index = ishft(noff,jshift)
+
56C
+
57C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD.
+
58C
+
59 ii = mod(noff,nbitsw)
+
60C
+
61C MOVER SPECIFIES HOW FAR TO THE RIGHT NBITS MUST BE MOVED IN ORDER
+
62C
+
63C TO BE RIGHT ADJUSTED.
+
64C
+
65 mover = icon - ii
+
66C
+
67 IF (mover.GT.0) THEN
+
68 iunpkd = iand(ishft(ipackd(index+1),-mover),mask)
+
69C
+
70C THE BYTE IS SPLIT ACROSS A WORD BREAK.
+
71C
+
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)
+
77C
+
78C THE BYTE IS ALREADY RIGHT ADJUSTED.
+
79C
+
80 ELSE
+
81 iunpkd = iand(ipackd(index+1),mask)
+
82 ENDIF
+
83C
+
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/gbytec_8f.html b/gbytec_8f.html index ddcaf1a5..fb1b0e68 100644 --- a/gbytec_8f.html +++ b/gbytec_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gbytec.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,38 +76,44 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
gbytec.f File Reference
+
gbytec.f File Reference
-

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

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...
 
subroutine gbytec (in, iout, iskip, nbyte)
 Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
 

Detailed Description

-

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

+

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

Author
NOAA Programmer

Definition in file gbytec.f.

Function/Subroutine Documentation

- -

◆ gbytec()

+ +

◆ gbytec()

@@ -116,25 +122,25 @@

subroutine gbytec ( character*1, dimension(*)  - IN, + in, integer, dimension(*)  - IOUT, + iout,   - ISKIP, + iskip,   - NBYTE  + nbyte  @@ -144,7 +150,7 @@

-

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

+

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

Parameters
@@ -165,7 +171,7 @@

diff --git a/gbytec_8f.js b/gbytec_8f.js index 1a118a20..34267d84 100644 --- a/gbytec_8f.js +++ b/gbytec_8f.js @@ -1,4 +1,4 @@ var gbytec_8f = [ - [ "gbytec", "gbytec_8f.html#adcae5457ea7270b3b95a379fec9233d7", null ] + [ "gbytec", "gbytec_8f.html#a43bd8d585799cf64eb09804156200064", null ] ]; \ No newline at end of file diff --git a/gbytec_8f_source.html b/gbytec_8f_source.html index 192a53a9..2cbb984e 100644 --- a/gbytec_8f_source.html +++ b/gbytec_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gbytec.f Source File @@ -23,10 +23,9 @@

[in]INCharacter*1 array input.
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0

- + +/* @license-end */ + +
@@ -76,43 +81,51 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
gbytec.f
+
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
-
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
+
3C> @author NOAA Programmer
+
4
+
5C> Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
+
6C>
+
7C> @param[in] IN Character*1 array input.
+
8C> @param[out] IOUT Unpacked array output.
+
9C> @param[in] ISKIP Initial number of bits to skip.
+
10C> @param[in] NBYTE Number of bits to take.
+
11C>
+
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
+
gbytec
subroutine gbytec(in, iout, iskip, nbyte)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition gbytec.f:14
+
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
diff --git a/gbytes_8f.html b/gbytes_8f.html index dd2ea2e0..b43af569 100644 --- a/gbytes_8f.html +++ b/gbytes_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gbytes.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
gbytes.f File Reference
+
gbytes.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

subroutine gbytes (IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
 Program history log: More...
 
subroutine gbytes (ipackd, iunpkd, noff, nbits, iskip, iter)
 Program history log:
 

Detailed Description

This is the fortran version of gbytes.

@@ -107,8 +113,8 @@

Definition in file gbytes.f.

Function/Subroutine Documentation

- -

◆ gbytes()

+ +

◆ gbytes()

@@ -117,37 +123,37 @@

subroutine gbytes ( integer, dimension(*)  - IPACKD, + ipackd, integer, dimension(*)  - IUNPKD, + iunpkd,   - NOFF, + noff,   - NBITS, + nbits,   - ISKIP, + iskip,   - ITER  + iter  @@ -184,7 +190,7 @@

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

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...
 
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.
 

Detailed Description

Get bytes - unpack bits.

@@ -106,8 +112,8 @@

Definition in file gbytesc.f.

Function/Subroutine Documentation

- -

◆ gbytesc()

+ +

◆ gbytesc()

@@ -116,37 +122,37 @@

subroutine gbytesc ( character*1, dimension(*)  - IN, + in, integer, dimension(*)  - IOUT, + iout,   - ISKIP, + iskip,   - NBYTE, + nbyte,   - NSKIP, + nskip,   - N  + n  @@ -179,7 +185,7 @@

diff --git a/gbytesc_8f.js b/gbytesc_8f.js index b390b28b..94191439 100644 --- a/gbytesc_8f.js +++ b/gbytesc_8f.js @@ -1,4 +1,4 @@ var gbytesc_8f = [ - [ "gbytesc", "gbytesc_8f.html#a8fd2d6beeef9feaf3ef1e927f66678db", null ] + [ "gbytesc", "gbytesc_8f.html#ad46c14caec87fa3f7d379d52fd8173bc", null ] ]; \ No newline at end of file diff --git a/gbytesc_8f_source.html b/gbytesc_8f_source.html index f8b8551e..316fb1ce 100644 --- a/gbytesc_8f_source.html +++ b/gbytesc_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gbytesc.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,79 +81,87 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
gbytesc.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Get bytes - unpack bits.
+
3C> @author Unknown
+
4
+
5C> Extract arbitrary size values from a packed bit string,
+
6C> right justifying each value in the unpacked array.
+
7C>
+
8C> @param[in] IN Character*1 array input.
+
9C> @param[out] IOUT Unpacked array output.
+
10C> @param[in] ISKIP Initial number of bits to skip.
+
11C> @param[in] NBYTE Number of bits to take.
+
12C> @param[in] NSKIP Additional number of bits to skip on each iteration.
+
13C> @param[in] N Number of iterations.
+
14C>
+
+
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
+
22c 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
+
30c 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
+
37c 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
+
44c 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/getbit_8f.html b/getbit_8f.html index 339cdbf0..d9c552c9 100644 --- a/getbit_8f.html +++ b/getbit_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getbit.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getbit.f File Reference
+
getbit.f File Reference
@@ -94,17 +100,95 @@

Go to the source code of this file.

- - - + + +

+

Functions/Subroutines

-subroutine getbit (IBM, IBS, IDS, LEN, MG, G, GROUND, GMIN, GMAX, NBIT)
 
subroutine getbit (ibm, ibs, ids, len, mg, g, ground, gmin, gmax, nbit)
 The number of bits required to pack a given field.
 

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.

+
Date
1992-10-31
+ +

Definition in file getbit.f.

+

Function/Subroutine Documentation

+ +

◆ getbit()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getbit ( ibm,
 ibs,
 ids,
 len,
dimension(len) mg,
dimension(len) g,
dimension(len) ground,
 gmin,
 gmax,
 nbit 
)
+
+ +

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
@@ -127,14 +211,17 @@
Author
Mark Iredell
Date
1992-10-31
-

Definition in file getbit.f.

-
+

Definition at line 32 of file getbit.f.

+ +
+ + diff --git a/getbit_8f.js b/getbit_8f.js index 40001f69..38eee7ad 100644 --- a/getbit_8f.js +++ b/getbit_8f.js @@ -1,4 +1,4 @@ var getbit_8f = [ - [ "getbit", "getbit_8f.html#a4f6601b376b03ad983fefd25058f1de9", null ] + [ "getbit", "getbit_8f.html#a4d5fdf661844c7978d879e815608d8f0", null ] ]; \ No newline at end of file diff --git a/getbit_8f_source.html b/getbit_8f_source.html index 540a9b80..0839b015 100644 --- a/getbit_8f_source.html +++ b/getbit_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getbit.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,103 +81,112 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getbit.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Compute number of bits and round field.
+
3C> @author Mark Iredell @date 1992-10-31
+
4
+
5C> The number of bits required to pack a given field.
+
6C> The field is rounded off to the decimal scaling for packing.
+
7C> The minimum and maximum rounded field values are also returned.
+
8C> For particular binary and decimal scalings is computed.
+
9C> Grib bitmap masking for valid data is optionally used.
+
10C>
+
11C> Program history log:
+
12C> - Mark Iredell 1996-09-16
+
13C>
+
14C> @param[in] IBM Integer bitmap flag (=0 for no bitmap).
+
15C> @param[in] IBS Integer binary scaling (e.g. ibs=3 to round field
+
16C> to nearest eighth value).
+
17C> @param[in] IDS Integer decimal scaling (e.g. ids=3 to round field
+
18C> to nearest milli-value) (note that ids and ibs can both be nonzero,
+
19C> e.g. ids=1 and ibs=1 rounds to the nearest twentieth).
+
20C> @param[in] LEN Integer length of the field and bitmap.
+
21C> @param[in] MG Integer (LEN) bitmap if ibm=1 (0 to skip, 1 to keep).
+
22C> @param[in] G Real (LEN) field.
+
23C> @param[out] GROUND Real (LEN) field rounded to decimal and binary scaling
+
24C> (set to zero where bitmap is 0 if ibm=1).
+
25C> @param[out] GMIN Real minimum valid rounded field value.
+
26C> @param[out] GMAX Real maximum valid rounded field value.
+
27C> @param[out] NBIT Integer number of bits to pack.
+
28C>
+
29C> @note CRAY FORTRAN
+
30C>
+
31C> @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)
+
34C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
35C 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
+
75C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
76C COMPUTE NUMBER OF BITS
+
77 nbit=log((gmax-gmin)*s+0.9)/log(2.)+1.
+
78C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
79 RETURN
+
+
80 END
+
getbit
subroutine getbit(ibm, ibs, ids, len, mg, g, ground, gmin, gmax, nbit)
The number of bits required to pack a given field.
Definition getbit.f:33
diff --git a/getgb1_8f.html b/getgb1_8f.html index 2675f34f..c2e0b65b 100644 --- a/getgb1_8f.html +++ b/getgb1_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgb1.f File Reference
+
getgb1.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine getgb1 (lugb, lugi, jf, j, jpds, jgds, grib, kf, k, kpds, kgds, lb, f, iret)
 Find and unpack a grib message.
 

Detailed Description

Find and unpacks a grib message.

@@ -107,8 +113,8 @@

Definition in file getgb1.f.

Function/Subroutine Documentation

- -

◆ getgb1()

+ +

◆ getgb1()

@@ -117,85 +123,85 @@

subroutine getgb1 (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(25)  - JPDS, + jpds, integer, dimension(*)  - JGDS, + jgds, character*1, dimension(*)  - GRIB, + grib,   - KF, + kf,   - K, + k, integer, dimension(25)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds, logical, dimension(*)  - LB, + lb, real, dimension(*)  - F, + f,   - IRET  + iret  @@ -251,7 +257,7 @@

diff --git a/getgb1_8f.js b/getgb1_8f.js index c5b2de0c..469265e3 100644 --- a/getgb1_8f.js +++ b/getgb1_8f.js @@ -1,4 +1,4 @@ var getgb1_8f = [ - [ "getgb1", "getgb1_8f.html#a124fccd25cd6967ce2b5ba8629e3707c", null ] + [ "getgb1", "getgb1_8f.html#a75aa7f2cd8878c41dc74056854b7bade", null ] ]; \ No newline at end of file diff --git a/getgb1_8f_source.html b/getgb1_8f_source.html index 494bb392..113fa219 100644 --- a/getgb1_8f_source.html +++ b/getgb1_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,207 +81,215 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgb1.f
+
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
-
gbyte
subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
This is the fortran version of gbyte.
Definition: gbyte.f:27
-
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
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find and unpacks a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Find and unpack a grib message.
+
6C> Read an associated grib index file (unless it already was read).
+
7C> Find in the index file a reference to the grib message requested.
+
8C> The grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. (A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then it is read from the
+
12C> grib file and unpacked. Its message number is returned along with
+
13C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
14C> and the unpacked data. If the grib message is not found, then the
+
15C> return code will be nonzero.
+
16C>
+
17C> Program history log:
+
18C> - Mark Iredell 1994-04-01
+
19C> - Ralph Jones 1995-05-10 Add one more parameter to getgb and
+
20C> change name to getgb1.
+
21C>
+
22C> @param[in] lugb logical unit of the unblocked grib data file.
+
23C> @param[in] lugi logical unit of the unblocked grib index file.
+
24C> @param[in] jf integer maximum number of data points to unpack.
+
25C> @param[in] j integer number of messages to skip (=0 to search from beginning)
+
26C> (<0 to reopen index file and search from beginning).
+
27C> @param[in] jpds integer (25) pds parameters for which to search
+
28C> (=-1 for wildcard) look in doc block of w3fi63 for array kpds
+
29C> for list of order of unpacked pds values.
+
30C> In most cases you only need to set 4 or 5 values to pick up record.
+
31C> @param[in] jgds integer (22) gds parameters for which to search
+
32C> (only searched if jpds(3)=255) (=-1 for wildcard).
+
33C> @param[out] grib Grib data array before it is unpacked.
+
34C> @param[out] kf Integer number of data points unpacked.
+
35C> @param[out] k Integer message number unpacked
+
36C> (can be same as j in calling program
+
37C> in order to facilitate multiple searches).
+
38C> @param[out] kpds Integer (25) unpacked pds parameters.
+
39C> @param[out] kgds Integer (22) unpacked gds parameters.
+
40C> @param[out] lb Logical (kf) unpacked bitmap if present.
+
41C> @param[out] f Real (kf) unpacked data.
+
42C> @param[out] iret Integer return code.
+
43C> - 0 All ok.
+
44C> - 96 Error reading index file.
+
45C> - 97 Error reading grib file.
+
46C> - 98 Number of data points greater than jf.
+
47C> - 99 Request not found.
+
48C> - other w3fi63 grib unpacker return code.
+
49C>
+
50C> @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)
+
53C
+
54 parameter(mbuf=8192*128)
+
55 parameter(lpds=23,lgds=22)
+
56C
+
57 INTEGER JPDS(25),JGDS(*),KPDS(25),KGDS(*)
+
58 INTEGER IPDSP(LPDS),JPDSP(LPDS),IGDSP(LGDS)
+
59 INTEGER JGDSP(LGDS)
+
60 INTEGER KPTR(20)
+
61C
+
62 LOGICAL LB(*)
+
63C
+
64 REAL F(*)
+
65C
+
66 CHARACTER CBUF(MBUF)
+
67 CHARACTER*81 CHEAD(2)
+
68 CHARACTER*1 CPDS(28)
+
69 CHARACTER*1 CGDS(42)
+
70 CHARACTER*1 GRIB(*)
+
71C
+
72C SAVE LUX,NSKP,NLEN,NNUM,CBUF
+
73 SAVE
+
74C
+
75 DATA lux/0/
+
76C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
77C READ INDEX FILE
+
78 IF(j.LT.0.OR.lugi.NE.lux) THEN
+
79C REWIND LUGI
+
80C 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
+
100C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
101C 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
+
148C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
149C 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)
+
156C BSM IF(LGRIB.LE.200+17*JF/8.AND.KGDS(2)*KGDS(3).LE.JF) THEN
+
157C 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
+
177C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
178 RETURN
+
+
179 END
+
gbyte
subroutine gbyte(ipackd, iunpkd, noff, nbits)
This is the fortran version of gbyte.
Definition gbyte.f:27
+
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
+
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
+
fi632
subroutine fi632(msga, kptr, kpds, kret)
Gather info from product definition sec.
Definition w3fi63.f:635
+
fi633
subroutine fi633(msga, kptr, kgds, kret)
Extract info from grib-gds.
Definition w3fi63.f:981
diff --git a/getgb1r_8f.html b/getgb1r_8f.html index 0f343bbb..fa127503 100644 --- a/getgb1r_8f.html +++ b/getgb1r_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1r.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgb1r.f File Reference
+
getgb1r.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine getgb1r (lugb, lskip, lgrib, kf, kpds, kgds, kens, lb, f, nbitss, iret)
 Program history log:
 

Detailed Description

Reads and unpacks a grib message.

@@ -107,8 +113,8 @@

Definition in file getgb1r.f.

Function/Subroutine Documentation

- -

◆ getgb1r()

+ +

◆ getgb1r()

@@ -117,67 +123,67 @@

subroutine getgb1r (   - LUGB, + lugb,   - LSKIP, + lskip,   - LGRIB, + lgrib,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(*)  - LB, + lb, real, dimension(*)  - F, + f,   - NBITSS, + nbitss,   - IRET  + iret  @@ -225,7 +231,7 @@

diff --git a/getgb1r_8f.js b/getgb1r_8f.js index c9c560e1..f70037fb 100644 --- a/getgb1r_8f.js +++ b/getgb1r_8f.js @@ -1,4 +1,4 @@ var getgb1r_8f = [ - [ "getgb1r", "getgb1r_8f.html#a38f437c2ae06e0aecb78f8841749a09d", null ] + [ "getgb1r", "getgb1r_8f.html#a982dff5bb7d495326427c13fc654d7bb", null ] ]; \ No newline at end of file diff --git a/getgb1r_8f_source.html b/getgb1r_8f_source.html index 19ce010c..c2c1d2b5 100644 --- a/getgb1r_8f_source.html +++ b/getgb1r_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1r.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,88 +81,96 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgb1r.f
+
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
-
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
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Reads and unpacks a grib message.
+
3C> @author Mark Iredell @date 1995-10-31
+
4
+
5C> Program history log:
+
6C> - Mark Iredell 1995-10-31
+
7C> - Chuang 2004-07-22 Add packing bit number nbitss in the argument
+
8C> list because eta grib files need it to repack grib file.
+
9C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
10C> @param[in] LSKIP Integer number of bytes to skip.
+
11C> @param[in] LGRIB Integer number of bytes to read.
+
12C> @param[out] KF Integer number of data points unpacked.
+
13C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
14C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
15C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
16C> @param[out] LB Logical*1 (kf) unpacked bitmap if present.
+
17C> @param[out] F Real (kf) unpacked data.
+
18C> @param[out] NBITSS Packaging bit number. Used by GRIB file to repack.
+
19C> @param[out] IRET Integer return code.
+
20C> - 0 All ok.
+
21C> - 97 Error reading grib file.
+
22C> - other w3fi63 grib unpacker return code.
+
23C>
+
24C> @note There is no protection against unpacking too much data.
+
25C> Subprogram can be called from a multiprocessing environment.
+
26C> Do not engage the same logical unit from more than one processor.
+
27C> This subprogram is intended for private use by getgb routines only.
+
28C>
+
29C> @author Mark Iredell @date 1995-10-31
+
30
+
31C-----------------------------------------------------------------------
+
+
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
+
39C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
40C READ GRIB RECORD
+
41 CALL baread(lugb,lskip,lgrib,lread,grib)
+
42C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
43C 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)
+
53C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
54C RETURN NUMBER OF POINTS
+
55 IF(iret.EQ.0) THEN
+
56 kf=kptr(10)
+
57 ELSE
+
58 kf=0
+
59 ENDIF
+
60C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
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
+
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
diff --git a/getgb1re_8f.html b/getgb1re_8f.html index bdc2c79b..ab15037a 100644 --- a/getgb1re_8f.html +++ b/getgb1re_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1re.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgb1re.f File Reference
+
getgb1re.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine getgb1re (lugb, lskip, lgrib, kf, kpds, kgds, kens, kprob, xprob, kclust, kmembr, lb, f, iret)
 Reads and unpacks a grib message.
 

Detailed Description

Reads and unpacks a grib message.

@@ -107,8 +113,8 @@

Definition in file getgb1re.f.

Function/Subroutine Documentation

- -

◆ getgb1re()

+ +

◆ getgb1re()

@@ -117,85 +123,85 @@

subroutine getgb1re (   - LUGB, + lugb,   - LSKIP, + lskip,   - LGRIB, + lgrib,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, integer, dimension(2)  - KPROB, + kprob, real, dimension(2)  - XPROB, + xprob, integer, dimension(16)  - KCLUST, + kclust, integer, dimension(80)  - KMEMBR, + kmembr, logical*1, dimension(*)  - LB, + lb, real, dimension(*)  - F, + f,   - IRET  + iret  @@ -245,7 +251,7 @@

diff --git a/getgb1re_8f.js b/getgb1re_8f.js index cbebc91a..93a4712d 100644 --- a/getgb1re_8f.js +++ b/getgb1re_8f.js @@ -1,4 +1,4 @@ var getgb1re_8f = [ - [ "getgb1re", "getgb1re_8f.html#a964db1a320f7b795dd353fbd292c06d7", null ] + [ "getgb1re", "getgb1re_8f.html#a58c5662f20d4a9ed1881394b25818565", null ] ]; \ No newline at end of file diff --git a/getgb1re_8f_source.html b/getgb1re_8f_source.html index 5bc50996..b916f772 100644 --- a/getgb1re_8f_source.html +++ b/getgb1re_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1re.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,93 +81,101 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgb1re.f
+
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
-
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
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Reads and unpacks a grib message.
+
3C> @author Mark Iredell @date 1995-10-31
+
4
+
5C> Reads and unpacks a grib message.
+
6C>
+
7C> PROGRAM HISTORY LOG:
+
8C> Mark Iredell 1995-10-31
+
9C> Y. Zhu 1997-02-11 Included probability and cluster arguments.
+
10C>
+
11C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
12C> @param[in] LSKIP Integer number of bytes to skip.
+
13C> @param[in] LGRIB Integer number of bytes to read.
+
14C> @param[out] KF Integer number of data points unpacked.
+
15C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
16C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
17C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
18C> @param[out] KPROB Integer (2) probability ensemble parms.
+
19C> @param[out] XPROB Real (2) probability ensemble parms.
+
20C> @param[out] KCLUST Integer (16) cluster ensemble parms.
+
21C> @param[out] KMEMBR Integer (8) cluster ensemble parms.
+
22C> @param[out] LB Logical*1 (kf) unpacked bitmap if present.
+
23C> @param[out] F Real (kf) unpacked data.
+
24C> @param[out] IRET Integer return code.
+
25C> - 0 All ok.
+
26C> - 97 Error reading grib file.
+
27C> - other w3fi63 grib unpacker return code.
+
28C>
+
29C> @note There is no protection against unpacking too much data.
+
30C> Subprogram can be called from a multiprocessing environment.
+
31C> Do not engage the same logical unit from more than one processor.
+
32C> This subprogram is intended for private use by getgb routines only.
+
33C>
+
34C> @author Mark Iredell @date 1995-10-31
+
35C-----------------------------------------------------------------------
+
+
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
+
45C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
46C READ GRIB RECORD
+
47 CALL baread(lugb,lskip,lgrib,lread,grib)
+
48C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
49C 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
+
58C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
59C RETURN NUMBER OF POINTS
+
60 IF(iret.EQ.0) THEN
+
61 kf=kptr(10)
+
62 ELSE
+
63 kf=0
+
64 ENDIF
+
65C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
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
+
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
diff --git a/getgb1s_8f.html b/getgb1s_8f.html index 99238a1b..054c025e 100644 --- a/getgb1s_8f.html +++ b/getgb1s_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1s.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgb1s.f File Reference
+
getgb1s.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine getgb1s (cbuf, nlen, nnum, j, jpds, jgds, jens, k, kpds, kgds, kens, lskip, lgrib, iret)
 Find a grib message.
 

Detailed Description

Find a grib message.

@@ -107,8 +113,8 @@

Definition in file getgb1s.f.

Function/Subroutine Documentation

- -

◆ getgb1s()

+ +

◆ getgb1s()

@@ -117,85 +123,85 @@

subroutine getgb1s ( character, dimension(nlen*nnum)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens,   - LSKIP, + lskip,   - LGRIB, + lgrib,   - IRET  + iret  @@ -248,7 +254,7 @@

diff --git a/getgb1s_8f.js b/getgb1s_8f.js index 85ccd6c5..5380e03c 100644 --- a/getgb1s_8f.js +++ b/getgb1s_8f.js @@ -1,4 +1,4 @@ var getgb1s_8f = [ - [ "getgb1s", "getgb1s_8f.html#a112566bbdfcf96f3ce3f7c5e2ba8618f", null ] + [ "getgb1s", "getgb1s_8f.html#a5005a2bc8cb1f85d4ab9d897c73e8344", null ] ]; \ No newline at end of file diff --git a/getgb1s_8f_source.html b/getgb1s_8f_source.html index f0344f6e..62338f6a 100644 --- a/getgb1s_8f_source.html +++ b/getgb1s_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb1s.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,195 +81,203 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgb1s.f
+
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
-
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
-
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
-
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
-
fi632
subroutine fi632(MSGA, KPTR, KPDS, KRET)
Gather info from product definition sec.
Definition: w3fi63.f:635
-
fi633
subroutine fi633(MSGA, KPTR, KGDS, KRET)
Extract info from grib-gds.
Definition: w3fi63.f:981
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find a grib message.
+
3C> @author Mark Iredell @date 1995-10-31
+
4
+
5C> Find a grib message.
+
6C> Find in the index file a reference to the grib message requested.
+
7C> The grib message request specifies the number of messages to skip
+
8c> and the unpacked pds and gds parameters. (A requested parameter
+
9c> of -1 means to allow any value of this parameter to be found.)
+
10C>
+
11C> Program history log:
+
12C> - Mark Iredell 1995-10-31
+
13C> - Mark Iredell 2001-06-05 Apply linux port by ebisuzaki.
+
14C>
+
15C> @param[in] CBUF Character*1 (nlen*nnum) buffer containing index data.
+
16C> @param[in] NLEN Integer length of each index record in bytes.
+
17C> @param[in] NNUM Integer number of index records.
+
18C> @param[in] J Integer number of messages to skip
+
19c> (=0 to search from beginning).
+
20C> @param[in] JPDS Integer (200) pds parameters for which to search
+
21c> (=-1 for wildcard).
+
22C> @param[in] JGDS Integer (200) gds parameters for which to search
+
23c> (only searched if jpds(3)=255) (=-1 for wildcard).
+
24C> @param[in] JENS Integer (200) ensemble pds parms for which to search
+
25c> (only searched if jpds(23)=2) (=-1 for wildcard).
+
26C> @param[out] K Integer message number found
+
27c> (can be same as j in calling program in order to facilitate multiple searches).
+
28C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
29C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
30C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
31C> @param[out] LSKIP Integer number of bytes to skip.
+
32C> @param[out] LGRIB Integer number of bytes to read.
+
33C> @param[out] IRET Integer return code.
+
34C> - 0 All ok.
+
35C> - 1 Request not found.
+
36C>
+
37C> @note Subprogram can be called from a multiprocessing environment.
+
38C> This subprogram is intended for private use by getgb routines only.
+
39C>
+
40C> @author Mark Iredell @date 1995-10-31
+
41C-----------------------------------------------------------------------
+
+
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)
+
53C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
54C COMPRESS REQUEST LISTS
+
55 k=j
+
56 lskip=0
+
57 lgrib=0
+
58 iret=1
+
59C 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
+
68C 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
+
79C 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
+
90C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
91C SEARCH FOR REQUEST
+
92 dowhile(iret.NE.0.AND.k.LT.nnum)
+
93 k=k+1
+
94 lt=0
+
95C 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
+
111C 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
+
124C 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
+
134C 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
+
165C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
166 RETURN
+
+
167 END
+
gbytec
subroutine gbytec(in, iout, iskip, nbyte)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition gbytec.f:14
+
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
+
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
+
fi632
subroutine fi632(msga, kptr, kpds, kret)
Gather info from product definition sec.
Definition w3fi63.f:635
+
fi633
subroutine fi633(msga, kptr, kgds, kret)
Extract info from grib-gds.
Definition w3fi63.f:981
diff --git a/getgb_8f.html b/getgb_8f.html index b177f326..a5476f6c 100644 --- a/getgb_8f.html +++ b/getgb_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgb.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgb.f File Reference
+
getgb.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine getgb (lugb, lugi, jf, j, jpds, jgds, kf, k, kpds, kgds, lb, f, iret)
 Find and unpack a grib message.
 

Detailed Description

Find and unpack a grib message.

@@ -107,8 +113,8 @@

Definition in file getgb.f.

Function/Subroutine Documentation

- -

◆ getgb()

+ +

◆ getgb()

@@ -117,79 +123,79 @@

subroutine getgb (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -367,7 +373,7 @@

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

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...
 
subroutine getgbe (lugb, lugi, jf, j, jpds, jgds, jens, kf, k, kpds, kgds, kens, lb, f, iret)
 Find and unpack a grib message.
 

Detailed Description

Finds and unpacks a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbe.f.

Function/Subroutine Documentation

- -

◆ getgbe()

+ +

◆ getgbe()

@@ -117,91 +123,91 @@

subroutine getgbe (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -388,7 +394,7 @@

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

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...
 
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.
 

Detailed Description

Find a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbeh.f.

Function/Subroutine Documentation

- -

◆ getgbeh()

+ +

◆ getgbeh()

@@ -117,79 +123,79 @@

subroutine getgbeh (   - LUGB, + lugb,   - LUGI, + lugi,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - KG, + kg,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens,   - IRET  + iret  @@ -371,7 +377,7 @@

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

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...
 
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.
 

Detailed Description

Find and unpack a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbem.f.

Function/Subroutine Documentation

- -

◆ getgbem()

+ +

◆ getgbem()

@@ -117,121 +123,121 @@

subroutine getgbem (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -422,7 +428,7 @@

diff --git a/getgbem_8f.js b/getgbem_8f.js index 3f7371fe..bd1a3c45 100644 --- a/getgbem_8f.js +++ b/getgbem_8f.js @@ -1,4 +1,4 @@ var getgbem_8f = [ - [ "getgbem", "getgbem_8f.html#a1b647652df8027c1858a12f78234d246", null ] + [ "getgbem", "getgbem_8f.html#a52148a120ff1d3de25afdc5e7843c3e9", null ] ]; \ No newline at end of file diff --git a/getgbem_8f_source.html b/getgbem_8f_source.html index b55f441c..5ec0f86d 100644 --- a/getgbem_8f_source.html +++ b/getgbem_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbem.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,275 +81,283 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbem.f
+
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
-
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find and unpack a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Find and unpack a grib message.
+
6C> Read a grib index file (or optionally the grib file itself)
+
7C> to get the index buffer (i.e. table of contents) for the grib file.
+
8C> Find in the index buffer a reference to the grib message requested.
+
9C> The grib message request specifies the number of messages to skip
+
10C> and the unpacked pds and gds parameters. (A requested parameter
+
11C> of -1 means to allow any value of this parameter to be found.)
+
12C> If the requested grib message is found, then it is read from the
+
13C> grib file and unpacked. Its message number is returned along with
+
14C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
15C> and the unpacked data. if the grib message is not found, then the
+
16C> return code will be nonzero.
+
17C>
+
18C> Program history log:
+
19C> - Mark Iredell 1994-04-01
+
20C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
21C> and allowed for unspecified index file.
+
22C>
+
23C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
24C> @param[in] LUGI Integer unit of the unblocked grib index file
+
25C> (=0 to get index buffer from the grib file).
+
26C> @param[in] JF Integer maximum number of data points to unpack.
+
27C> @param[in] J integer number of messages to skip
+
28C> (=0 to search from beginning)
+
29C> (<0 to read index buffer and skip -1-j messages)
+
30C> @param[in] jpds integer (200) pds parameters for which to search
+
31C> (=-1 for wildcard)
+
32C> - 1 id of center.
+
33C> - 2 generating process id number.
+
34C> - 3 grid definition.
+
35C> - 4 gds/bms flag (right adj copy of octet 8).
+
36C> - 5 indicator of parameter.
+
37C> - 6 type of level.
+
38C> - 7 height/pressure , etc of level.
+
39C> - 8 year including (century-1).
+
40C> - 9 month of year.
+
41C> - 10 day of month.
+
42C> - 11 hour of day.
+
43C> - 12 minute of hour.
+
44C> - 13 indicator of forecast time unit.
+
45C> - 14 time range 1.
+
46C> - 15 time range 2.
+
47C> - 16 time range flag.
+
48C> - 17 number included in average.
+
49C> - 18 version nr of grib specification.
+
50C> - 19 version nr of parameter table.
+
51C> - 20 nr missing from average/accumulation.
+
52C> - 21 century of reference time of data.
+
53C> - 22 units decimal scale factor.
+
54C> - 23 subcenter number.
+
55C> - 24 pds byte 29, for nmc ensemble products.
+
56C> - 128 if forecast field error.
+
57C> - 64 if bias corrected fcst field.
+
58C> - 32 if smoothed field.
+
59C> - warning: can be combination of more than 1.
+
60C> - (25) - pds byte 30, not used.
+
61C> @param[in] jgds integer (200) gds parameters for which to search
+
62C> (only searched if jpds(3)=255)
+
63C> (=-1 for wildcard).
+
64C> - 1 data representation type.
+
65C> - 19 number of vertical coordinate parameters.
+
66C> - 20 octet number of the list of vertical coordinate parameters
+
67C> or octet number of the list of numbers of points in each row or
+
68C> 255 if neither are present.
+
69C> - 21 for grids with pl, number of points in grid.
+
70C> - 22 number of words in each row.
+
71C> - Latitude/longitude grids.
+
72C> - 2 n(i) nr points on latitude circle.
+
73C> - 3 n(j) nr points on longitude meridian.
+
74C> - 4 la(1) latitude of origin.
+
75C> - 5 lo(1) longitude of origin.
+
76C> - 6 resolution flag (right adj copy of octet 17).
+
77C> - 7 la(2) latitude of extreme point.
+
78C> - 8 lo(2) longitude of extreme point.
+
79C> - 9 di longitudinal direction of increment.
+
80C> - 10 dj latitudinal direction increment.
+
81C> - 11 scanning mode flag (right adj copy of octet 28).
+
82C> - Gaussian grids.
+
83C> - 2 n(i) nr points on latitude circle.
+
84C> - 3 n(j) nr points on longitude meridian.
+
85C> - 4 la(1) latitude of origin.
+
86C> - 5 lo(1) longitude of origin.
+
87C> - 6 resolution flag (right adj copy of octet 17).
+
88C> - 7 la(2) latitude of extreme point.
+
89C> - 8 lo(2) longitude of extreme point.
+
90C> - 9 di longitudinal direction of increment.
+
91C> - 10 n: nr of circles pole to equator.
+
92C> - 11 scanning mode flag (right adj copy of octet 28).
+
93C> - 12 nv: nr of vert coord parameters.
+
94C> - 13 pv: octet nr of list of vert coord parameters or
+
95C> - pl: location of the list of numbers of points in
+
96C> each row (if no vert coord parameters are present or
+
97C> - 255 if neither are present.
+
98C> - Polar stereographic grids.
+
99C> - 2 n(i) nr points along lat circle.
+
100C> - 3 n(j) nr points along lon circle.
+
101C> - 4 la(1) latitude of origin.
+
102C> - 5 lo(1) longitude of origin.
+
103C> - 6 resolution flag (right adj copy of octet 17).
+
104C> - 7 lov grid orientation.
+
105C> - 8 dx - x direction increment.
+
106C> - 9 dy - y direction increment.
+
107C> - 10 projection center flag.
+
108C> - 11 scanning mode (right adj copy of octet 28).
+
109C> - Spherical harmonic coefficients.
+
110C> - 2 j pentagonal resolution parameter.
+
111C> - 3 k pentagonal resolution parameter.
+
112C> - 4 m pentagonal resolution parameter.
+
113C> - 5 representation type.
+
114C> - 6 coefficient storage mode.
+
115C> - Mercator grids.
+
116C> - 2 n(i) nr points on latitude circle.
+
117C> - 3 n(j) nr points on longitude meridian.
+
118C> - 4 la(1) latitude of origin.
+
119C> - 5 lo(1) longitude of origin.
+
120C> - 6 resolution flag (right adj copy of octet 17).
+
121C> - 7 la(2) latitude of last grid point.
+
122C> - 8 lo(2) longitude of last grid point.
+
123C> - 9 latit - latitude of projection intersection.
+
124C> - 10 reserved.
+
125C> - 11 scanning mode flag (right adj copy of octet 28).
+
126C> - 12 longitudinal dir grid length.
+
127C> - 13 latitudinal dir grid length.
+
128C> - Lambert conformal grids.
+
129C> - 2 nx nr points along x-axis.
+
130C> - 3 ny nr points along y-axis.
+
131C> - 4 la1 lat of origin (lower left).
+
132C> - 5 lo1 lon of origin (lower left).
+
133C> - 6 resolution (right adj copy of octet 17).
+
134C> - 7 lov - orientation of grid.
+
135C> - 8 dx - x-dir increment.
+
136C> - 9 dy - y-dir increment.
+
137C> - 10 projection center flag.
+
138C> - 11 scanning mode flag (right adj copy of octet 28).
+
139C> - 12 latin 1 - first lat from pole of secant cone inter.
+
140C> - 13 latin 2 - second lat from pole of secant cone inter.
+
141C> @param[in] jens integer (200) ensemble pds parms for which to search
+
142C> (only searched if jpds(23)=2)
+
143C> (=-1 for wildcard).
+
144C> - 1 application identifier.
+
145C> - 2 ensemble type.
+
146C> - 3 ensemble identifier.
+
147C> - 4 product identifier.
+
148C> - 5 smoothing flag.
+
149C> @param[in] mbuf integer length of index buffer in bytes.
+
150C> @param[inout] nnum integer number of index records
+
151C> (initialize by setting j=-1).
+
152C> @param[inout] mnum integer number of index records skipped
+
153C> (initialize by setting j=-1).
+
154C> @param[inout] cbuf character*1 (mbuf) index buffer
+
155C> (initialize by setting j=-1).
+
156C> @param[inout] nlen integer length of each index record in bytes.
+
157C> (initialize by setting j=-1).
+
158C> @param[out] kf integer number of data points unpacked.
+
159C> @param[out] k integer message number unpacked
+
160C> (can be same as j in calling program
+
161C> in order to facilitate multiple searches).
+
162C> @param[out] kpds integer (200) unpacked pds parameters.
+
163C> @param[out] kgds integer (200) unpacked gds parameters.
+
164C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
165C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
166C> @param[out] f real (kf) unpacked data.
+
167C> @param[out] iret integer return code.
+
168C> - 0 all ok.
+
169C> - 96 error reading index file.
+
170C> - 97 error reading grib file.
+
171C> - 98 number of data points greater than jf.
+
172C> - 99 request not found.
+
173C> - other w3fi63 grib unpacker return code.
+
174C>
+
175C> @note Specify an index file if feasible to increase speed.
+
176C> Subprogram can be called from a multiprocessing environment.
+
177C> Do not engage the same logical unit from more than one processor.
+
178C>
+
179C-----------------------------------------------------------------------
+
+
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)
+
189C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
190C 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
+
215C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
216C 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
+
232C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
233C 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
+
244C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/getgbemh_8f.html b/getgbemh_8f.html index dcf0b3cc..a90b572f 100644 --- a/getgbemh_8f.html +++ b/getgbemh_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbemh.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbemh.f File Reference
+
getgbemh.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Find a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbemh.f.

Function/Subroutine Documentation

- -

◆ getgbemh()

+ +

◆ getgbemh()

@@ -117,109 +123,109 @@

subroutine getgbemh (   - LUGB, + lugb,   - LUGI, + lugi,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KG, + kg,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens,   - IRET  + iret  @@ -408,7 +414,7 @@

diff --git a/getgbemh_8f.js b/getgbemh_8f.js index 552278f4..f3a3bde1 100644 --- a/getgbemh_8f.js +++ b/getgbemh_8f.js @@ -1,4 +1,4 @@ var getgbemh_8f = [ - [ "getgbemh", "getgbemh_8f.html#af515ecda0ec8361b15a4596b5773bd5f", null ] + [ "getgbemh", "getgbemh_8f.html#a0cfcd2b0adf1907f29efd836cee13554", null ] ]; \ No newline at end of file diff --git a/getgbemh_8f_source.html b/getgbemh_8f_source.html index 49f1ea01..91932ce7 100644 --- a/getgbemh_8f_source.html +++ b/getgbemh_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbemh.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,265 +81,273 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbemh.f
+
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
-
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Read a grib index file (or optionally the grib file itself)
+
6C> to get the index buffer (i.e. table of contents) for the grib file.
+
7C> Find in the index buffer a reference to the grib message requested.
+
8C> The grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. (A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then its message number is
+
12C> returned along with the unpacked pds and gds parameters. If the
+
13C> grib message is not found, then the return code will be nonzero.
+
14C>
+
15C> Program history log:
+
16C> - Mark Iredell 1994-04-01
+
17C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
18C> and allowed for unspecified index file
+
19C>
+
20C> @param[in] lugb integer unit of the unblocked grib data file
+
21C> (only used if lugi=0).
+
22C> @param[in] lugi integer unit of the unblocked grib index file
+
23C> (=0 to get index buffer from the grib file).
+
24C> @param[in] j integer number of messages to skip
+
25C> (=0 to search from beginning)
+
26C> (<0 to read index buffer and skip -1-j messages).
+
27C> @param[in] jpds integer (200) pds parameters for which to search.
+
28C> (=-1 for wildcard).
+
29C> - 1: id of center.
+
30C> - 2: generating process id number.
+
31C> - 3: grid definition.
+
32C> - 4: gds/bms flag (right adj copy of octet 8).
+
33C> - 5: indicator of parameter.
+
34C> - 6: type of level.
+
35C> - 7: height/pressure , etc of level.
+
36C> - 8: year including (century-1).
+
37C> - 9: month of year.
+
38C> - 10: day of month.
+
39C> - 11: hour of day.
+
40C> - 12: minute of hour.
+
41C> - 13: indicator of forecast time unit.
+
42C> - 14: time range 1.
+
43C> - 15: time range 2.
+
44C> - 16: time range flag.
+
45C> - 17: number included in average.
+
46C> - 18: version nr of grib specification.
+
47C> - 19: version nr of parameter table.
+
48C> - 20: nr missing from average/accumulation.
+
49C> - 21: century of reference time of data.
+
50C> - 22: units decimal scale factor.
+
51C> - 23: subcenter number.
+
52C> - 24: pds byte 29, for nmc ensemble products.
+
53C> - 128: if forecast field error.
+
54C> - 64: if bias corrected fcst field.
+
55C> - 32: if smoothed field.
+
56C> - warning: can be combination of more than 1.
+
57C> - 25: pds byte 30, not used.
+
58C> @param[in] jgds integer (200) gds parameters for which to search
+
59C> (only searched if jpds(3)=255)
+
60C> (=-1 for wildcard).
+
61C> - 1: data representation type.
+
62C> - 19: number of vertical coordinate parameters.
+
63C> - 20: octet number of the list of vertical coordinate parameters or.
+
64C> octet number of the list of numbers of points in each row or.
+
65C> 255 if neither are present.
+
66C> - 21: for grids with pl, number of points in grid.
+
67C> - 22: number of words in each row.
+
68C> - Latitude/longitude grids.
+
69C> - 2: n(i) nr points on latitude circle.
+
70C> - 3: n(j) nr points on longitude meridian.
+
71C> - 4: la(1) latitude of origin.
+
72C> - 5: lo(1) longitude of origin.
+
73C> - 6: resolution flag (right adj copy of octet 17).
+
74C> - 7: la(2) latitude of extreme point.
+
75C> - 8: lo(2) longitude of extreme point.
+
76C> - 9: di longitudinal direction of increment.
+
77C> - 10: dj latitudinal direction increment.
+
78C> - 11: scanning mode flag (right adj copy of octet 28).
+
79C> - Gaussian grids.
+
80C> - 2: n(i) nr points on latitude circle.
+
81C> - 3: n(j) nr points on longitude meridian.
+
82C> - 4: la(1) latitude of origin.
+
83C> - 5: lo(1) longitude of origin.
+
84C> - 6: resolution flag (right adj copy of octet 17).
+
85C> - 7: la(2) latitude of extreme point.
+
86C> - 8: lo(2) longitude of extreme point.
+
87C> - 9: di longitudinal direction of increment.
+
88C> - 10: n: nr of circles pole to equator.
+
89C> - 11: scanning mode flag (right adj copy of octet 28).
+
90C> - 12: nv: nr of vert coord parameters.
+
91C> - 13:
+
92C> - pv: octet nr of list of vert coord parameters or.
+
93C> - pl:location of the list of numbers of points in
+
94C> each row (if no vert coord parameters are present) or.
+
95C> - 255: if neither are present.
+
96C> - Polar stereographic grids.
+
97C> - 2: n(i) nr points along lat circle.
+
98C> - 3: n(j) nr points along lon circle.
+
99C> - 4: la(1) latitude of origin.
+
100C> - 5: lo(1) longitude of origin.
+
101C> - 6: resolution flag (right adj copy of octet 17).
+
102C> - 7: lov grid orientation.
+
103C> - 8: dx - x direction increment.
+
104C> - 9: dy - y direction increment.
+
105C> - 10: projection center flag.
+
106C> - 11: scanning mode (right adj copy of octet 28).
+
107C> - Spherical harmonic coefficients.
+
108C> - 2: j pentagonal resolution parameter.
+
109C> - 3: k pentagonal resolution parameter.
+
110C> - 4: m pentagonal resolution parameter.
+
111C> - 5: representation type.
+
112C> - 6: coefficient storage mode.
+
113C> - Mercator grids.
+
114C> - 2: n(i) nr points on latitude circle.
+
115C> - 3: n(j) nr points on longitude meridian.
+
116C> - 4: la(1) latitude of origin.
+
117C> - 5: lo(1) longitude of origin.
+
118C> - 6: resolution flag (right adj copy of octet 17).
+
119C> - 7: la(2) latitude of last grid point.
+
120C> - 8: lo(2) longitude of last grid point.
+
121C> - 9: latit - latitude of projection intersection.
+
122C> - 10: reserved.
+
123C> - 11: scanning mode flag (right adj copy of octet 28).
+
124C> - 12: longitudinal dir grid length.
+
125C> - 13: latitudinal dir grid length.
+
126C> - Lambert conformal grids.
+
127C> - 2: nx nr points along x-axis.
+
128C> - 3: ny nr points along y-axis.
+
129C> - 4: la1 lat of origin (lower left).
+
130C> - 5: lo1 lon of origin (lower left).
+
131C> - 6: resolution (right adj copy of octet 17).
+
132C> - 7: lov - orientation of grid.
+
133C> - 8: dx - x-dir increment.
+
134C> - 9: dy - y-dir increment.
+
135C> - 10: projection center flag.
+
136C> - 11: scanning mode flag (right adj copy of octet 28).
+
137C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139C> @param[in] jens integer (200) ensemble pds parms for which to search
+
140C> (only searched if jpds(23)=2).
+
141C> (=-1 for wildcard).
+
142C> - 1: application identifier.
+
143C> - 2: ensemble type.
+
144C> - 3: ensemble identifier.
+
145C> - 4: product identifier.
+
146C> - 5: smoothing flag.
+
147C> @param[in] mbuf integer length of index buffer in bytes.
+
148C> @param[inout] cbuf character*1 (mbuf) index buffer
+
149C> (initialize by setting j=-1).
+
150C> @param[inout] nlen integer length of each index record in bytes
+
151C> (initialize by setting j=-1).
+
152C> @param[inout] nnum integer number of index records
+
153C> (initialize by setting j=-1).
+
154C> @param[inout] mnum integer number of index records skipped
+
155C> (initialize by setting j=-1).
+
156C> @param[out] kg integer number of bytes in the grib message.
+
157C> @param[out] kf integer number of data points in the message.
+
158C> @param[out] k integer message number unpacked
+
159C> (can be same as j in calling program in order to facilitate multiple searches).
+
160C> @param[out] kpds integer (200) unpacked pds parameters.
+
161C> @param[out] kgds integer (200) unpacked gds parameters.
+
162C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
163C> @param[out] iret integer return code.
+
164C> - 0: all ok.
+
165C> - 96: error reading index file.
+
166C> - 99: request not found.
+
167C>
+
168C> @note Specify an index file if feasible to increase speed.
+
169C> Subprogram can be called from a multiprocessing environment.
+
170C> Do not engage the same logical unit from more than one processor.
+
171C>
+
172C> @author Mark Iredell @date 1994-04-01
+
173C-----------------------------------------------------------------------
+
+
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)
+
181C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
182C 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
+
207C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
208C 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
+
224C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
225C 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
+
235C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
236 RETURN
+
+
237 END
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/getgbemn_8f.html b/getgbemn_8f.html index 21a3dbe2..b830a71c 100644 --- a/getgbemn_8f.html +++ b/getgbemn_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbemn.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbemn.f File Reference
+
getgbemn.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Finds and unpacks a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbemn.f.

Function/Subroutine Documentation

- -

◆ getgbemn()

+ +

◆ getgbemn()

@@ -117,127 +123,127 @@

subroutine getgbemn (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - NBITSS, + nbitss,   - IRET  + iret  @@ -428,7 +434,7 @@

diff --git a/getgbemn_8f.js b/getgbemn_8f.js index 5d4255d1..8c452232 100644 --- a/getgbemn_8f.js +++ b/getgbemn_8f.js @@ -1,4 +1,4 @@ var getgbemn_8f = [ - [ "getgbemn", "getgbemn_8f.html#aa8900c58b55dacd248734fa3e97c1482", null ] + [ "getgbemn", "getgbemn_8f.html#aac1e0617524cfcef1651f92133f0c959", null ] ]; \ No newline at end of file diff --git a/getgbemn_8f_source.html b/getgbemn_8f_source.html index 2bf1afbb..ada45975 100644 --- a/getgbemn_8f_source.html +++ b/getgbemn_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbemn.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,278 +81,286 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbemn.f
+
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
-
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+Go to the documentation of this file.
1C> @file
+
2C> @brief Finds and unpacks a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Find and unpack a grib message.
+
6C> Read a grib index file (or optionally the grib file itself)
+
7C> to get the index buffer (i.e. table of contents) for the grib file.
+
8C> Find in the index buffer a reference to the grib message requested.
+
9C> The grib message request specifies the number of messages to skip
+
10C> and the unpacked pds and gds parameters. (A requested parameter
+
11C> of -1 means to allow any value of this parameter to be found.)
+
12C> If the requested grib message is found, then it is read from the
+
13C> grib file and unpacked. Its message number is returned along with
+
14C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
15C> and the unpacked data. If the grib message is not found, then the
+
16C> return code will be nonzero.
+
17C>
+
18C> Program history log:
+
19C> - Mark Iredell 1994-04-01
+
20C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
21C> and allowed for unspecified index file
+
22C> - Chuang 2004-07-22 add packing bit number nbitss in the argument
+
23C> list because eta grib files need it to repack grib file
+
24C>
+
25C> @param[in] lugb integer unit of the unblocked grib data file.
+
26C> @param[in] lugi integer unit of the unblocked grib index file
+
27C> (=0 to get index buffer from the grib file).
+
28C> @param[in] jf integer maximum number of data points to unpack.
+
29C> @param[in] j integer number of messages to skip
+
30C> (=0 to search from beginning)
+
31C> (<0 to read index buffer and skip -1-j messages).
+
32C> @param[in] jpds integer (200) pds parameters for which to search
+
33C> (=-1 for wildcard).
+
34C> - 1: id of center.
+
35C> - 2: generating process id number.
+
36C> - 3: grid definition.
+
37C> - 4: gds/bms flag (right adj copy of octet 8).
+
38C> - 5: indicator of parameter.
+
39C> - 6: type of level.
+
40C> - 7: height/pressure , etc of level.
+
41C> - 8: year including (century-1).
+
42C> - 9: month of year.
+
43C> - 10: day of month.
+
44C> - 11: hour of day.
+
45C> - 12: minute of hour.
+
46C> - 13: indicator of forecast time unit.
+
47C> - 14: time range 1.
+
48C> - 15: time range 2.
+
49C> - 16: time range flag.
+
50C> - 17: number included in average.
+
51C> - 18: version nr of grib specification.
+
52C> - 19: version nr of parameter table.
+
53C> - 20: nr missing from average/accumulation.
+
54C> - 21: century of reference time of data.
+
55C> - 22: units decimal scale factor.
+
56C> - 23: subcenter number.
+
57C> - 24: pds byte 29, for nmc ensemble products.
+
58C> - 128 if forecast field error.
+
59C> - 64 if bias corrected fcst field.
+
60C> - 32 if smoothed field.
+
61C> - Warning: can be combination of more than 1.
+
62C> - 25: pds byte 30, not used.
+
63C> @param[in] jgds integer (200) gds parameters for which to search
+
64C> (only searched if jpds(3)=255)
+
65C> (=-1 for wildcard).
+
66C> - 1: data representation type.
+
67C> - 19: number of vertical coordinate parameters.
+
68C> - 20: octet number of the list of vertical coordinate parameters or
+
69C> octet number of the list of numbers of points in each row or
+
70C> 255 if neither are present.
+
71C> - 21: for grids with pl, number of points in grid.
+
72C> - 22: number of words in each row.
+
73C> - Latitude/longitude grids.
+
74C> - 2: n(i) nr points on latitude circle.
+
75C> - 3: n(j) nr points on longitude meridian.
+
76C> - 4: la(1) latitude of origin.
+
77C> - 5: lo(1) longitude of origin.
+
78C> - 6: resolution flag (right adj copy of octet 17).
+
79C> - 7: la(2) latitude of extreme point.
+
80C> - 8: lo(2) longitude of extreme point.
+
81C> - 9: di longitudinal direction of increment.
+
82C> - 10: dj latitudinal direction increment.
+
83C> - 11: scanning mode flag (right adj copy of octet 28).
+
84C> - Gaussian grids.
+
85C> - 2: n(i) nr points on latitude circle.
+
86C> - 3: n(j) nr points on longitude meridian.
+
87C> - 4: la(1) latitude of origin.
+
88C> - 5: lo(1) longitude of origin.
+
89C> - 6: resolution flag (right adj copy of octet 17).
+
90C> - 7: la(2) latitude of extreme point.
+
91C> - 8: lo(2) longitude of extreme point.
+
92C> - 9: di longitudinal direction of increment.
+
93C> - 10: n - nr of circles pole to equator.
+
94C> - 11: scanning mode flag (right adj copy of octet 28).
+
95C> - 12: nv - nr of vert coord parameters.
+
96C> - 13: pv - octet nr of list of vert coord parameters or
+
97C> pl - location of the list of numbers of points in each row
+
98C> (if no vert coord parameters are present) or 255 if neither are present
+
99C> - Polar stereographic grids.
+
100C> - 2: n(i) nr points along lat circle.
+
101C> - 3: n(j) nr points along lon circle.
+
102C> - 4: la(1) latitude of origin.
+
103C> - 5: lo(1) longitude of origin.
+
104C> - 6: resolution flag (right adj copy of octet 17).
+
105C> - 7: lov grid orientation.
+
106C> - 8: dx - x direction increment.
+
107C> - 9: dy - y direction increment.
+
108C> - 10: projection center flag.
+
109C> - 11: scanning mode (right adj copy of octet 28).
+
110C> - Spherical harmonic coefficients.
+
111C> - 2: j pentagonal resolution parameter.
+
112C> - 3: k pentagonal resolution parameter.
+
113C> - 4: m pentagonal resolution parameter.
+
114C> - 5: representation type.
+
115C> - 6: coefficient storage mode.
+
116C> - Mercator grids.
+
117C> - 2: n(i) nr points on latitude circle.
+
118C> - 3: n(j) nr points on longitude meridian.
+
119C> - 4: la(1) latitude of origin.
+
120C> - 5: lo(1) longitude of origin.
+
121C> - 6: resolution flag (right adj copy of octet 17).
+
122C> - 7: la(2) latitude of last grid point.
+
123C> - 8: lo(2) longitude of last grid point.
+
124C> - 9: latit - latitude of projection intersection.
+
125C> - 10: reserved.
+
126C> - 11: scanning mode flag (right adj copy of octet 28).
+
127C> - 12: longitudinal dir grid length.
+
128C> - 13: latitudinal dir grid length.
+
129C> - Lambert conformal grids.
+
130C> - 2: nx nr points along x-axis.
+
131C> - 3: ny nr points along y-axis.
+
132C> - 4: la1 lat of origin (lower left).
+
133C> - 5: lo1 lon of origin (lower left).
+
134C> - 6: resolution (right adj copy of octet 17).
+
135C> - 7: lov - orientation of grid.
+
136C> - 8: dx - x-dir increment.
+
137C> - 9: dy - y-dir increment.
+
138C> - 10: projection center flag.
+
139C> - 11: scanning mode flag (right adj copy of octet 28).
+
140C> - 12: latin 1 - first lat from pole of secant cone inter.
+
141C> - 13: latin 2 - second lat from pole of secant cone inter.
+
142C> @param[in] jens integer (200) ensemble pds parms for which to search
+
143C> (only searched if jpds(23)=2)
+
144C> (=-1 for wildcard).
+
145C> - 1: application identifier.
+
146C> - 2: ensemble type.
+
147C> - 3: ensemble identifier.
+
148C> - 4: product identifier.
+
149C> - 5: smoothing flag.
+
150C> @param[in] mbuf integer length of index buffer in bytes.
+
151C> @param[in] nbitss integer.
+
152C> @param[inout] cbuf character*1 (mbuf) index buffer
+
153C> (initialize by setting j=-1).
+
154C> @param[inout] nlen integer length of each index record in bytes
+
155C> (initialize by setting j=-1).
+
156C> @param[inout] nnum integer number of index records
+
157C> (initialize by setting j=-1).
+
158C> @param[inout] mnum integer number of index records skipped
+
159C> (initialize by setting j=-1).
+
160C> @param[out] kf integer number of data points unpacked.
+
161C> @param[out] k integer message number unpacked
+
162C> (can be same as j in calling program
+
163C> in order to facilitate multiple searches).
+
164C> @param[out] kpds integer (200) unpacked pds parameters.
+
165C> @param[out] kgds integer (200) unpacked gds parameters.
+
166C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
167C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
168C> @param[out] f real (kf) unpacked data.
+
169C> @param[out] iret integer return code.
+
170C> - 0 all ok.
+
171C> - 96 error reading index file.
+
172C> - 97 error reading grib file.
+
173C> - 98 number of data points greater than jf.
+
174C> - 99 request not found.
+
175C> - other w3fi63 grib unpacker return code.
+
176C>
+
177C> @note Specify an index file if feasible to increase speed.
+
178C> Subprogram can be called from a multiprocessing environment.
+
179C> Do not engage the same logical unit from more than one processor.
+
180C>
+
181C> @author Mark Iredell @date 1994-04-01
+
182C-----------------------------------------------------------------------
+
+
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)
+
192C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
193C 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
+
218C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
219C 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
+
235C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
236C 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
+
247C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/getgbemp_8f.html b/getgbemp_8f.html index f2860090..9a10c66d 100644 --- a/getgbemp_8f.html +++ b/getgbemp_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbemp.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbemp.f File Reference
+
getgbemp.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Find a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbemp.f.

Function/Subroutine Documentation

- -

◆ getgbemp()

+ +

◆ getgbemp()

@@ -117,115 +123,115 @@

subroutine getgbemp (   - LUGB, + lugb,   - LUGI, + lugi,   - JG, + jg,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KG, + kg,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, character, dimension(jg)  - G, + g,   - IRET  + iret  @@ -416,7 +422,7 @@

diff --git a/getgbemp_8f.js b/getgbemp_8f.js index b763637c..8e947e9a 100644 --- a/getgbemp_8f.js +++ b/getgbemp_8f.js @@ -1,4 +1,4 @@ var getgbemp_8f = [ - [ "getgbemp", "getgbemp_8f.html#a3703b88e4d6f0e0dc3a8643d7662137c", null ] + [ "getgbemp", "getgbemp_8f.html#a6f58776aeb1ed2f7e367bf4a01a1ad35", null ] ]; \ No newline at end of file diff --git a/getgbemp_8f_source.html b/getgbemp_8f_source.html index 8c12302d..31ecc00f 100644 --- a/getgbemp_8f_source.html +++ b/getgbemp_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbemp.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,270 +81,278 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbemp.f
+
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Read a grib index file (or optionally the grib file itself)
+
6C> to get the index buffer (i.e. table of contents) for the grib file.
+
7C> Find in the index buffer a reference to the grib message requested.
+
8C> the grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. (A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then it is read from the
+
12C> grib file. Its message number is returned along with the unpacked
+
13C> pds and gds parameters and the packed grib message. If the grib
+
14C> message is not found, then the return code will be nonzero.
+
15C>
+
16C> Program history log:
+
17C> - Mark Iredell 1994-04-01
+
18C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
19C> and allowed for unspecified index file.
+
20C>
+
21C> @param[in] lugb integer unit of the unblocked grib data file.
+
22C> @param[in] lugi integer unit of the unblocked grib index file
+
23C> (=0 to get index buffer from the grib file).
+
24C> @param[in] jg integer maximum number of bytes in the grib message.
+
25C> @param[in] j integer number of messages to skip
+
26C> (=0 to search from beginning)
+
27C> (<0 to read index buffer and skip -1-j messages).
+
28C> @param[in] jpds integer (200) pds parameters for which to search
+
29C> (=-1 for wildcard).
+
30C> - 1: id of center.
+
31C> - 2: generating process id number.
+
32C> - 3: grid definition.
+
33C> - 4: gds/bms flag (right adj copy of octet 8).
+
34C> - 5: indicator of parameter.
+
35C> - 6: type of level.
+
36C> - 7: height/pressure , etc of level.
+
37C> - 8: year including (century-1).
+
38C> - 9: month of year.
+
39C> - 10: day of month.
+
40C> - 11: hour of day.
+
41C> - 12: minute of hour.
+
42C> - 13: indicator of forecast time unit.
+
43C> - 14: time range 1.
+
44C> - 15: time range 2.
+
45C> - 16: time range flag.
+
46C> - 17: number included in average.
+
47C> - 18: version nr of grib specification.
+
48C> - 19: version nr of parameter table.
+
49C> - 20: nr missing from average/accumulation.
+
50C> - 21: century of reference time of data.
+
51C> - 22: units decimal scale factor.
+
52C> - 23: subcenter number.
+
53C> - 24: pds byte 29, for nmc ensemble products.
+
54C> - 128 if forecast field error.
+
55C> - 64 if bias corrected fcst field.
+
56C> - 32 if smoothed field.
+
57C> - warning: can be combination of more than 1.
+
58C> - 25: pds byte 30, not used.
+
59C> @param[in] jgds integer (200) gds parameters for which to search
+
60C> (only searched if jpds(3)=255)
+
61C> (=-1 for wildcard).
+
62C> - 1: data representation type.
+
63C> - 19: number of vertical coordinate parameters.
+
64C> - 20: octet number of the list of vertical coordinate parameters or
+
65C> octet number of the list of numbers of points in each row or
+
66C> 255 if neither are present.
+
67C> - 21: for grids with pl, number of points in grid.
+
68C> - 22: number of words in each row.
+
69C> - Latitude/longitude grids.
+
70C> - 2: n(i) nr points on latitude circle.
+
71C> - 3: n(j) nr points on longitude meridian.
+
72C> - 4: la(1) latitude of origin.
+
73C> - 5: lo(1) longitude of origin.
+
74C> - 6: resolution flag (right adj copy of octet 17).
+
75C> - 7: la(2) latitude of extreme point.
+
76C> - 8: lo(2) longitude of extreme point.
+
77C> - 9: di longitudinal direction of increment.
+
78C> - 10: dj latitudinal direction increment.
+
79C> - 11: scanning mode flag (right adj copy of octet 28).
+
80C> - Gaussian grids.
+
81C> - 2: n(i) nr points on latitude circle.
+
82C> - 3: n(j) nr points on longitude meridian.
+
83C> - 4: la(1) latitude of origin.
+
84C> - 5: lo(1) longitude of origin.
+
85C> - 6: resolution flag (right adj copy of octet 17).
+
86C> - 7: la(2) latitude of extreme point.
+
87C> - 8: lo(2) longitude of extreme point.
+
88C> - 9: di longitudinal direction of increment.
+
89C> - 10: n - nr of circles pole to equator.
+
90C> - 11: scanning mode flag (right adj copy of octet 28).
+
91C> - 12: nv - nr of vert coord parameters.
+
92C> - 13: pv - octet nr of list of vert coord parameters or.
+
93C> - pl - location of the list of numbers of points in each row
+
94C> (if no vert coord parameters are present) or
+
95C> - 255 if neither are present.
+
96C> - Polar stereographic grids.
+
97C> - 2: n(i) nr points along lat circle.
+
98C> - 3: n(j) nr points along lon circle.
+
99C> - 4: la(1) latitude of origin.
+
100C> - 5: lo(1) longitude of origin.
+
101C> - 6: resolution flag (right adj copy of octet 17).
+
102C> - 7: lov grid orientation.
+
103C> - 8: dx - x direction increment.
+
104C> - 9: dy - y direction increment.
+
105C> - 10: projection center flag.
+
106C> - 11: scanning mode (right adj copy of octet 28).
+
107C> - Spherical harmonic coefficients.
+
108C> - 2: j pentagonal resolution parameter.
+
109C> - 3: k pentagonal resolution parameter.
+
110C> - 4: m pentagonal resolution parameter.
+
111C> - 5: representation type.
+
112C> - 6: coefficient storage mode.
+
113C> - Mercator grids.
+
114C> - 2: n(i) nr points on latitude circle.
+
115C> - 3: n(j) nr points on longitude meridian.
+
116C> - 4: la(1) latitude of origin.
+
117C> - 5: lo(1) longitude of origin.
+
118C> - 6: resolution flag (right adj copy of octet 17).
+
119C> - 7: la(2) latitude of last grid point.
+
120C> - 8: lo(2) longitude of last grid point.
+
121C> - 9: latit - latitude of projection intersection.
+
122C> - 10: reserved.
+
123C> - 11: scanning mode flag (right adj copy of octet 28).
+
124C> - 12: longitudinal dir grid length.
+
125C> - 13: latitudinal dir grid length.
+
126C> - Lambert conformal grids.
+
127C> - 2: nx nr points along x-axis.
+
128C> - 3: ny nr points along y-axis.
+
129C> - 4: la1 lat of origin (lower left).
+
130C> - 5: lo1 lon of origin (lower left).
+
131C> - 6: resolution (right adj copy of octet 17).
+
132C> - 7: lov - orientation of grid.
+
133C> - 8: dx - x-dir increment.
+
134C> - 9: dy - y-dir increment.
+
135C> - 10: projection center flag.
+
136C> - 11: scanning mode flag (right adj copy of octet 28).
+
137C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139C> @param[in] jens integer (200) ensemble pds parms for which to search
+
140C> (only searched if jpds(23)=2)
+
141C> (=-1 for wildcard).
+
142C> - 1: application identifier.
+
143C> - 2: ensemble type.
+
144C> - 3: ensemble identifier.
+
145C> - 4: product identifier.
+
146C> - 5: smoothing flag.
+
147C> @param[in] mbuf integer length of index buffer in bytes.
+
148C> @param[inout] cbuf character*1 (mbuf) index buffer
+
149C> (initialize by setting j=-1).
+
150C> @param[inout] nlen integer length of each index record in bytes
+
151C> (initialize by setting j=-1).
+
152C> @param[inout] nnum integer number of index records
+
153C> (initialize by setting j=-1).
+
154C> @param[inout] mnum integer number of index records skipped
+
155C> (initialize by setting j=-1).
+
156C> @param[out] kg integer number of bytes in the grib message.
+
157C> @param[out] k integer message number unpacked
+
158C> (can be same as j in calling program
+
159C> in order to facilitate multiple searches).
+
160C> @param[out] kpds integer (200) unpacked pds parameters.
+
161C> @param[out] kgds integer (200) unpacked gds parameters.
+
162C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
163C> @param[out] g character*1 (kg) grib message.
+
164C> @param[out] iret integer return code.
+
165C> - 0: all ok.
+
166C> - 96: error reading index file.
+
167C> - 97: error reading grib file.
+
168C> - 98: number of bytes greater than jg.
+
169C> - 99: request not found.
+
170C>
+
171C> @note Specify an index file if feasible to increase speed.
+
172C> Subprogram can be called from a multiprocessing environment.
+
173C> Do not engage the same logical unit from more than one processor.
+
174C>
+
175C> @author Mark Iredell @date 1994-04-01
+
176C-----------------------------------------------------------------------
+
+
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)
+
185C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
186C 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
+
211C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
212C 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
+
228C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
229C 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
+
241C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
242 RETURN
+
+
243 END
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
diff --git a/getgbens_8f.html b/getgbens_8f.html index da674c9d..0da0dea2 100644 --- a/getgbens_8f.html +++ b/getgbens_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbens.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbens.f File Reference
+
getgbens.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Find and unpack a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbens.f.

Function/Subroutine Documentation

- -

◆ getgbens()

+ +

◆ getgbens()

@@ -117,91 +123,91 @@

subroutine getgbens (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -388,7 +394,7 @@

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

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...
 
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.
 

Detailed Description

Find a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbep.f.

Function/Subroutine Documentation

- -

◆ getgbep()

+ +

◆ getgbep()

@@ -117,85 +123,85 @@

subroutine getgbep (   - LUGB, + lugb,   - LUGI, + lugi,   - JG, + jg,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - KG, + kg,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, character, dimension(jg)  - G, + g,   - IRET  + iret  @@ -378,7 +384,7 @@

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

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...
 
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.
 

Detailed Description

Find and unpack a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbex.f.

Function/Subroutine Documentation

- -

◆ getgbex()

+ +

◆ getgbex()

@@ -117,115 +123,115 @@

subroutine getgbex (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, integer, dimension(2)  - KPROB, + kprob, real, dimension(2)  - XPROB, + xprob, integer, dimension(16)  - KCLUST, + kclust, integer, dimension(80)  - KMEMBR, + kmembr, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -419,7 +425,7 @@

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

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...
 
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.
 

Detailed Description

Find and unpack a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbexm.f.

Function/Subroutine Documentation

- -

◆ getgbexm()

+ +

◆ getgbexm()

@@ -117,145 +123,145 @@

subroutine getgbexm (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds, integer, dimension(200)  - JENS, + jens,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, integer, dimension(2)  - KPROB, + kprob, real, dimension(2)  - XPROB, + xprob, integer, dimension(16)  - KCLUST, + kclust, integer, dimension(80)  - KMEMBR, + kmembr, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -452,7 +458,7 @@

diff --git a/getgbexm_8f.js b/getgbexm_8f.js index 0d45eeec..1ed66ea1 100644 --- a/getgbexm_8f.js +++ b/getgbexm_8f.js @@ -1,4 +1,4 @@ var getgbexm_8f = [ - [ "getgbexm", "getgbexm_8f.html#ab15467040c53a0346d4857a0496c4762", null ] + [ "getgbexm", "getgbexm_8f.html#a660f20529705ee3731e6544771eedf4d", null ] ]; \ No newline at end of file diff --git a/getgbexm_8f_source.html b/getgbexm_8f_source.html index 3a4fa999..addc29e4 100644 --- a/getgbexm_8f_source.html +++ b/getgbexm_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbexm.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,282 +81,290 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbexm.f
+
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
-
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
-
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
-
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find and unpack a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Read a grib index file (or optionally the grib file itself)
+
6C> to get the index buffer (i.e. table of contents) for the grib file.
+
7C> Find in the index buffer a reference to the grib message requested.
+
8C> The grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. (A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then it is read from the
+
12C> grib file and unpacked. Its message number is returned along with
+
13C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
14C> and the unpacked data. If the grib message is not found, then the
+
15C> return code will be nonzero.
+
16C>
+
17C> Program history log:
+
18C> - Mark Iredell 1994-04-01
+
19C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
20C> and allowed for unspecified index file.
+
21C> - Y. Zhu 1997-02-11 Included probability and cluster arguments.
+
22C>
+
23C> @param[in] lugb integer unit of the unblocked grib data file.
+
24C> @param[in] lugi integer unit of the unblocked grib index file
+
25C> (=0 to get index buffer from the grib file).
+
26C> @param[in] jf integer maximum number of data points to unpack.
+
27C> @param[in] j integer number of messages to skip
+
28C> (=0 to search from beginning)
+
29C> (<0 to read index buffer and skip -1-j messages).
+
30C> @param[in] jpds integer (200) pds parameters for which to search
+
31C> (=-1 for wildcard).
+
32C> - 1): id of center.
+
33C> - 2): generating process id number.
+
34C> - 3): grid definition.
+
35C> - 4): gds/bms flag (right adj copy of octet 8).
+
36C> - 5): indicator of parameter.
+
37C> - 6): type of level.
+
38C> - 7): height/pressure , etc of level.
+
39C> - 8): year including (century-1).
+
40C> - 9): month of year.
+
41C> - 10: day of month.
+
42C> - 11: hour of day.
+
43C> - 12: minute of hour.
+
44C> - 13: indicator of forecast time unit.
+
45C> - 14: time range 1.
+
46C> - 15: time range 2.
+
47C> - 16: time range flag.
+
48C> - 17: number included in average.
+
49C> - 18: version nr of grib specification.
+
50C> - 19: version nr of parameter table.
+
51C> - 20: nr missing from average/accumulation.
+
52C> - 21: century of reference time of data.
+
53C> - 22: units decimal scale factor.
+
54C> - 23: subcenter number.
+
55C> - 24: pds byte 29, for nmc ensemble products.
+
56C> - 128 if forecast field error.
+
57C> - 64 if bias corrected fcst field.
+
58C> - 32 if smoothed field.
+
59C> - warning: can be combination of more than 1.
+
60C> - 25: pds byte 30, not used.
+
61C> @param[in] jgds integer (200) gds parameters for which to search
+
62C> (only searched if jpds(3)=255)
+
63C> (=-1 for wildcard).
+
64C> - 1): data representation type.
+
65C> - 19: number of vertical coordinate parameters.
+
66C> - 20: octet number of the list of vertical coordinate parameters or.
+
67C> octet number of the list of numbers of points in each row or.
+
68C> 255 if neither are present.
+
69C> - 21: for grids with pl, number of points in grid.
+
70C> - 22: number of words in each row.
+
71C> - Latitude/longitude grids.
+
72C> - 2: n(i) nr points on latitude circle.
+
73C> - 3: n(j) nr points on longitude meridian.
+
74C> - 4: la(1) latitude of origin.
+
75C> - 5: lo(1) longitude of origin.
+
76C> - 6: resolution flag (right adj copy of octet 17).
+
77C> - 7: la(2) latitude of extreme point.
+
78C> - 8: lo(2) longitude of extreme point.
+
79C> - 9: di longitudinal direction of increment.
+
80C> - 10: dj latitudinal direction increment.
+
81C> - 11: scanning mode flag (right adj copy of octet 28).
+
82C> - Gaussian grids.
+
83C> - 2: n(i) nr points on latitude circle.
+
84C> - 3: n(j) nr points on longitude meridian.
+
85C> - 4: la(1) latitude of origin.
+
86C> - 5: lo(1) longitude of origin.
+
87C> - 6: resolution flag (right adj copy of octet 17).
+
88C> - 7: la(2) latitude of extreme point.
+
89C> - 8: lo(2) longitude of extreme point.
+
90C> - 9: di longitudinal direction of increment.
+
91C> - 10: n - nr of circles pole to equator.
+
92C> - 11: scanning mode flag (right adj copy of octet 28).
+
93C> - 12: nv - nr of vert coord parameters.
+
94C> - 13: pv - octet nr of list of vert coord parameters or.
+
95C> - pl - location of the list of numbers of points in each row
+
96C> (if no vert coord parameters are present) or 255 if neither are present.
+
97C> - Polar stereographic grids.
+
98C> - 2: n(i) nr points along lat circle.
+
99C> - 3: n(j) nr points along lon circle.
+
100C> - 4: la(1) latitude of origin.
+
101C> - 5: lo(1) longitude of origin.
+
102C> - 6: resolution flag (right adj copy of octet 17).
+
103C> - 7: lov grid orientation.
+
104C> - 8: dx - x direction increment.
+
105C> - 9: dy - y direction increment.
+
106C> - 10: projection center flag.
+
107C> - 11: scanning mode (right adj copy of octet 28).
+
108C> - Spherical harmonic coefficients.
+
109C> - 2: j pentagonal resolution parameter.
+
110C> - 3: k pentagonal resolution parameter.
+
111C> - 4: m pentagonal resolution parameter.
+
112C> - 5: representation type.
+
113C> - 6: coefficient storage mode.
+
114C> - Mercator grids.
+
115C> - 2: n(i) nr points on latitude circle.
+
116C> - 3: n(j) nr points on longitude meridian.
+
117C> - 4: la(1) latitude of origin.
+
118C> - 5: lo(1) longitude of origin.
+
119C> - 6: resolution flag (right adj copy of octet 17).
+
120C> - 7: la(2) latitude of last grid point.
+
121C> - 8: lo(2) longitude of last grid point.
+
122C> - 9: latit - latitude of projection intersection.
+
123C> - 10: reserved.
+
124C> - 11: scanning mode flag (right adj copy of octet 28).
+
125C> - 12: longitudinal dir grid length.
+
126C> - 13: latitudinal dir grid length.
+
127C> - Lambert conformal grids.
+
128C> - 2: nx nr points along x-axis.
+
129C> - 3: ny nr points along y-axis.
+
130C> - 4: la1 lat of origin (lower left).
+
131C> - 5: lo1 lon of origin (lower left).
+
132C> - 6: resolution (right adj copy of octet 17).
+
133C> - 7: lov - orientation of grid.
+
134C> - 8: dx - x-dir increment.
+
135C> - 9: dy - y-dir increment.
+
136C> - 10: projection center flag.
+
137C> - 11: scanning mode flag (right adj copy of octet 28).
+
138C> - 12: latin 1 - first lat from pole of secant cone inter.
+
139C> - 13: latin 2 - second lat from pole of secant cone inter.
+
140C> @param[in] jens integer (200) ensemble pds parms for which to search
+
141C> (only searched if jpds(23)=2)
+
142C> (=-1 for wildcard).
+
143C> - 1: application identifier.
+
144C> - 2: ensemble type.
+
145C> - 3: ensemble identifier.
+
146C> - 4: product identifier.
+
147C> - 5: smoothing flag.
+
148C> @param[in] mbuf integer length of index buffer in bytes.
+
149C> @param[inout] cbuf character*1 (mbuf) index buffer
+
150C> (initialize by setting j=-1).
+
151C> @param[inout] nlen integer length of each index record in bytes
+
152C> (initialize by setting j=-1).
+
153C> @param[inout] nnum integer number of index records
+
154C> (initialize by setting j=-1).
+
155C> @param[inout] mnum integer number of index records skipped
+
156C> (initialize by setting j=-1).
+
157C> @param[out] kf integer number of data points unpacked.
+
158C> @param[out] k integer message number unpacked
+
159C> (can be same as j in calling program
+
160C> in order to facilitate multiple searches).
+
161C> @param[out] kpds integer (200) unpacked pds parameters.
+
162C> @param[out] kgds integer (200) unpacked gds parameters.
+
163C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
164C> @param[out] kprob integer (2) probability ensemble parms.
+
165C> @param[out] xprob real (2) probability ensemble parms.
+
166C> @param[out] kclust integer (16) cluster ensemble parms.
+
167C> @param[out] kmembr integer (8) cluster ensemble parms.
+
168C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
169C> @param[out] f real (kf) unpacked data.
+
170C> @param[out] iret integer return code.
+
171C> - 0 all ok.
+
172C> - 96 error reading index file.
+
173C> - 97 error reading grib file.
+
174C> - 98 number of data points greater than jf.
+
175C> - 99 request not found.
+
176C> - other w3fi63 grib unpacker return code.
+
177C>
+
178C> @note Specify an index file if feasible to increase speed.
+
179C> Subprogram can be called from a multiprocessing environment.
+
180C> Do not engage the same logical unit from more than one processor.
+
181C>
+
182C> @author Mark Iredell @date 1994-04-01
+
183C-----------------------------------------------------------------------
+
+
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)
+
196C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
197C 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
+
222C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
223C 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
+
239C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
240C 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
+
251C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
252 RETURN
+
+
253 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
+
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
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/getgbh_8f.html b/getgbh_8f.html index 0a2731e6..48221964 100644 --- a/getgbh_8f.html +++ b/getgbh_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbh.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbh.f File Reference
+
getgbh.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Find a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbh.f.

Function/Subroutine Documentation

- -

◆ getgbh()

+ +

◆ getgbh()

@@ -117,67 +123,67 @@

subroutine getgbh (   - LUGB, + lugb,   - LUGI, + lugi,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds,   - KG, + kg,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds,   - IRET  + iret  @@ -345,7 +351,7 @@

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

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...
 
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.
 

Detailed Description

Find and unpack a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbm.f.

Function/Subroutine Documentation

- -

◆ getgbm()

+ +

◆ getgbm()

@@ -117,109 +123,109 @@

subroutine getgbm (   - LUGB, + lugb,   - LUGI, + lugi,   - JF, + jf,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, logical*1, dimension(jf)  - LB, + lb, real, dimension(jf)  - F, + f,   - IRET  + iret  @@ -401,7 +407,7 @@

diff --git a/getgbm_8f.js b/getgbm_8f.js index 2f08c7b7..df9ac18b 100644 --- a/getgbm_8f.js +++ b/getgbm_8f.js @@ -1,4 +1,4 @@ var getgbm_8f = [ - [ "getgbm", "getgbm_8f.html#ac004e0201adb9928c5fada5c7372fd78", null ] + [ "getgbm", "getgbm_8f.html#a13e5b7b94989de452f47d062a917e8f9", null ] ]; \ No newline at end of file diff --git a/getgbm_8f_source.html b/getgbm_8f_source.html index e8d575c9..7737ec4a 100644 --- a/getgbm_8f_source.html +++ b/getgbm_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbm.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,270 +81,278 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbm.f
+
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
-
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
-
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+Go to the documentation of this file.
1C> @file
+
2C> @brief Find and unpack a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Read a grib index file (or optionally the grib file itself)
+
6C> to get the index buffer (i.e. table of contents) for the grib file.
+
7C> Find in the index buffer a reference to the grib message requested.
+
8C> The grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then it is read from the
+
12C> grib file and unpacked. Its message number is returned along with
+
13C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
14C> and the unpacked data. If the grib message is not found, then the
+
15C> return code will be nonzero.
+
16C>
+
17C> Program history log:
+
18C> - Mark Iredell 1994-04-01
+
19C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
20C> and allowed for unspecified index file.
+
21C> - Chuang 2004-07-22 Add nbitss to the argument list of getgb1r that
+
22C> is called in this subroutine.
+
23C> - Wang 2010-03-02 wang Increase msk1 to 256000000 for nemsio files.
+
24C>
+
25C> @param[in] lugb integer unit of the unblocked grib data file.
+
26C> @param[in] lugi integer unit of the unblocked grib index file
+
27C> (=0 to get index buffer from the grib file).
+
28C> @param[in] jf integer maximum number of data points to unpack.
+
29C> @param[in] j integer number of messages to skip
+
30C> (=0 to search from beginning)
+
31C> (<0 to read index buffer and skip -1-j messages).
+
32C> @param[in] jpds integer (200) pds parameters for which to search
+
33C> (=-1 for wildcard).
+
34C> - 1: id of center.
+
35C> - 2: generating process id number.
+
36C> - 3: grid definition.
+
37C> - 4: gds/bms flag (right adj copy of octet 8).
+
38C> - 5: indicator of parameter.
+
39C> - 6: type of level.
+
40C> - 7: height/pressure , etc of level.
+
41C> - 8: year including (century-1).
+
42C> - 9: month of year.
+
43C> - 10: day of month.
+
44C> - 11: hour of day.
+
45C> - 12: minute of hour.
+
46C> - 13: indicator of forecast time unit.
+
47C> - 14: time range 1.
+
48C> - 15: time range 2.
+
49C> - 16: time range flag.
+
50C> - 17: number included in average.
+
51C> - 18: version nr of grib specification.
+
52C> - 19: version nr of parameter table.
+
53C> - 20: nr missing from average/accumulation.
+
54C> - 21: century of reference time of data.
+
55C> - 22: units decimal scale factor.
+
56C> - 23: subcenter number.
+
57C> - 24: pds byte 29, for nmc ensemble products.
+
58C> - 128 if forecast field error.
+
59C> - 64 if bias corrected fcst field.
+
60C> - 32 if smoothed field.
+
61C> - warning: can be combination of more than 1.
+
62C> - 25: pds byte 30, not used.
+
63C> @param[in] jgds integer (200) gds parameters for which to search
+
64C> (only searched if jpds(3)=255)
+
65C> (=-1 for wildcard).
+
66C> - 1): data representation type.
+
67C> - 19: number of vertical coordinate parameters.
+
68C> - 20: octet number of the list of vertical coordinate parameters or.
+
69C> octet number of the list of numbers of points in each row or.
+
70C> 255 if neither are present.
+
71C> - 21: for grids with pl, number of points in grid.
+
72C> - 22: number of words in each row.
+
73C> - Latitude/longitude grids.
+
74C> - 2): n(i) nr points on latitude circle.
+
75C> - 3): n(j) nr points on longitude meridian.
+
76C> - 4): la(1) latitude of origin.
+
77C> - 5): lo(1) longitude of origin.
+
78C> - 6): resolution flag (right adj copy of octet 17).
+
79C> - 7): la(2) latitude of extreme point.
+
80C> - 8): lo(2) longitude of extreme point.
+
81C> - 9): di longitudinal direction of increment.
+
82C> - 10: dj latitudinal direction increment.
+
83C> - 11: scanning mode flag (right adj copy of octet 28).
+
84C> - Gaussian grids.
+
85C> - 2): n(i) nr points on latitude circle.
+
86C> - 3): n(j) nr points on longitude meridian.
+
87C> - 4): la(1) latitude of origin.
+
88C> - 5): lo(1) longitude of origin.
+
89C> - 6): resolution flag (right adj copy of octet 17).
+
90C> - 7): la(2) latitude of extreme point.
+
91C> - 8): lo(2) longitude of extreme point.
+
92C> - 9): di longitudinal direction of increment.
+
93C> - 10: n - nr of circles pole to equator.
+
94C> - 11: scanning mode flag (right adj copy of octet 28).
+
95C> - 12: nv - nr of vert coord parameters.
+
96C> - 13: pv - octet nr of list of vert coord parameters or
+
97C> pl - location of the list of numbers of points in each row
+
98C> (if no vert coord parameters are present) or
+
99C> 255 if neither are present
+
100C> - Polar stereographic grids.
+
101C> - 2): n(i) nr points along lat circle.
+
102C> - 3): n(j) nr points along lon circle.
+
103C> - 4): la(1) latitude of origin.
+
104C> - 5): lo(1) longitude of origin.
+
105C> - 6): resolution flag (right adj copy of octet 17).
+
106C> - 7): lov grid orientation.
+
107C> - 8): dx - x direction increment.
+
108C> - 9): dy - y direction increment.
+
109C> - 10: projection center flag.
+
110C> - 11: scanning mode (right adj copy of octet 28).
+
111C> - Spherical harmonic coefficients.
+
112C> - 2): j pentagonal resolution parameter.
+
113C> - 3): k pentagonal resolution parameter.
+
114C> - 4): m pentagonal resolution parameter.
+
115C> - 5): representation type.
+
116C> - 6): coefficient storage mode.
+
117C> - Mercator grids.
+
118C> - 2): n(i) nr points on latitude circle.
+
119C> - 3): n(j) nr points on longitude meridian.
+
120C> - 4): la(1) latitude of origin.
+
121C> - 5): lo(1) longitude of origin.
+
122C> - 6): resolution flag (right adj copy of octet 17).
+
123C> - 7): la(2) latitude of last grid point.
+
124C> - 8): lo(2) longitude of last grid point.
+
125C> - 9): latit - latitude of projection intersection.
+
126C> - 10: reserved.
+
127C> - 11: scanning mode flag (right adj copy of octet 28).
+
128C> - 12: longitudinal dir grid length.
+
129C> - 13: latitudinal dir grid length.
+
130C> - Lambert conformal grids.
+
131C> - 2): nx nr points along x-axis.
+
132C> - 3): ny nr points along y-axis.
+
133C> - 4): la1 lat of origin (lower left).
+
134C> - 5): lo1 lon of origin (lower left).
+
135C> - 6): resolution (right adj copy of octet 17).
+
136C> - 7): lov - orientation of grid.
+
137C> - 8): dx - x-dir increment.
+
138C> - 9): dy - y-dir increment.
+
139C> - 10: projection center flag.
+
140C> - 11: scanning mode flag (right adj copy of octet 28).
+
141C> - 12: latin 1 - first lat from pole of secant cone inter.
+
142C> - 13: latin 2 - second lat from pole of secant cone inter.
+
143C> @param[in] mbuf integer length of index buffer in bytes.
+
144C> @param[inout] cbuf character*1 (mbuf) index buffer
+
145C> (initialize by setting j=-1).
+
146C> @param[inout] nlen integer length of each index record in bytes
+
147C> (initialize by setting j=-1).
+
148C> @param[inout] nnum integer number of index records
+
149C> (initialize by setting j=-1).
+
150C> @param[inout] mnum integer number of index records skipped
+
151C> (initialize by setting j=-1).
+
152C> @param[out] kf integer number of data points unpacked.
+
153C> @param[out] k integer message number unpacked
+
154C> (can be same as j in calling program in order to facilitate multiple searches).
+
155C> @param[out] kpds integer (200) unpacked pds parameters.
+
156C> @param[out] kgds integer (200) unpacked gds parameters.
+
157C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
158C> @param[out] f real (kf) unpacked data.
+
159C> @param[out] iret integer return code.
+
160C> - 0: all ok.
+
161C> - 96: error reading index file.
+
162C> - 97: error reading grib file.
+
163C> - 98: number of data points greater than jf.
+
164C> - 99: request not found.
+
165C> - other w3fi63 grib unpacker return code.
+
166C>
+
167C> @note Specify an index file if feasible to increase speed.
+
168C> Subprogram can be called from a multiprocessing environment.
+
169C> Do not engage the same logical unit from more than one processor.
+
170C>
+
171C> @author Mark Iredell @date 1994-04-01
+
172C-----------------------------------------------------------------------
+
+
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)
+
183C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
184C 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
+
210C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
211C 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
+
227C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
228C 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
+
239C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
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
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/getgbmh_8f.html b/getgbmh_8f.html index 551d0607..8e2afdfa 100644 --- a/getgbmh_8f.html +++ b/getgbmh_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbmh.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbmh.f File Reference
+
getgbmh.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Finds a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbmh.f.

Function/Subroutine Documentation

- -

◆ getgbmh()

+ +

◆ getgbmh()

@@ -117,97 +123,97 @@

subroutine getgbmh (   - LUGB, + lugb,   - LUGI, + lugi,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KG, + kg,   - KF, + kf,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds,   - IRET  + iret  @@ -382,7 +388,7 @@

diff --git a/getgbmh_8f.js b/getgbmh_8f.js index c6b9bbfd..e9f5c89c 100644 --- a/getgbmh_8f.js +++ b/getgbmh_8f.js @@ -1,4 +1,4 @@ var getgbmh_8f = [ - [ "getgbmh", "getgbmh_8f.html#ac4c2d81dcaf427548139d55ca7041022", null ] + [ "getgbmh", "getgbmh_8f.html#a0fe386a75ceff44f8914bc6d883c28f4", null ] ]; \ No newline at end of file diff --git a/getgbmh_8f_source.html b/getgbmh_8f_source.html index bc5c9010..acb87d40 100644 --- a/getgbmh_8f_source.html +++ b/getgbmh_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbmh.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,257 +81,265 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbmh.f
+
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
-
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
-
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+Go to the documentation of this file.
1C> @file
+
2C> @brief Finds a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Read a grib index file (or optionally the grib file itself)
+
6C> to get the index buffer (i.e. table of contents) for the grib file.
+
7C> Find in the index buffer a reference to the grib message requested.
+
8C> The grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. (A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then its message number is
+
12C> returned along with the unpacked pds and gds parameters. If the
+
13C> grib message is not found, then the return code will be nonzero.
+
14C>
+
15C> Program history log:
+
16C> - Mark Iredell 1994-04-01
+
17C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
18C> and allowed for unspecified index file.
+
19C>
+
20C> @param[in] lugb integer unit of the unblocked grib data file
+
21C> (only used if lugi=0).
+
22C> @param[in] lugi integer unit of the unblocked grib index file
+
23C> (=0 to get index buffer from the grib file).
+
24C> @param[in] j integer number of messages to skip
+
25C> (=0 to search from beginning)
+
26C> (<0 to read index buffer and skip -1-j messages).
+
27C> @param[in] jpds integer (200) pds parameters for which to search
+
28C> (=-1 for wildcard).
+
29C> - 1: id of center.
+
30C> - 2: generating process id number.
+
31C> - 3: grid definition.
+
32C> - 4: gds/bms flag (right adj copy of octet 8).
+
33C> - 5: indicator of parameter.
+
34C> - 6: type of level.
+
35C> - 7: height/pressure , etc of level.
+
36C> - 8: year including (century-1).
+
37C> - 9: month of year.
+
38C> - 10: day of month.
+
39C> - 11: hour of day.
+
40C> - 12: minute of hour.
+
41C> - 13: indicator of forecast time unit.
+
42C> - 14: time range 1.
+
43C> - 15: time range 2.
+
44C> - 16: time range flag.
+
45C> - 17: number included in average.
+
46C> - 18: version nr of grib specification.
+
47C> - 19: version nr of parameter table.
+
48C> - 20: nr missing from average/accumulation.
+
49C> - 21: century of reference time of data.
+
50C> - 22: units decimal scale factor.
+
51C> - 23: subcenter number.
+
52C> - 24: pds byte 29, for nmc ensemble products.
+
53C> - 128 if forecast field error.
+
54C> - 64 if bias corrected fcst field.
+
55C> - 32 if smoothed field.
+
56C> - warning: can be combination of more than 1.
+
57C> - 25: pds byte 30, not used.
+
58C> @param[in] jgds integer (200) gds parameters for which to search
+
59C> (only searched if jpds(3)=255)
+
60C> (=-1 for wildcard).
+
61C> - 1: data representation type.
+
62C> - 19: number of vertical coordinate parameters.
+
63C> - 20: octet number of the list of vertical coordinate parameters or
+
64C> octet number of the list of numbers of points in each row or
+
65C> 255 if neither are present.
+
66C> - 21: for grids with pl, number of points in grid.
+
67C> - 22: number of words in each row.
+
68C> - Latitude/longitude grids.
+
69C> - 2: n(i) nr points on latitude circle.
+
70C> - 3: n(j) nr points on longitude meridian.
+
71C> - 4: la(1) latitude of origin.
+
72C> - 5: lo(1) longitude of origin.
+
73C> - 6: resolution flag (right adj copy of octet 17).
+
74C> - 7: la(2) latitude of extreme point.
+
75C> - 8: lo(2) longitude of extreme point.
+
76C> - 9: di longitudinal direction of increment.
+
77C> - 10: dj latitudinal direction increment.
+
78C> - 11: scanning mode flag (right adj copy of octet 28).
+
79C> - Gaussian grids.
+
80C> - 2: n(i) nr points on latitude circle.
+
81C> - 3: n(j) nr points on longitude meridian.
+
82C> - 4: la(1) latitude of origin.
+
83C> - 5: lo(1) longitude of origin.
+
84C> - 6: resolution flag (right adj copy of octet 17).
+
85C> - 7: la(2) latitude of extreme point.
+
86C> - 8: lo(2) longitude of extreme point.
+
87C> - 9: di longitudinal direction of increment.
+
88C> - 10: n - nr of circles pole to equator.
+
89C> - 11: scanning mode flag (right adj copy of octet 28).
+
90C> - 12: nv - nr of vert coord parameters.
+
91C> - 13: pv - octet nr of list of vert coord parameters or
+
92C> pl - location of the list of numbers of points in each row
+
93C> (if no vert coord parameters are present or
+
94C> 255 if neither are present
+
95C> - Polar stereographic grids.
+
96C> - 2: n(i) nr points along lat circle.
+
97C> - 3: n(j) nr points along lon circle.
+
98C> - 4: la(1) latitude of origin.
+
99C> - 5: lo(1) longitude of origin.
+
100C> - 6: resolution flag (right adj copy of octet 17).
+
101C> - 7: lov grid orientation.
+
102C> - 8: dx - x direction increment.
+
103C> - 9: dy - y direction increment.
+
104C> - 10: projection center flag.
+
105C> - 11: scanning mode (right adj copy of octet 28).
+
106C> - Spherical harmonic coefficients.
+
107C> - 2): j pentagonal resolution parameter.
+
108C> - 3): k pentagonal resolution parameter.
+
109C> - 4): m pentagonal resolution parameter.
+
110C> - 5): representation type.
+
111C> - 6): coefficient storage mode.
+
112C> - Mercator grids.
+
113C> - 2: n(i) nr points on latitude circle.
+
114C> - 3: n(j) nr points on longitude meridian.
+
115C> - 4: la(1) latitude of origin.
+
116C> - 5: lo(1) longitude of origin.
+
117C> - 6: resolution flag (right adj copy of octet 17).
+
118C> - 7: la(2) latitude of last grid point.
+
119C> - 8: lo(2) longitude of last grid point.
+
120C> - 9: latit - latitude of projection intersection.
+
121C> - 10: reserved.
+
122C> - 11: scanning mode flag (right adj copy of octet 28).
+
123C> - 12: longitudinal dir grid length.
+
124C> - 13: latitudinal dir grid length.
+
125C> - Lambert conformal grids.
+
126C> - 2: nx nr points along x-axis.
+
127C> - 3: ny nr points along y-axis.
+
128C> - 4: la1 lat of origin (lower left).
+
129C> - 5: lo1 lon of origin (lower left).
+
130C> - 6: resolution (right adj copy of octet 17).
+
131C> - 7: lov - orientation of grid.
+
132C> - 8: dx - x-dir increment.
+
133C> - 9: dy - y-dir increment.
+
134C> - 10: projection center flag.
+
135C> - 11: scanning mode flag (right adj copy of octet 28).
+
136C> - 12: latin 1 - first lat from pole of secant cone inter.
+
137C> - 13: latin 2 - second lat from pole of secant cone inter.
+
138C> @param[in] mbuf integer length of index buffer in bytes.
+
139C> @param[inout] cbuf character*1 (mbuf) index buffer
+
140C> (initialize by setting j=-1).
+
141C> @param[inout] nlen integer length of each index record in bytes
+
142C> (initialize by setting j=-1).
+
143C> @param[inout] nnum integer number of index records
+
144C> (initialize by setting j=-1).
+
145C> @param[inout] mnum integer number of index records skipped
+
146C> (initialize by setting j=-1).
+
147C> @param[out] kg integer number of bytes in the grib message.
+
148C> @param[out] kf integer number of data points in the message.
+
149C> @param[out] k integer message number unpacked
+
150C> (can be same as j in calling program in order to facilitate multiple searches).
+
151C> @param[out] kpds integer (200) unpacked pds parameters.
+
152C> @param[out] kgds integer (200) unpacked gds parameters.
+
153C> @param[out] iret integer return code.
+
154C> - 0: all ok.
+
155C> - 96: error reading index file.
+
156C> - 99: request not found.
+
157C>
+
158C> @note Specify an index file if feasible to increase speed.
+
159C> Subprogram can be called from a multiprocessing environment.
+
160C> Do not engage the same logical unit from more than one processor.
+
161C>
+
162C> @author Mark Iredell @date 1994-04-01
+
163C-----------------------------------------------------------------------
+
+
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)
+
172C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
173C 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
+
199C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
200C 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
+
216C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
217C 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
+
227C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
228 RETURN
+
+
229 END
+
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
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/getgbmp_8f.html b/getgbmp_8f.html index 6a4bb0f2..99f76e93 100644 --- a/getgbmp_8f.html +++ b/getgbmp_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbmp.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbmp.f File Reference
+
getgbmp.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Finds a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbmp.f.

Function/Subroutine Documentation

- -

◆ getgbmp()

+ +

◆ getgbmp()

@@ -117,103 +123,103 @@

subroutine getgbmp (   - LUGB, + lugb,   - LUGI, + lugi,   - JG, + jg,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - MNUM, + mnum,   - KG, + kg,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, character, dimension(jg)  - G, + g,   - IRET  + iret  @@ -391,7 +397,7 @@

diff --git a/getgbmp_8f.js b/getgbmp_8f.js index e2fbf085..4fc78272 100644 --- a/getgbmp_8f.js +++ b/getgbmp_8f.js @@ -1,4 +1,4 @@ var getgbmp_8f = [ - [ "getgbmp", "getgbmp_8f.html#a3dce03b33b45a2c4f9c859774615cb5a", null ] + [ "getgbmp", "getgbmp_8f.html#a87989f48a32883137be354ba99db080b", null ] ]; \ No newline at end of file diff --git a/getgbmp_8f_source.html b/getgbmp_8f_source.html index 5f86c917..63fcb4ac 100644 --- a/getgbmp_8f_source.html +++ b/getgbmp_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbmp.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,262 +81,270 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgbmp.f
+
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
-
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
-
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Finds a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> Read a grib index file (or optionally the grib file itself)
+
6C> to get the index buffer (i.e. table of contents) for the grib file.
+
7C> Find in the index buffer a reference to the grib message requested.
+
8C> The grib message request specifies the number of messages to skip
+
9C> and the unpacked pds and gds parameters. (A requested parameter
+
10C> of -1 means to allow any value of this parameter to be found.)
+
11C> If the requested grib message is found, then it is read from the
+
12C> grib file. Its message number is returned along with the unpacked
+
13C> pds and gds parameters and the packed grib message. If the grib
+
14C> message is not found, then the return code will be nonzero.
+
15C>
+
16C> Program history log:
+
17C> - Mark Iredell 1994-04-01 iredell
+
18C> - Mark Iredell 1995-10-31 iredell Modularized portions of code into subprograms
+
19C> and allowed for unspecified index file.
+
20C>
+
21C> @param[in] lugb integer unit of the unblocked grib data file.
+
22C> @param[in] lugi integer unit of the unblocked grib index file
+
23C> (=0 to get index buffer from the grib file).
+
24C> @param[in] jg integer maximum number of bytes in the grib message.
+
25C> @param[in] j integer number of messages to skip
+
26C> (=0 to search from beginning)
+
27C> (<0 to read index buffer and skip -1-j messages).
+
28C> @param[in] jpds integer (200) pds parameters for which to search
+
29C> (=-1 for wildcard).
+
30C> - 1): id of center.
+
31C> - 2): generating process id number.
+
32C> - 3): grid definition.
+
33C> - 4): gds/bms flag (right adj copy of octet 8).
+
34C> - 5): indicator of parameter.
+
35C> - 6): type of level.
+
36C> - 7): height/pressure , etc of level.
+
37C> - 8): year including (century-1).
+
38C> - 9): month of year.
+
39C> - 10: day of month.
+
40C> - 11: hour of day.
+
41C> - 12: minute of hour.
+
42C> - 13: indicator of forecast time unit.
+
43C> - 14: time range 1.
+
44C> - 15: time range 2.
+
45C> - 16: time range flag.
+
46C> - 17: number included in average.
+
47C> - 18: version nr of grib specification.
+
48C> - 19: version nr of parameter table.
+
49C> - 20: nr missing from average/accumulation.
+
50C> - 21: century of reference time of data.
+
51C> - 22: units decimal scale factor.
+
52C> - 23: subcenter number.
+
53C> - 24: pds byte 29, for nmc ensemble products.
+
54C> - 128 if forecast field error.
+
55C> - 64 if bias corrected fcst field.
+
56C> - 32 if smoothed field.
+
57C> - warning: can be combination of more than 1.
+
58C> - 25: pds byte 30, not used.
+
59C> @param[in] jgds integer (200) gds parameters for which to search
+
60C> (only searched if jpds(3)=255)
+
61C> (=-1 for wildcard).
+
62C> - 1): data representation type.
+
63C> - 19: number of vertical coordinate parameters.
+
64C> - 20: octet number of the list of vertical coordinate parameters or.
+
65C> octet number of the list of numbers of points in each row or.
+
66C> 255 if neither are present.
+
67C> - 21: for grids with pl, number of points in grid.
+
68C> - 22: number of words in each row.
+
69C> - Latitude/longitude grids.
+
70C> - 2): n(i) nr points on latitude circle.
+
71C> - 3): n(j) nr points on longitude meridian.
+
72C> - 4): la(1) latitude of origin.
+
73C> - 5): lo(1) longitude of origin.
+
74C> - 6): resolution flag (right adj copy of octet 17).
+
75C> - 7): la(2) latitude of extreme point.
+
76C> - 8): lo(2) longitude of extreme point.
+
77C> - 9): di longitudinal direction of increment.
+
78C> - 10: dj latitudinal direction increment.
+
79C> - 11: scanning mode flag (right adj copy of octet 28).
+
80C> - Gaussian grids.
+
81C> - 2): n(i) nr points on latitude circle.
+
82C> - 3): n(j) nr points on longitude meridian.
+
83C> - 4): la(1) latitude of origin.
+
84C> - 5): lo(1) longitude of origin.
+
85C> - 6): resolution flag (right adj copy of octet 17).
+
86C> - 7): la(2) latitude of extreme point.
+
87C> - 8): lo(2) longitude of extreme point.
+
88C> - 9): di longitudinal direction of increment.
+
89C> - 10: n - nr of circles pole to equator.
+
90C> - 11: scanning mode flag (right adj copy of octet 28).
+
91C> - 12: nv - nr of vert coord parameters.
+
92C> - 13: pv - octet nr of list of vert coord parameters or
+
93C> pl - location of the list of numbers of points in each row
+
94C> (if no vert coord parameters are present) or
+
95C> 255 if neither are present.
+
96C> - Polar stereographic grids.
+
97C> - 2): n(i) nr points along lat circle.
+
98C> - 3): n(j) nr points along lon circle.
+
99C> - 4): la(1) latitude of origin.
+
100C> - 5): lo(1) longitude of origin.
+
101C> - 6): resolution flag (right adj copy of octet 17).
+
102C> - 7): lov grid orientation.
+
103C> - 8): dx - x direction increment.
+
104C> - 9): dy - y direction increment.
+
105C> - 10: projection center flag.
+
106C> - 11: scanning mode (right adj copy of octet 28).
+
107C> - Spherical harmonic coefficients.
+
108C> - 2): j pentagonal resolution parameter.
+
109C> - 3): k pentagonal resolution parameter.
+
110C> - 4): m pentagonal resolution parameter.
+
111C> - 5): representation type.
+
112C> - 6): coefficient storage mode.
+
113C> - Mercator grids.
+
114C> - 2): n(i) nr points on latitude circle.
+
115C> - 3): n(j) nr points on longitude meridian.
+
116C> - 4): la(1) latitude of origin.
+
117C> - 5): lo(1) longitude of origin.
+
118C> - 6): resolution flag (right adj copy of octet 17).
+
119C> - 7): la(2) latitude of last grid point.
+
120C> - 8): lo(2) longitude of last grid point.
+
121C> - 9): latit - latitude of projection intersection.
+
122C> - 10: reserved.
+
123C> - 11: scanning mode flag (right adj copy of octet 28).
+
124C> - 12: longitudinal dir grid length.
+
125C> - 13: latitudinal dir grid length.
+
126C> - Lambert conformal grids.
+
127C> - 2): nx nr points along x-axis.
+
128C> - 3): ny nr points along y-axis.
+
129C> - 4): la1 lat of origin (lower left).
+
130C> - 5): lo1 lon of origin (lower left).
+
131C> - 6): resolution (right adj copy of octet 17).
+
132C> - 7): lov - orientation of grid.
+
133C> - 8): dx - x-dir increment.
+
134C> - 9): dy - y-dir increment.
+
135C> - 10: projection center flag.
+
136C> - 11: scanning mode flag (right adj copy of octet 28).
+
137C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139C> @param[in] mbuf integer length of index buffer in bytes.
+
140C> @param[inout] cbuf character*1 (mbuf) index buffer
+
141C> (initialize by setting j=-1).
+
142C> @param[inout] nlen integer length of each index record in bytes
+
143C> (initialize by setting j=-1).
+
144C> @param[inout] nnum integer number of index records
+
145C> (initialize by setting j=-1).
+
146C> @param[inout] mnum integer number of index records skipped
+
147C> (initialize by setting j=-1).
+
148C> @param[out] kg integer number of bytes in the grib message.
+
149C> @param[out] k integer message number unpacked
+
150C> (can be same as j in calling programin order to facilitate multiple searches).
+
151C> @param[out] kpds integer (200) unpacked pds parameters.
+
152C> @param[out] kgds integer (200) unpacked gds parameters.
+
153C> @param[out] g character*1 (kg) grib message.
+
154C> @param[out] iret integer return code.
+
155C> - 0: all ok.
+
156C> - 96: error reading index file.
+
157C> - 97: error reading grib file.
+
158C> - 98: number of bytes greater than jg.
+
159C> - 99: request not found.
+
160C>
+
161C> @note Specify an index file if feasible to increase speed.
+
162C> Subprogram can be called from a multiprocessing environment.
+
163C> Do not engage the same logical unit from more than one processor.
+
164C>
+
165C> @author Mark Iredell @date 1994-04-01
+
166C-----------------------------------------------------------------------
+
+
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)
+
176C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
177C 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
+
203C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
204C 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
+
220C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
221C 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
+
233C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
234 RETURN
+
+
235 END
+
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
+
getgi
subroutine getgi(lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
Read a grib index file and return its contents.
Definition getgi.f:50
+
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
diff --git a/getgbp_8f.html b/getgbp_8f.html index eeb797ea..f0f7a42c 100644 --- a/getgbp_8f.html +++ b/getgbp_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgbp.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgbp.f File Reference
+
getgbp.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Finds a grib message.

@@ -107,8 +113,8 @@

Definition in file getgbp.f.

Function/Subroutine Documentation

- -

◆ getgbp()

+ +

◆ getgbp()

@@ -117,73 +123,73 @@

subroutine getgbp (   - LUGB, + lugb,   - LUGI, + lugi,   - JG, + jg,   - J, + j, integer, dimension(200)  - JPDS, + jpds, integer, dimension(200)  - JGDS, + jgds,   - KG, + kg,   - K, + k, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, character, dimension(jg)  - G, + g,   - IRET  + iret  @@ -356,7 +362,7 @@

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

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...
 
subroutine getgi (lugi, mnum, mbuf, cbuf, nlen, nnum, iret)
 Read a grib index file and return its contents.
 

Detailed Description

Read a grib index file and return its contents.

@@ -107,8 +113,8 @@

Definition in file getgi.f.

Function/Subroutine Documentation

- -

◆ getgi()

+ +

◆ getgi()

@@ -117,43 +123,43 @@

subroutine getgi (   - LUGI, + lugi,   - MNUM, + mnum,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - IRET  + iret  @@ -216,7 +222,7 @@

diff --git a/getgi_8f.js b/getgi_8f.js index b1e5a660..967655ad 100644 --- a/getgi_8f.js +++ b/getgi_8f.js @@ -1,4 +1,4 @@ var getgi_8f = [ - [ "getgi", "getgi_8f.html#aa6b511267e410648a9961a1aa2e4d27f", null ] + [ "getgi", "getgi_8f.html#acdad122216fa099a6a3a45cbf85ec1c2", null ] ]; \ No newline at end of file diff --git a/getgi_8f_source.html b/getgi_8f_source.html index 1c2439c7..b9707257 100644 --- a/getgi_8f_source.html +++ b/getgi_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgi.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,101 +81,109 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgi.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Read a grib index file and return its contents.
+
3C> @author Mark Iredell @date 1995-10-31
+
4
+
5C> Read a grib index file and return its contents.
+
6C> Version 1 of the index file has the following format:
+
7C> 81-byte s.lord header with 'gb1ix1' in columns 42-47 followed by
+
8C> 81-byte header with number of bytes to skip before index records,
+
9C> number of bytes in each index record, number of index records,
+
10C> and grib file basename written in format ('ix1form:',3i10,2x,a40).
+
11C> Each following index record corresponds to a grib message
+
12C> and has the internal format:
+
13C> - byte 001-004: bytes to skip in data file before grib message.
+
14C> - byte 005-008: bytes to skip in message before pds.
+
15C> - byte 009-012: bytes to skip in message before gds (0 if no gds).
+
16C> - byte 013-016: bytes to skip in message before bms (0 if no bms).
+
17C> - byte 017-020: bytes to skip in message before bds.
+
18C> - byte 021-024: bytes total in the message.
+
19C> - byte 025-025: grib version number.
+
20C> - byte 026-053: product definition section (pds).
+
21C> - byte 054-095: grid definition section (gds) (or nulls).
+
22C> - byte 096-101: first part of the bit map section (bms) (or nulls).
+
23C> - byte 102-112: first part of the binary data section (bds).
+
24C> - byte 113-172: (optional) bytes 41-100 of the pds.
+
25C> - byte 173-184: (optional) bytes 29-40 of the pds.
+
26C> - byte 185-320: (optional) bytes 43-178 of the gds.
+
27C>
+
28C> Program history log:
+
29C> - Mark Iredell 1995-10-31
+
30C> - Mark Iredell 1996-10-31 Augmented optional definitions to byte 320.
+
31C>
+
32C> @param[in] lugi integer unit of the unblocked grib index file.
+
33C> @param[in] mnum integer number of index records to skip (usually 0).
+
34C> @param[in] mbuf integer length of cbuf in bytes.
+
35C> @param[out] cbuf character*1 (mbuf) buffer to receive index data.
+
36C> @param[out] nlen integer length of each index record in bytes.
+
37C> @param[out] nnum integer number of index records.
+
38C> @param[out] iret integer return code.
+
39C> - 0: all ok.
+
40C> - 1: cbuf too small to hold index buffer.
+
41C> - 2: error reading index file buffer.
+
42C> - 3: error reading index file header.
+
43C>
+
44C> @note Subprogram can be called from a multiprocessing environment.
+
45C> Do not engage the same logical unit from more than one processor.
+
46C>
+
47C> @author Mark Iredell @date 1995-10-31
+
48C-----------------------------------------------------------------------
+
+
49 SUBROUTINE getgi(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET)
+
50 CHARACTER CBUF(MBUF)
+
51 CHARACTER CHEAD*162
+
52C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
75C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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/getgir_8f.html b/getgir_8f.html index 4be04ade..b27f3935 100644 --- a/getgir_8f.html +++ b/getgir_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgir.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
getgir.f File Reference
+
getgir.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine getgir (lugb, msk1, msk2, mnum, mbuf, cbuf, nlen, nnum, iret)
 Read a grib file and return its index contents.
 

Detailed Description

Read a grib index file and return its index contents.

@@ -107,8 +113,8 @@

Definition in file getgir.f.

Function/Subroutine Documentation

- -

◆ getgir()

+ +

◆ getgir()

@@ -117,55 +123,55 @@

subroutine getgir (   - LUGB, + lugb,   - MSK1, + msk1,   - MSK2, + msk2,   - MNUM, + mnum,   - MBUF, + mbuf, character, dimension(mbuf)  - CBUF, + cbuf,   - NLEN, + nlen,   - NNUM, + nnum,   - IRET  + iret  @@ -228,7 +234,7 @@

diff --git a/getgir_8f.js b/getgir_8f.js index 92a1afe8..2556ae23 100644 --- a/getgir_8f.js +++ b/getgir_8f.js @@ -1,4 +1,4 @@ var getgir_8f = [ - [ "getgir", "getgir_8f.html#abcd2305cabdf6bb6a000fbb948c608a1", null ] + [ "getgir", "getgir_8f.html#a1d594876e11881c99690d52b4091849f", null ] ]; \ No newline at end of file diff --git a/getgir_8f_source.html b/getgir_8f_source.html index 462d7b4b..bcc4fee6 100644 --- a/getgir_8f_source.html +++ b/getgir_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: getgir.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,104 +81,112 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
getgir.f
+
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
-
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
-
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
-
skgb
subroutine skgb(LUGB, ISEEK, MSEEK, LSKIP, LGRIB)
This subprogram searches a file for the next grib 1 message.
Definition: skgb.f:27
+Go to the documentation of this file.
1C> @file
+
2C> @brief Read a grib index file and return its index contents.
+
3C> @author Mark Iredell @date 1995-10-31
+
4
+
5C> Read a grib file and return its index contents.
+
6C> The index buffer returned contains index records with the internal format:
+
7C> - byte 001-004: bytes to skip in data file before grib message.
+
8C> - byte 005-008: bytes to skip in message before pds.
+
9C> - byte 009-012: bytes to skip in message before gds (0 if no gds).
+
10C> - byte 013-016: bytes to skip in message before bms (0 if no bms).
+
11C> - byte 017-020: bytes to skip in message before bds.
+
12C> - byte 021-024: bytes total in the message.
+
13C> - byte 025-025: grib version number.
+
14C> - byte 026-053: product definition section (pds).
+
15C> - byte 054-095: grid definition section (gds) (or nulls).
+
16C> - byte 096-101: first part of the bit map section (bms) (or nulls).
+
17C> - byte 102-112: first part of the binary data section (bds).
+
18C> - byte 113-172: (optional) bytes 41-100 of the pds.
+
19C> - byte 173-184: (optional) bytes 29-40 of the pds.
+
20C> - byte 185-320: (optional) bytes 43-178 of the gds.
+
21C>
+
22C> Program history log:
+
23C> - Mark Iredell 1995-10-31
+
24C> - Mark Iredell 1996-10-31 Augmented optional definitions to byte 320.
+
25C>
+
26C> @param[in] lugb integer unit of the unblocked grib file.
+
27C> @param[in] msk1 integer number of bytes to search for first message.
+
28C> @param[in] msk2 integer number of bytes to search for other messages.
+
29C> @param[in] mnum integer number of index records to skip (usually 0).
+
30C> @param[in] mbuf integer length of cbuf in bytes.
+
31C> @param[out] cbuf character*1 (mbuf) buffer to receive index data.
+
32C> @param[out] nlen integer length of each index record in bytes.
+
33C> @param[out] nnum integer number of index records
+
34C> (=0 if no grib messages are found).
+
35C> @param[out] iret integer return code.
+
36C> - 0: all ok.
+
37C> - 1: cbuf too small to hold index data.
+
38C>
+
39C> @note Subprogram can be called from a multiprocessing environment.
+
40C> Do not engage the same logical unit from more than one processor.
+
41C>
+
42C> @author Mark Iredell @date 1995-10-31
+
43C-----------------------------------------------------------------------
+
+
44 SUBROUTINE getgir(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET)
+
45 CHARACTER CBUF(MBUF)
+
46 parameter(mindex=320)
+
47C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
48C 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
+
62C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
63C 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
+
76C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
77 RETURN
+
+
78 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
+
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
+
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/globals.html b/globals.html index ed2706b0..8e8c8413 100644 --- a/globals.html +++ b/globals.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- a -

diff --git a/globals_b.html b/globals_b.html index 2d62940e..2d176791 100644 --- a/globals_b.html +++ b/globals_b.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,25 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- b -

diff --git a/globals_c.html b/globals_c.html index 922618a7..9e06071d 100644 --- a/globals_c.html +++ b/globals_c.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,32 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- c -

diff --git a/globals_e.html b/globals_e.html index fd82bd92..ceaf7290 100644 --- a/globals_e.html +++ b/globals_e.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,34 +76,33 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- e -

diff --git a/globals_f.html b/globals_f.html index 466969fb..eaf936a8 100644 --- a/globals_f.html +++ b/globals_f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,199 +76,88 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- f -

diff --git a/globals_func.html b/globals_func.html index e8f63460..eea59f43 100644 --- a/globals_func.html +++ b/globals_func.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- a -

diff --git a/globals_func_b.html b/globals_func_b.html index 146fb1a3..62d512e9 100644 --- a/globals_func_b.html +++ b/globals_func_b.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,25 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- b -

diff --git a/globals_func_c.html b/globals_func_c.html index 941acc76..b68ecebd 100644 --- a/globals_func_c.html +++ b/globals_func_c.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,32 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- c -

diff --git a/globals_func_e.html b/globals_func_e.html index cea43fe8..7003dacb 100644 --- a/globals_func_e.html +++ b/globals_func_e.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,34 +76,33 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- e -

diff --git a/globals_func_f.html b/globals_func_f.html index b28415a8..368ed986 100644 --- a/globals_func_f.html +++ b/globals_func_f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,199 +76,88 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- f -

diff --git a/globals_func_g.html b/globals_func_g.html index 01a8c2cf..e4d6efee 100644 --- a/globals_func_g.html +++ b/globals_func_g.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,103 +76,57 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- g -

diff --git a/globals_func_i.html b/globals_func_i.html index d295092f..ce101063 100644 --- a/globals_func_i.html +++ b/globals_func_i.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,55 +76,41 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- i -

diff --git a/globals_func_l.html b/globals_func_l.html index af0ec9af..27cfe981 100644 --- a/globals_func_l.html +++ b/globals_func_l.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,34 +76,33 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- l -

diff --git a/globals_func_m.html b/globals_func_m.html index 6c798353..43ac8812 100644 --- a/globals_func_m.html +++ b/globals_func_m.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,46 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- m -

diff --git a/globals_func_o.html b/globals_func_o.html index 145dc6c2..78a2ae3b 100644 --- a/globals_func_o.html +++ b/globals_func_o.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,25 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- o -

diff --git a/globals_func_p.html b/globals_func_p.html index 44856056..e85585ae 100644 --- a/globals_func_p.html +++ b/globals_func_p.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- p -

diff --git a/globals_func_q.html b/globals_func_q.html index 33aa2f4a..d06c1fec 100644 --- a/globals_func_q.html +++ b/globals_func_q.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,32 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- q -

diff --git a/globals_func_r.html b/globals_func_r.html index 040cf5be..9c665763 100644 --- a/globals_func_r.html +++ b/globals_func_r.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,40 +76,35 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- r -

diff --git a/globals_func_s.html b/globals_func_s.html index 9c52a856..565e50bd 100644 --- a/globals_func_s.html +++ b/globals_func_s.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- s -

diff --git a/globals_func_u.html b/globals_func_u.html index fb2c47d8..8a3921d9 100644 --- a/globals_func_u.html +++ b/globals_func_u.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- u -

diff --git a/globals_func_v.html b/globals_func_v.html index 0b1b4c7d..8749c6e1 100644 --- a/globals_func_v.html +++ b/globals_func_v.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,25 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- v -

diff --git a/globals_func_w.html b/globals_func_w.html index 7826cb5d..d91281aa 100644 --- a/globals_func_w.html +++ b/globals_func_w.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,445 +76,171 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- w -

diff --git a/globals_func_x.html b/globals_func_x.html index 33d1c9fd..a2524981 100644 --- a/globals_func_x.html +++ b/globals_func_x.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,32 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-  +
Here is a list of all documented functions with links to the documentation:
-

- x -

diff --git a/globals_g.html b/globals_g.html index ff2675a8..9748599a 100644 --- a/globals_g.html +++ b/globals_g.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,103 +76,57 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- g -

diff --git a/globals_i.html b/globals_i.html index c5673024..7b8e5f37 100644 --- a/globals_i.html +++ b/globals_i.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,55 +76,41 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- i -

diff --git a/globals_l.html b/globals_l.html index 4eebe71e..9e88b4aa 100644 --- a/globals_l.html +++ b/globals_l.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,34 +76,33 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- l -

diff --git a/globals_m.html b/globals_m.html index 6a60c261..094ddba4 100644 --- a/globals_m.html +++ b/globals_m.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,46 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- m -

diff --git a/globals_o.html b/globals_o.html index dba13504..6013b44f 100644 --- a/globals_o.html +++ b/globals_o.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,25 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- o -

diff --git a/globals_p.html b/globals_p.html index 5ed43bc5..4aaca531 100644 --- a/globals_p.html +++ b/globals_p.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- p -

diff --git a/globals_q.html b/globals_q.html index 69e00441..527be752 100644 --- a/globals_q.html +++ b/globals_q.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,32 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- q -

diff --git a/globals_r.html b/globals_r.html index 00734fed..7e4a9039 100644 --- a/globals_r.html +++ b/globals_r.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,40 +76,35 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- r -

diff --git a/globals_s.html b/globals_s.html index 56b0278c..f7fd8f13 100644 --- a/globals_s.html +++ b/globals_s.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- s -

diff --git a/globals_u.html b/globals_u.html index e4da5fb7..a33540d7 100644 --- a/globals_u.html +++ b/globals_u.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,49 +76,38 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- u -

diff --git a/globals_v.html b/globals_v.html index 6a7c6556..d126933d 100644 --- a/globals_v.html +++ b/globals_v.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,25 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- v -

diff --git a/globals_w.html b/globals_w.html index ded24031..39526197 100644 --- a/globals_w.html +++ b/globals_w.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,445 +76,171 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- w -

diff --git a/globals_x.html b/globals_x.html index 96779173..bf4c4512 100644 --- a/globals_x.html +++ b/globals_x.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Globals @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,31 +76,32 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
-

- x -

diff --git a/gtbits_8f.html b/gtbits_8f.html index 5cfd3638..379c9ffa 100644 --- a/gtbits_8f.html +++ b/gtbits_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gtbits.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
gtbits.f File Reference
+
gtbits.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

The number of bits required to pack a given field.

@@ -107,8 +113,8 @@

Definition in file gtbits.f.

Function/Subroutine Documentation

- -

◆ gtbits()

+ +

◆ gtbits()

@@ -117,55 +123,55 @@

subroutine gtbits (   - IBM, + ibm,   - IDS, + ids,   - LEN, + len, dimension(len)  - MG, + mg, dimension(len)  - G, + g, dimension(len)  - GROUND, + ground,   - GMIN, + gmin,   - GMAX, + gmax,   - NBIT  + nbit  @@ -207,7 +213,7 @@

diff --git a/gtbits_8f.js b/gtbits_8f.js index c278be66..99074a62 100644 --- a/gtbits_8f.js +++ b/gtbits_8f.js @@ -1,4 +1,4 @@ var gtbits_8f = [ - [ "gtbits", "gtbits_8f.html#a31c0ebc8937002fb7b104298f8c439ec", null ] + [ "gtbits", "gtbits_8f.html#a0f90e24d4c196fe0bdf31f938110c704", null ] ]; \ No newline at end of file diff --git a/gtbits_8f_source.html b/gtbits_8f_source.html index bcc79268..64acee7b 100644 --- a/gtbits_8f_source.html +++ b/gtbits_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: gtbits.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,97 +81,105 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
gtbits.f
+
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
-
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
-
isrchne
function isrchne(N, X, INCX, TARGET)
Program history log:
Definition: isrchne.f:21
+Go to the documentation of this file.
1C> @file
+
2C> @brief The number of bits required to pack a given field.
+
3C> @author Mark Iredell @date 1992-10-31
+
4
+
5C> The number of bits required to pack a given field
+
6c> at a particular decimal scaling is computed using the field range.
+
7C> The field is rounded off to the decimal scaling for packing.
+
8C> The minimum and maximum rounded field values are also returned.
+
9C> Grib bitmap masking for valid data is optionally used.
+
10C>
+
11C> Program history log:
+
12C> - Mark Iredell 1992-10-31
+
13C>
+
14C> @param[in] ibm integer bitmap flag (=0 for no bitmap).
+
15c> @param[in] ids integer decimal scaling
+
16c> (e.g. ids=3 to round field to nearest milli-value).
+
17c> @param[in] len integer length of the field and bitmap.
+
18c> @param[in] mg integer (len) bitmap if ibm=1 (0 to skip, 1 to keep).
+
19c> @param[in] g real (len) field.
+
20c> @param[out] ground real (len) field rounded to decimal scaling
+
21c> (set to zero where bitmap is 0 if ibm=1).
+
22c> @param[out] gmin real minimum valid rounded field value.
+
23c> @param[out] gmax real maximum valid rounded field value.
+
24c> @param[out] nbit integer number of bits to pack.
+
25C>
+
26C> @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)
+
29C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
30C 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
+
67C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
68C COMPUTE NUMBER OF BITS
+
69 nbit=log((gmax-gmin)*ds+0.9)/log(2.)+1.
+
70C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
71 RETURN
+
+
72 END
+
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
+
isrchne
function isrchne(n, x, incx, target)
Program history log:
Definition isrchne.f:21
diff --git a/idsdef_8f.html b/idsdef_8f.html index c7fd582c..cbfc30e0 100644 --- a/idsdef_8f.html +++ b/idsdef_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: idsdef.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
idsdef.f File Reference
+
idsdef.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

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

Detailed Description

Sets decimal scalings defaults for various parameters.

@@ -107,8 +113,8 @@

Definition in file idsdef.f.

Function/Subroutine Documentation

- -

◆ idsdef()

+ +

◆ idsdef()

@@ -117,13 +123,13 @@

subroutine idsdef (   - IPTV, + iptv, dimension(255)  - IDS  + ids  @@ -158,7 +164,7 @@

diff --git a/idsdef_8f.js b/idsdef_8f.js index 53ade0cd..6ae3d335 100644 --- a/idsdef_8f.js +++ b/idsdef_8f.js @@ -1,4 +1,4 @@ var idsdef_8f = [ - [ "idsdef", "idsdef_8f.html#a55d6afd1ffb535e0b76701cd33c997e3", null ] + [ "idsdef", "idsdef_8f.html#af116d5532c9d7b1e288ff59b1e75800c", null ] ]; \ No newline at end of file diff --git a/idsdef_8f_source.html b/idsdef_8f_source.html index 0b063407..081c7d6e 100644 --- a/idsdef_8f_source.html +++ b/idsdef_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: idsdef.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,302 +81,310 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
idsdef.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Sets decimal scalings defaults for various parameters.
+
3C> @author Mark Iredell @date 1992-10-31
+
4
+
5C> Sets decimal scalings defaults for various parameters.
+
6C> A decimal scaling of -3 means data is packed in kilo-si units.
+
7C>
+
8C> Program history log:
+
9C> - Mark Iredell 1992-10-31
+
10C>
+
11C> @param[in] IPTV parameter table version (only 1 or 2 is recognized).
+
12C> @param[out] IDS integer (255) decimal scalings
+
13C> (unknown decimal scalings will not be set).
+
14C>
+
15C> @author Mark Iredell @date 1992-10-31
+
+
16 SUBROUTINE idsdef(IPTV,IDS)
+
17 dimension ids(255)
+
18C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
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
+
276C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
277 RETURN
+
+
278 END
+
idsdef
subroutine idsdef(iptv, ids)
Sets decimal scalings defaults for various parameters.
Definition idsdef.f:17
diff --git a/index.html b/index.html index 0a32f954..c1721bf5 100644 --- a/index.html +++ b/index.html @@ -1,11 +1,11 @@ - + - - + + -NCEPLIBS-w3emc: Main Page +NCEPLIBS-w3emc: NCEPLIBS-w3emc @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,35 +76,211 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
-
NCEPLIBS-w3emc Documentation
+
+
NCEPLIBS-w3emc
-

-NCEPLIBS-w3emc

-

-Documentation for Previous Versions

+

Documentation for Previous Versions

+

+Introduction

+

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

+

This library also contains a module mersenne_twister, a random number generator that uses the Mersenne twister (aka MT19937).

+

+GRIB1 Parameters

+

-Introduction

-

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

+Reading GRIB1 Files + +

+Packing and Writing GRIB1 Files

+ +

+Product Definition Section

+ +

+Grid Description Section

+ +

+WMO Headers

+ +

+Reading Formats

+ +

+Index Files for GRIB1 Files

+

The NCEPLIBS-w3emc library supports index files which contain the byte-offsets of a GRIB1 file. Index files can improve performance when reading large GRIB files.

+

The following subroutines work with index file:

+

+Bit and Byte Manipulation

+

The following functions manipulate bits and bytes to pack or unpack a GRIB1 message:

+

+Date/Time

+ +

+Sorting

+ +

+Error Handling

+

The following subroutines are used for error handling:

+

+Command Line Arguments

+ +

+Code Instrumentation

+

Code instrumentation is supported with instrument() and summary.c. See also:

+

+Dummy Subroutines

+

Some legacy dummy subroutines are in xdopen.f. See also w3log()*.

+

+Conversions

+ +

+Coordinates

+ +

+Office-Note 85 Subroutines

+ +

+9-Point Smoother

+ +

+Printing

+ +

+Transformation

+ +

*Deprecated subroutines. Build with -DBUILD_DEPRECATED=ON to compile these.

+

+Documentation for Previous Versions

+
diff --git a/instrument_8f.html b/instrument_8f.html index 80cbf7ae..1ab52f0e 100644 --- a/instrument_8f.html +++ b/instrument_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: instrument.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
instrument.f File Reference
+
instrument.f File Reference
@@ -94,11 +100,11 @@

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...
 
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.
 

Detailed Description

Monitor wall-clock times, etc.

@@ -107,8 +113,8 @@

Definition in file instrument.f.

Function/Subroutine Documentation

- -

◆ instrument()

+ +

◆ instrument()

@@ -117,31 +123,31 @@

subroutine instrument ( integer, intent(in)  - K, + k, integer, intent(out)  - KALL, + kall, real, intent(out)  - TTOT, + ttot, real, intent(out)  - TMIN, + tmin, real, intent(out)  - TMAX  + tmax  @@ -182,7 +188,7 @@

Author
Mark Iredell
Date
1998-07-16
-

Definition at line 47 of file instrument.f.

+

Definition at line 46 of file instrument.f.

@@ -192,7 +198,7 @@

diff --git a/instrument_8f.js b/instrument_8f.js index 5e182f96..092ba69f 100644 --- a/instrument_8f.js +++ b/instrument_8f.js @@ -1,4 +1,4 @@ var instrument_8f = [ - [ "instrument", "instrument_8f.html#a1bf5314dfe3e0adf03773a63dadf6173", null ] + [ "instrument", "instrument_8f.html#a9e01b91f60a070be2a253f818d3d9732", null ] ]; \ No newline at end of file diff --git a/instrument_8f_source.html b/instrument_8f_source.html index e0260395..59c6cec0 100644 --- a/instrument_8f_source.html +++ b/instrument_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: instrument.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,99 +81,107 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
instrument.f
+
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
-
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
-
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
+Go to the documentation of this file.
1
+
4
+
+
46 SUBROUTINE instrument(K,KALL,TTOT,TMIN,TMAX)
+
47 IMPLICIT NONE
+
48 INTEGER,INTENT(IN):: K
+
49 INTEGER,INTENT(OUT):: KALL
+
50 REAL,INTENT(OUT):: TTOT,TMIN,TMAX
+
51 INTEGER,SAVE:: KMAX=0
+
52 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE:: KALLS
+
53 REAL,DIMENSION(:),ALLOCATABLE,SAVE:: TTOTS,TMINS,TMAXS
+
54 INTEGER,DIMENSION(8),SAVE:: IDAT
+
55 INTEGER,DIMENSION(8):: JDAT
+
56 REAL,DIMENSION(5):: RINC
+
57 INTEGER:: KA
+
58! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
59 ka=abs(k)
+
60! ALLOCATE MONITORING ARRAYS IF INITIAL INVOCATION
+
61 IF(kmax.EQ.0) THEN
+
62 kmax=k
+
63 ALLOCATE(kalls(kmax))
+
64 ALLOCATE(ttots(kmax))
+
65 ALLOCATE(tmins(kmax))
+
66 ALLOCATE(tmaxs(kmax))
+
67 kalls=0
+
68 ka=0
+
69! OR RESET ALL STATISTICS BACK TO ZERO
+
70 ELSEIF(k.EQ.0) THEN
+
71 kalls=0
+
72! OR COUNT TIME SINCE LAST INVOCATION AGAINST THIS SECTION
+
73 ELSEIF(k.GT.0) THEN
+
74 CALL w3utcdat(jdat)
+
75 CALL w3difdat(jdat,idat,4,rinc)
+
76 kalls(k)=kalls(k)+1
+
77 IF(kalls(k).EQ.1) THEN
+
78 ttots(k)=rinc(4)
+
79 tmins(k)=rinc(4)
+
80 tmaxs(k)=rinc(4)
+
81 ELSE
+
82 ttots(k)=ttots(k)+rinc(4)
+
83 tmins(k)=min(tmins(k),rinc(4))
+
84 tmaxs(k)=max(tmaxs(k),rinc(4))
+
85 ENDIF
+
86 ENDIF
+
87! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
88! RETURN STATISTICS
+
89
+
90! FRIMEL and KALINA, DECOMPOSE THE IF STATEMENT, SAFER FOR SOME
+
91! COMPILERS. Since No Guarantee on order of evaluation, and when
+
92! evaluation will stop.
+
93! MAKE SURE KA.GE.1 BEFORE TESTING IF KALLS(KA).GT.0, ELSE
+
94! MAY ENCOUNTER A RUNTIME SIGSEGV SEGEMENTATION FAULT.
+
95! Since Subscript #1 of the array KALLS can have value 0 which
+
96! is less than the lower bound of 1
+
97! IF(KA.GE.1.AND.KA.LE.KMAX.AND.KALLS(KA).GT.0) THEN
+
98
+
99 IF(ka.GE.1.AND.ka.LE.kmax) THEN
+
100 IF(kalls(ka).GT.0) THEN
+
101 kall=kalls(ka)
+
102 ttot=ttots(ka)
+
103 tmin=tmins(ka)
+
104 tmax=tmaxs(ka)
+
105 ENDIF
+
106 IF(kalls(ka).LE.0) THEN
+
107 kall=0
+
108 ttot=0
+
109 tmin=0
+
110 tmax=0
+
111 ENDIF
+
112 END IF
+
113! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
114! KEEP CURRENT TIME FOR NEXT INVOCATION
+
115 IF(k.GE.0) CALL w3utcdat(idat)
+
+
116 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:47
+
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
+
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
diff --git a/interfaceargs__mod_1_1getarg.html b/interfaceargs__mod_1_1getarg.html deleted file mode 100644 index 93be2a30..00000000 --- a/interfaceargs__mod_1_1getarg.html +++ /dev/null @@ -1,117 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: args_mod::getarg Interface Reference - - - - - - - - - - - - - -
-
- - - - - - -
-
NCEPLIBS-w3emc -  2.11.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/interfaceargs__mod_1_1getarg.js b/interfaceargs__mod_1_1getarg.js deleted file mode 100644 index 94b37ca0..00000000 --- a/interfaceargs__mod_1_1getarg.js +++ /dev/null @@ -1,5 +0,0 @@ -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/interfaceargs__mod_1_1iargc.html b/interfaceargs__mod_1_1iargc.html deleted file mode 100644 index 7d1682f8..00000000 --- a/interfaceargs__mod_1_1iargc.html +++ /dev/null @@ -1,114 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: args_mod::iargc Interface Reference - - - - - - - - - - - - - -
-
- - - - - - -
-
NCEPLIBS-w3emc -  2.11.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/interfaceargs__mod_1_1iargc.js b/interfaceargs__mod_1_1iargc.js deleted file mode 100644 index 169cb099..00000000 --- a/interfaceargs__mod_1_1iargc.js +++ /dev/null @@ -1,4 +0,0 @@ -var interfaceargs__mod_1_1iargc = -[ - [ "iargc_8", "interfaceargs__mod_1_1iargc.html#af4538b3ec9b539460c2490f71df060c9", null ] -]; \ No newline at end of file diff --git a/interfacemersenne__twister_1_1random__gauss.html b/interfacemersenne__twister_1_1random__gauss.html new file mode 100644 index 00000000..c25878be --- /dev/null +++ b/interfacemersenne__twister_1_1random__gauss.html @@ -0,0 +1,239 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister::random_gauss Interface Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
+Public Member Functions
+
mersenne_twister::random_gauss Interface Reference
+
+
+ + + + + + + + + + + +

+Public Member Functions

subroutine random_gauss_i (harvest, inseed)
 Generates Gaussian random numbers in interactive mode.
 
subroutine random_gauss_s (harvest)
 Generates Gaussian random numbers in saved mode.
 
subroutine random_gauss_t (harvest, stat)
 Generates Gaussian random numbers in thread-safe mode.
 
+

Detailed Description

+
+

Definition at line 138 of file mersenne_twister.f.

+

Member Function/Subroutine Documentation

+ +

◆ random_gauss_i()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_gauss::random_gauss_i (real, dimension(:), intent(out) harvest,
integer, intent(in) inseed 
)
+
+ +

Generates Gaussian random numbers in interactive mode.

+
Parameters
+ + + +
[out]harvestReal(:) numbers output.
[in]inseedInteger seed input.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 348 of file mersenne_twister.f.

+ +
+
+ +

◆ random_gauss_s()

+ +
+
+ + + + + + + + +
subroutine mersenne_twister::random_gauss::random_gauss_s (real, dimension(:), intent(out) harvest)
+
+ +

Generates Gaussian random numbers in saved mode.

+
Parameters
+ + +
[out]harvestReal(:) numbers output.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 361 of file mersenne_twister.f.

+ +
+
+ +

◆ random_gauss_t()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_gauss::random_gauss_t (real, dimension(:), intent(out) harvest,
type(random_stat), intent(inout) stat 
)
+
+ +

Generates Gaussian random numbers in thread-safe mode.

+
Parameters
+ + + +
[out]harvestReal(:) numbers output.
[in,out]statType(random_stat) input.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 373 of file mersenne_twister.f.

+ +
+
+
The documentation for this interface was generated from the following file: +
+
+ + + + diff --git a/interfacemersenne__twister_1_1random__gauss.js b/interfacemersenne__twister_1_1random__gauss.js new file mode 100644 index 00000000..2914e56f --- /dev/null +++ b/interfacemersenne__twister_1_1random__gauss.js @@ -0,0 +1,6 @@ +var interfacemersenne__twister_1_1random__gauss = +[ + [ "random_gauss_i", "interfacemersenne__twister_1_1random__gauss.html#a2ab29e2f6e4efe8ffd858ff257747173", null ], + [ "random_gauss_s", "interfacemersenne__twister_1_1random__gauss.html#a50af58f1f0525f0d68b14e6362305b1c", null ], + [ "random_gauss_t", "interfacemersenne__twister_1_1random__gauss.html#afea5a15176c49f9829db24f555692278", null ] +]; \ No newline at end of file diff --git a/interfacemersenne__twister_1_1random__index.html b/interfacemersenne__twister_1_1random__index.html new file mode 100644 index 00000000..e256bf0b --- /dev/null +++ b/interfacemersenne__twister_1_1random__index.html @@ -0,0 +1,264 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister::random_index Interface Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
+Public Member Functions
+
mersenne_twister::random_index Interface Reference
+
+
+ + + + + + + + + + + +

+Public Member Functions

subroutine random_index_i (imax, iharvest, inseed)
 Generates random indices in interactive mode.
 
subroutine random_index_s (imax, iharvest)
 Generates random indices in saved mode.
 
subroutine random_index_t (imax, iharvest, stat)
 Generates random indices in thread-safe mode.
 
+

Detailed Description

+
+

Definition at line 143 of file mersenne_twister.f.

+

Member Function/Subroutine Documentation

+ +

◆ random_index_i()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_index::random_index_i (integer, intent(in) imax,
integer, dimension(:), intent(out) iharvest,
integer, intent(in) inseed 
)
+
+ +

Generates random indices in interactive mode.

+
Parameters
+ + + + +
[in]imaxInteger maximum index input.
[out]iharvestInteger(:) numbers output.
[in]inseedInteger seed input.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 456 of file mersenne_twister.f.

+ +
+
+ +

◆ random_index_s()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_index::random_index_s (integer, intent(in) imax,
integer, dimension(:), intent(out) iharvest 
)
+
+ +

Generates random indices in saved mode.

+
Parameters
+ + + +
[in]imaxInteger maximum index input.
[out]iharvestInteger(:) numbers output.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 471 of file mersenne_twister.f.

+ +
+
+ +

◆ random_index_t()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_index::random_index_t (integer, intent(in) imax,
integer, dimension(:), intent(out) iharvest,
type(random_stat), intent(inout) stat 
)
+
+ +

Generates random indices in thread-safe mode.

+
Parameters
+ + + + +
[in]imaxInteger maximum index input.
[out]iharvestInteger(:) numbers output.
[in,out]statType(random_stat) input.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 485 of file mersenne_twister.f.

+ +
+
+
The documentation for this interface was generated from the following file: +
+
+ + + + diff --git a/interfacemersenne__twister_1_1random__index.js b/interfacemersenne__twister_1_1random__index.js new file mode 100644 index 00000000..8290f580 --- /dev/null +++ b/interfacemersenne__twister_1_1random__index.js @@ -0,0 +1,6 @@ +var interfacemersenne__twister_1_1random__index = +[ + [ "random_index_i", "interfacemersenne__twister_1_1random__index.html#adb086879ee9eabb64d4026daacf40567", null ], + [ "random_index_s", "interfacemersenne__twister_1_1random__index.html#ab4356f122440e3e8eb2eccfd16968c84", null ], + [ "random_index_t", "interfacemersenne__twister_1_1random__index.html#af137b7c612966c256b47c9949f8095ba", null ] +]; \ No newline at end of file diff --git a/interfacemersenne__twister_1_1random__number.html b/interfacemersenne__twister_1_1random__number.html new file mode 100644 index 00000000..32e3e27f --- /dev/null +++ b/interfacemersenne__twister_1_1random__number.html @@ -0,0 +1,239 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister::random_number Interface Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
+Public Member Functions
+
mersenne_twister::random_number Interface Reference
+
+
+ + + + + + + + + + + +

+Public Member Functions

subroutine random_number_i (harvest, inseed)
 Generates random numbers in interactive mode.
 
subroutine random_number_s (harvest)
 Generates random numbers in saved mode; overloads Fortran 90 standard.
 
subroutine random_number_t (harvest, stat)
 Generates random numbers in thread-safe mode.
 
+

Detailed Description

+
+

Definition at line 133 of file mersenne_twister.f.

+

Member Function/Subroutine Documentation

+ +

◆ random_number_i()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_number::random_number_i (real, dimension(:), intent(out) harvest,
integer, intent(in) inseed 
)
+
+ +

Generates random numbers in interactive mode.

+
Parameters
+ + + +
[out]harvestReal(:) numbers output.
[in]inseedInteger seed input.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 264 of file mersenne_twister.f.

+ +
+
+ +

◆ random_number_s()

+ +
+
+ + + + + + + + +
subroutine mersenne_twister::random_number::random_number_s (real, dimension(:), intent(out) harvest)
+
+ +

Generates random numbers in saved mode; overloads Fortran 90 standard.

+
Parameters
+ + +
[out]harvestReal(:) numbers output.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 277 of file mersenne_twister.f.

+ +
+
+ +

◆ random_number_t()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_number::random_number_t (real, dimension(:), intent(out) harvest,
type(random_stat), intent(inout) stat 
)
+
+ +

Generates random numbers in thread-safe mode.

+
Parameters
+ + + +
[out]harvestReal(:) numbers output
[in,out]statType(random_stat) input
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 289 of file mersenne_twister.f.

+ +
+
+
The documentation for this interface was generated from the following file: +
+
+ + + + diff --git a/interfacemersenne__twister_1_1random__number.js b/interfacemersenne__twister_1_1random__number.js new file mode 100644 index 00000000..02737b9d --- /dev/null +++ b/interfacemersenne__twister_1_1random__number.js @@ -0,0 +1,6 @@ +var interfacemersenne__twister_1_1random__number = +[ + [ "random_number_i", "interfacemersenne__twister_1_1random__number.html#a4df934289beedb0e333c1260489949e6", null ], + [ "random_number_s", "interfacemersenne__twister_1_1random__number.html#a94e918a10214cfe0c24c303d220452e7", null ], + [ "random_number_t", "interfacemersenne__twister_1_1random__number.html#a0f53661cf413d88e71aef77a9a9468ae", null ] +]; \ No newline at end of file diff --git a/interfacemersenne__twister_1_1random__setseed.html b/interfacemersenne__twister_1_1random__setseed.html new file mode 100644 index 00000000..ff8e6890 --- /dev/null +++ b/interfacemersenne__twister_1_1random__setseed.html @@ -0,0 +1,195 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister::random_setseed Interface Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
+Public Member Functions
+
mersenne_twister::random_setseed Interface Reference
+
+
+ + + + + + + + +

+Public Member Functions

subroutine random_setseed_s (inseed)
 Sets seed in saved mode.
 
subroutine random_setseed_t (inseed, stat)
 Sets seed in thread-safe mode.
 
+

Detailed Description

+
+

Definition at line 129 of file mersenne_twister.f.

+

Member Function/Subroutine Documentation

+ +

◆ random_setseed_s()

+ +
+
+ + + + + + + + +
subroutine mersenne_twister::random_setseed::random_setseed_s (integer, intent(in) inseed)
+
+ +

Sets seed in saved mode.

+
Parameters
+ + +
[in]inseedInteger seed input.
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 219 of file mersenne_twister.f.

+ +
+
+ +

◆ random_setseed_t()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine mersenne_twister::random_setseed::random_setseed_t (integer, intent(in) inseed,
type(random_stat), intent(out) stat 
)
+
+ +

Sets seed in thread-safe mode.

+
Parameters
+ + + +
[in]inseedInteger seed input
[out]statType(random_stat) output
+
+
+
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 230 of file mersenne_twister.f.

+ +
+
+
The documentation for this interface was generated from the following file: +
+
+ + + + diff --git a/interfacemersenne__twister_1_1random__setseed.js b/interfacemersenne__twister_1_1random__setseed.js new file mode 100644 index 00000000..2fc20fc5 --- /dev/null +++ b/interfacemersenne__twister_1_1random__setseed.js @@ -0,0 +1,5 @@ +var interfacemersenne__twister_1_1random__setseed = +[ + [ "random_setseed_s", "interfacemersenne__twister_1_1random__setseed.html#af25a7d71ddbad282dd5eb407c0bd907d", null ], + [ "random_setseed_t", "interfacemersenne__twister_1_1random__setseed.html#a21dac133ee7db7e53a1161f36efe9d11", null ] +]; \ No newline at end of file diff --git a/isrchne_8f.html b/isrchne_8f.html index de5d6bce..91a270fc 100644 --- a/isrchne_8f.html +++ b/isrchne_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: isrchne.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
isrchne.f File Reference
+
isrchne.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

function isrchne (N, X, INCX, TARGET)
 Program history log: More...
 
function isrchne (n, x, incx, target)
 Program history log:
 

Detailed Description

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

@@ -107,8 +113,8 @@

Definition in file isrchne.f.

Function/Subroutine Documentation

- -

◆ isrchne()

+ +

◆ isrchne()

@@ -117,25 +123,25 @@

function isrchne (   - N, + n, integer, dimension(*)  - X, + x,   - INCX, + incx, integer  - TARGET  + target  @@ -173,7 +179,7 @@

diff --git a/isrchne_8f.js b/isrchne_8f.js index 25f3df0e..fb99ad09 100644 --- a/isrchne_8f.js +++ b/isrchne_8f.js @@ -1,4 +1,4 @@ var isrchne_8f = [ - [ "isrchne", "isrchne_8f.html#aa2ad73a774eaa79cc4134b5a30210c19", null ] + [ "isrchne", "isrchne_8f.html#a53cf06203460280eb4f894b66282b5fd", null ] ]; \ No newline at end of file diff --git a/isrchne_8f_source.html b/isrchne_8f_source.html index 63be2fc0..a9a0ca73 100644 --- a/isrchne_8f_source.html +++ b/isrchne_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: isrchne.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,56 +81,64 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
isrchne.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Searches a vector for the first element not equal to a target
+
3C> @author Stephen Gilbert @date 1999-02-11
+
4
+
5C> Program history log:
+
6C> - Stephen Gilbert 1999-02-11
+
7C>
+
8C> @param[in] n Number of elements to be searched.
+
9C> @param[in] x Real or integer array of dimension (n-1) * |incx| + 1.
+
10C> Array x contains the vector to be searched.
+
11C> @param[in] incx Increment between elements of the searched array.
+
12C> @param[in] target Value for which to search in the array.
+
13C> @return index Index of the first element equal or not equal to target.
+
14C> If target is not found, n+1 is returned. If n <= 0, 0 is returned.
+
15C>
+
16C> @note This code and documentation was taken directly from the
+
17C> man page for routine ISRCHNE on a CRAY UNICOS system.
+
18C>
+
19C> @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/iw3jdn_8f.html b/iw3jdn_8f.html index 6b0c1e68..96c7ee73 100644 --- a/iw3jdn_8f.html +++ b/iw3jdn_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: iw3jdn.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
iw3jdn.f File Reference
+
iw3jdn.f File Reference
@@ -94,11 +100,11 @@

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...
 
function iw3jdn (iyear, month, iday)
 Computes julian day number from year (4 digits), month, and day.
 

Detailed Description

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

@@ -107,8 +113,8 @@

Definition in file iw3jdn.f.

Function/Subroutine Documentation

- -

◆ iw3jdn()

+ +

◆ iw3jdn()

@@ -117,19 +123,19 @@

function iw3jdn (   - IYEAR, + iyear,   - MONTH, + month,   - IDAY  + iday  @@ -172,7 +178,7 @@

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

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

logical function iw3mat (L1, L2, N)
 Program history log: More...
 
logical function iw3mat (l1, l2, n)
 Program history log:
 

Detailed Description

Test n words starting at l1, l2 for equality, return .true.

@@ -107,8 +113,8 @@

Definition in file iw3mat.f.

Function/Subroutine Documentation

- -

◆ iw3mat()

+ +

◆ iw3mat()

@@ -117,19 +123,19 @@

logical function iw3mat ( integer, dimension(*)  - L1, + l1, integer, dimension(*)  - L2, + l2,   - N  + n  @@ -166,7 +172,7 @@

diff --git a/iw3mat_8f.js b/iw3mat_8f.js index e1d1768d..d8c8cea7 100644 --- a/iw3mat_8f.js +++ b/iw3mat_8f.js @@ -1,4 +1,4 @@ var iw3mat_8f = [ - [ "iw3mat", "iw3mat_8f.html#a2fba35a09957d0d2a2e37b8c63e9ef4f", null ] + [ "iw3mat", "iw3mat_8f.html#aa53ca2552f7a06ad9141f16197b82fda", null ] ]; \ No newline at end of file diff --git a/iw3mat_8f_source.html b/iw3mat_8f_source.html index bc097b9f..3f6904a3 100644 --- a/iw3mat_8f_source.html +++ b/iw3mat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: iw3mat.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,55 +81,63 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
iw3mat.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Test n words starting at l1, l2 for equality, return .true.
+
3C> if all equal; otherwise .false.
+
4C> @author J.D. Stackpole @date 1986-01-13
+
5
+
6C> Program history log:
+
7C> - J.D. Stackpole 1986-01-13
+
8C> - Ralph Jones 1990-03-15 Convert to cray cft77 fortran.
+
9C>
+
10C> @param[in] L1 Integer array to match with l2.
+
11C> @param[in] L2 Integer array to match with l1.
+
12C> @param[in] N Number of integer words to test for match.
+
13C> @return IW3MAT Logical .true. if l1 and l2 match on all words,
+
14C> logical .false. if not match on any word.
+
15C>
+
16C> @author J.D. Stackpole @date 1986-01-13
+
+
17 LOGICAL FUNCTION iw3mat(L1, L2, N)
+
18C
+
19 INTEGER l1(*)
+
20 INTEGER l2(*)
+
21C
+
22 iw3mat = .true.
+
23 DO 10 i = 1,n
+
24 IF (l1(i).NE.l2(i)) GO TO 20
+
25 10 CONTINUE
+
26 RETURN
+
27C
+
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/iw3pds_8f.html b/iw3pds_8f.html index 8c16a86a..5ad12ce1 100644 --- a/iw3pds_8f.html +++ b/iw3pds_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: iw3pds.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
iw3pds.f File Reference
+
iw3pds.f File Reference
@@ -94,17 +100,53 @@

Go to the source code of this file.

- - - + + +

+

Functions/Subroutines

-logical function iw3pds (L1, L2, KEY)
 
logical function iw3pds (l1, l2, key)
 Test two pds (grib product definition section) to see if all equal; otherwise .false.
 

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.

+
Date
1988-02-22
+ +

Definition in file iw3pds.f.

+

Function/Subroutine Documentation

+ +

◆ iw3pds()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
logical function iw3pds (character*1, dimension(24) l1,
character*1, dimension(24) l2,
 key 
)
+
+ +

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.
    • @@ -120,23 +162,28 @@ [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
      • +
    • 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).
    +
    Returns
    logical .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).
    +
    Author
    Ralph Jones
    +
    Date
    1988-02-22
    -

    Definition in file iw3pds.f.

    -
+

Definition at line 42 of file iw3pds.f.

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

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 ()
character *6 function c01o29 (subset)
 This function read subset and returns group name.
 
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 i01o29 (lunit, hdr, ier)
 This function read obs files and returns error message.
 
function i02o29 (lunit, obs, ier)
 This function read obs files and returns error message.
 
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.
 
function i04o29 (p)
 
function i05o29 (string, num, char)
 This function finds the location of the next numeric character in a string of characters.
 
function iw3unp29 (lunit, obs, ier)
 This routine has not been tested reading input data from any dump type in ON29/124 format on WCOSS.
 
logical function l01o29 ()
 
function r01o29 (SUBSET, LUNIT, OBS)
 This function read subset and returns corresponding file data. More...
 
-function r02o29 ()
function r01o29 (subset, lunit, obs)
 This function read subset and returns corresponding file data.
 
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
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 s05o29
 
subroutine s06o29 (IDEN, ID)
 This subrountine modifies amdar reports so that last character ends with 'Z'. More...
 
subroutine s06o29 (iden, id)
 This subrountine modifies amdar reports so that last character ends with 'Z'.
 

Detailed Description

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

@@ -170,8 +162,8 @@

Definition in file iw3unp29.f.

Function/Subroutine Documentation

- -

◆ c01o29()

+ +

◆ c01o29()

@@ -180,7 +172,7 @@

character*6 function c01o29 ( character*(*)  - SUBSET) + subset) @@ -201,8 +193,24 @@

-

◆ i01o29()

+ +

◆ c02o29()

+ +
+
+ + + + +
character*8 function c02o29
+
+ +

Definition at line 2021 of file iw3unp29.f.

+ +
+
+ +

◆ i01o29()

@@ -211,19 +219,19 @@

function i01o29 (   - LUNIT, + lunit, dimension(*)  - HDR, + hdr,   - IER  + ier  @@ -250,8 +258,8 @@

-

◆ i02o29()

+ +

◆ i02o29()

@@ -260,19 +268,19 @@

function i02o29 (   - LUNIT, + lunit, dimension(1608)  - OBS, + obs,   - IER  + ier  @@ -299,8 +307,8 @@

-

◆ i03o29()

+ +

◆ i03o29()

@@ -309,19 +317,19 @@

function i03o29 (   - NUNIT, + nunit, integer, dimension(*)  - OBS, + obs,   - IER  + ier  @@ -358,8 +366,28 @@

-

◆ i05o29()

+ +

◆ i04o29()

+ +
+
+ + + + + + + + +
function i04o29 ( p)
+
+ +

Definition at line 1603 of file iw3unp29.f.

+ +
+
+ +

◆ i05o29()

@@ -368,19 +396,19 @@

function i05o29 ( character*1, dimension(1)  - STRING, + string,   - NUM, + num, character*1  - CHAR  + char  @@ -407,8 +435,8 @@

-

◆ iw3unp29()

+ +

◆ iw3unp29()

@@ -417,19 +445,19 @@

function iw3unp29 (   - LUNIT, + lunit, dimension(*)  - OBS, + obs,   - IER  + ier  @@ -534,8 +562,24 @@

-

◆ r01o29()

+ +

◆ l01o29()

+ +
+
+ + + + +
logical function l01o29
+
+ +

Definition at line 2065 of file iw3unp29.f.

+ +
+
+ +

◆ r01o29()

@@ -544,19 +588,19 @@

function r01o29 ( character*(*)  - SUBSET, + subset,   - LUNIT, + lunit, dimension(*)  - OBS  + obs  @@ -583,8 +627,344 @@

-

◆ s06o29()

+ +

◆ r02o29()

+ +
+
+ + + + +
function r02o29
+
+ +

Definition at line 1651 of file iw3unp29.f.

+ +
+
+ +

◆ r03o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
function r03o29 ( lunit,
dimension(*) obs 
)
+
+ +

Definition at line 2092 of file iw3unp29.f.

+ +
+
+ +

◆ r04o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
function r04o29 ( lunit,
dimension(*) obs 
)
+
+ +

Definition at line 2897 of file iw3unp29.f.

+ +
+
+ +

◆ r05o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
function r05o29 ( lunit,
dimension(*) obs 
)
+
+ +

Definition at line 3369 of file iw3unp29.f.

+ +
+
+ +

◆ r06o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
function r06o29 ( lunit,
dimension(*) obs 
)
+
+ +

Definition at line 3871 of file iw3unp29.f.

+ +
+
+ +

◆ r07o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
function r07o29 ( lunit,
dimension(*) obs 
)
+
+ +

Definition at line 4156 of file iw3unp29.f.

+ +
+
+ +

◆ s01o29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine s01o29 (character*8 sid,
 xob,
 yob,
 rhr,
 rch,
character*(*) rsv,
character*(*) rsv2,
 elv,
 itp,
 rtp 
)
+
+ +

Definition at line 1008 of file iw3unp29.f.

+ +
+
+ +

◆ s02o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine s02o29 ( icat,
 n 
)
+
+ +

Definition at line 1106 of file iw3unp29.f.

+ +
+
+ +

◆ s03o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine s03o29 (dimension(*) unp,
character*8 subset 
)
+
+ +

Definition at line 1382 of file iw3unp29.f.

+ +
+
+ +

◆ s04o29()

+ +
+
+ + + + +
subroutine s04o29
+
+ +

Definition at line 1455 of file iw3unp29.f.

+ +
+
+ +

◆ s05o29()

+ +
+
+ + + + +
subroutine s05o29
+
+ +

Definition at line 1575 of file iw3unp29.f.

+ +
+
+ +

◆ s06o29()

@@ -593,13 +973,13 @@

subroutine s06o29 ( character*8  - IDEN, + iden, character*8  - ID  + id  @@ -630,7 +1010,7 @@

diff --git a/iw3unp29_8f.js b/iw3unp29_8f.js index dfec93ac..64d5d920 100644 --- a/iw3unp29_8f.js +++ b/iw3unp29_8f.js @@ -1,25 +1,11 @@ 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 ] + [ "c01o29", "iw3unp29_8f.html#a8f442c71c59f776fbf89cfed665f90a4", null ], + [ "i01o29", "iw3unp29_8f.html#a687b1ecdce871d1cf438f4fb2be95425", null ], + [ "i02o29", "iw3unp29_8f.html#a83aa538c2e5a51c40a981974247d82c7", null ], + [ "i03o29", "iw3unp29_8f.html#a291446927c470179df611e56fbc0ff6f", null ], + [ "i05o29", "iw3unp29_8f.html#a5cb8ae5d00bc1141f789b08555083739", null ], + [ "iw3unp29", "iw3unp29_8f.html#a79f04733a38667022a957e6c1b9093b6", null ], + [ "r01o29", "iw3unp29_8f.html#af86e22354050944e4507e85c314114a0", null ], + [ "s06o29", "iw3unp29_8f.html#aaa7ab7bf0bec88768b0fcb9921f07ff1", null ] ]; \ No newline at end of file diff --git a/iw3unp29_8f_source.html b/iw3unp29_8f_source.html index a2b1c73e..f810f6b6 100644 --- a/iw3unp29_8f_source.html +++ b/iw3unp29_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: iw3unp29.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,4636 +81,4658 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
iw3unp29.f
+
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
-
i01o29
function i01o29(LUNIT, HDR, IER)
This function read obs files and returns error message.
Definition: iw3unp29.f:477
-
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
-
s06o29
subroutine s06o29(IDEN, ID)
This subrountine modifies amdar reports so that last character ends with 'Z'.
Definition: iw3unp29.f:4482
-
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
-
c01o29
character *6 function c01o29(SUBSET)
This function read subset and returns group name.
Definition: iw3unp29.f:930
-
i02o29
function i02o29(LUNIT, OBS, IER)
This function read obs files and returns error message.
Definition: iw3unp29.f:546
-
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
-
r01o29
function r01o29(SUBSET, LUNIT, OBS)
This function read subset and returns corresponding file data.
Definition: iw3unp29.f:982
-
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
-
w3fa03
subroutine w3fa03(PRESS, HEIGHT, TEMP, THETA)
Computes the standard height, temperature, and potential temperature given the pressure in millibars ...
Definition: w3fa03.f:28
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Reads and unpacks one report into the unpacked office note
+
3C> 29/124 format
+
4C> @author Dennis Keyser @date 2013-03-20
+
5
+
6C> This routine has not been tested reading input data from any dump
+
7C> type in ON29/124 format on WCOSS. It likely will not work when
+
8C> attempting to read ON29/124 format dumps on WCOSS. It has also
+
9C> not been tested reading any dump file other than ADPUPA (BUFR
+
10C> input only) on WCOSS. It does work reading BUFR ADPUPA dump files
+
11C> on WCOSS. It will hopefully working reading other BUFR (only)
+
12C> dump files on WCOSS. Also, this routine is only known to work correctly
+
13C> when compiled using 8 byte machine words (real and integer).
+
14C>
+
15C> Reads and unpacks one report into the unpacked office note
+
16C> 29/124 format. The input data may be packed into either bufr or
+
17C> true on29/124 format with a y2k compliant pseudo-on85 header label.
+
18C> (Note: as a temporary measure, this code will still operate on a
+
19C> true on29/124 format file with a non-y2k compliant on85 header
+
20C> label. The code will use the "windowing" technique to obtain a
+
21C> 4-digit year.) This routine will determine the format of the
+
22C> input data and take the appropriate action. It returns the
+
23C> unpacked report to the calling program in the array 'obs'.
+
24C> Various contingencies are covered by return value of the function
+
25C> and parameter 'ier' - function and ier have same value. Repeated
+
26C> calls of function will return a sequence of unpacked on29/124
+
27C> reports. The calling program may switch to a new 'nunit' at any
+
28C> time, that dataset will then be read in sequence. If user
+
29C> switches back to a previous 'nunit', that data set will be read
+
30C> from the beginning, not from where the user left off (this is a
+
31C> 'software tool', not an entire i/o system).
+
32C>
+
33C> Program history log:
+
34C> - Jack Woollen 1996-12-13 (gsc) Note this new
+
35C> version of iw3gad incorporates the earlier version which
+
36C> was written by j. stackpole and dealt only with true
+
37C> on29/124 data as input - this option is still available
+
38C> but is a small part of the new routine which was written
+
39C> from scratch to read in bufr data.
+
40C> - Dennis Keyser 1997-01-27 Changes to more closely duplicate format
+
41C> obtained when reading from true on29/124 data sets.
+
42C> - Dennis Keyser 1997-02-04 Drops with missing stnid get stnid set to
+
43C> "drp88a"; satwnds with zero pressure are tossed.
+
44C> - Dennis Keyser 1997-02-12 To get around the 3-bit limitation to
+
45C> the on29 pressure q.m. mnemonic "qmpr", an sdmedit/quips
+
46C> purge or reject flag on pressure is changed from 12 or 14
+
47C> to 6 in order to fit into 3-bits, see function e35o29;
+
48C> interprets sdmedit and quips purge/keep/change flags
+
49C> properly for all data types; can now process cat. 6 and
+
50C> cat. 2/3 type flight-level reccos (before skipped these);
+
51C> tests for missing lat, lon, obtime decoded from bufr and
+
52C> retains missing value on these in unpacked on29/124
+
53C> format (before no missing check, led to possible non-
+
54C> missing but incorrect values for these); the check for
+
55C> drops with missing stnid removed since decoder fixed for
+
56C> this.
+
57C> - Dennis Keyser 1997-05-01 Looks for duplicate levels when
+
58C> processing on29 cat. 2, 3, and 4 (in all data on level)
+
59C> and removes duplicate level; in processing on29 cat. 3
+
60C> levels, removes all levels where wind is missing; fixed
+
61C> bug in aircraft (airep/pirep/amdar) quality mark
+
62C> assignment (was not assigning keep flag to report if
+
63C> pressure had a keep q.m. but temperature q.m. was
+
64C> missing).
+
65C> - Dennis Keyser 1997-05-30 For aircft: (only acars right now) -
+
66C> seconds are decoded (if avail.) and used to obtain
+
67C> report time; only asdar/amdar - new cat. 8 code figs.
+
68C> o-put 917 (char. 1 & 2 of actual stnid), 918 (char. 3 &
+
69C> 4 of actual stnid), 919 (char. 5 & 6 of actual stnid);
+
70C> asdar/amdar and acars - new cat. 8 code fig. o-put 920
+
71C> (char. 7 & 8 of actual stnid); only acars - new cat. 8
+
72C> code fig. o-put 921 (report time to nearest 1000'th of
+
73C> an hour); only some acars - new mnemonic "ialt" now
+
74C> exists and can (if line not commented out) be used to
+
75C> obtain unpacked on29 cat. 6.
+
76C> - Dennis Keyser 1997-07-02 Removed filtering of aircraft data as
+
77C> follows: air france amdars no longer filtered, amdar/
+
78C> asdar below 7500 ft. no longer filtered, airep/pirep
+
79C> below 100 meters no longer filtered, all aircraft with
+
80C> missing wind but valid temperature are no longer
+
81C> filtered; reprocesses u.s. satwnd stn. ids to conform
+
82C> with previous on29 appearance except now 8-char (tag
+
83C> char. 1 & 6 not changed from bufr stn. id) - never any
+
84C> dupl. ids now for u.s. satwnds decoded from a single
+
85C> bufr file; streamlined/eliminated some do loops to
+
86C> speed up a bit.
+
87C> - Dennis Keyser 1997-09-18 Corrected errors in reformatting surface
+
88C> data into unpacked on124, specifically-header: inst. type
+
89C> (synoptic fmt flg, auto stn. type, converted hrly flg),
+
90C> indicators (precip., wind speed, wx/auto stn), cat51:
+
91C> p-tend, horiz. viz., present/past wx, cloud info, max/
+
92C> min temp, cat52: precip., snow dpth, wave info, ship
+
93C> course/speed, cat8: code figs. 81-85,98; corrected
+
94C> problem which coded upper-air mandatory level winds
+
95C> as cat. 3 instead of cat. 1 when mass data (only) was
+
96C> reported on same mandatory level in a separate reported
+
97C> level in the raw bulletin.
+
98C> - Dennis Keyser 1997-10-06 Updated logic to read and process nesdis
+
99C> hi-density satellite winds properly.
+
100C> - Dennis Keyser 1997-10-30 Added gross check on u-air pressure, all
+
101C> levels with reported pressure .le. zero now tossed; sfc
+
102C> cat. 52 sea-sfc temperature now read from hierarchy of
+
103C> sst in bufr {1st choice - hi-res sst ('sst2'), 2nd
+
104C> choice - lo-res sst ('sst1'), 3rd choice - sea temp
+
105C> ('stmp')}, before only read 'sst1'.
+
106C> - Dennis Keyser 1998-01-26 Changed pqm processing for adpupa types
+
107C> such that sdmedit flags are now honored (before, pqm
+
108C> was always hardwired to 2 for adpupa types); bumped
+
109C> limit for number of levels that can be processed from
+
110C> 100 to 150 and added diagnostic print when the limit
+
111C> is exceeded.
+
112C> - Dennis Keyser 1998-05-19 Y2k compliant version of iw3gad routine
+
113C> accomplished by redefining original 32-character on85
+
114C> header label to be a 40-character label that contains a
+
115C> full 4-digit year, can still read "true" on29/124 data
+
116C> sets provided their header label is in this modified
+
117C> form.
+
118C> - Dennis Keyser 1998-07-22 Minor modifications to account for
+
119C> corrections in y2k/f90 bufrlib (mainly related to
+
120C> bufrlib routine dumpbf).
+
121C> - Dennis Keyser 1998-08-04 Fixed a bug that resulted in code being
+
122C> clobbered in certain situations for recco reports; minor
+
123C> modifications to give same answers on cray as on sgi;
+
124C> allowed code to read true on29/124 files with non-y2k
+
125C> compliant on85 label (a temporary measure during
+
126C> transition of main programs to y2k); added call to "aea"
+
127C> which converts ebcdic characters to ascii for input
+
128C> true on29/124 data set processing of sgi (which does
+
129C> not support "-cebcdic" in assign statement).
+
130C> - Dennis Keyser 1999-02-25 Added ability to read reprocessed ssm/i
+
131C> bufr data set (spssmi); added ability to read mean
+
132C> sea-level pressure bogus (paobs) data set (sfcbog).
+
133C> - Dennis Keyser 1999-05-14 Made changes necessary to port this
+
134C> routine to the ibm sp.
+
135C> - Dennis Keyser 1999-06-18 Can now process water vapor satwnds
+
136C> from foreign producers; stn. id for foreign satwnds
+
137C> now reprocessed in same way as for nesdis/goes satwnds,
+
138C> character 1 of stn. id now defines even vs. odd
+
139C> satellite while character 6 of stn. id now defines
+
140C> ir cloud-drft vs. visible cloud drft vs. water vapor.
+
141C> - Dennis Keyser 2002-03-05 Removed entry "e02o29", now performs
+
142C> height to press. conversion directly in code for cat. 7;
+
143C> test for missing "rpid" corrected for adpupa data (now
+
144C> checks ufbint return code rather than value=bmiss);
+
145C> accounts for changes in input adpupa, adpsfc, aircft
+
146C> and aircar bufr dump files after 3/2002: cat. 7 and cat.
+
147C> 51 use mnemonic "hblcs" to get height of cloud base if
+
148C> mnemonic "hocb" not available (and it will not be for all
+
149C> cat. 7 and some cat. 51 reports); mnemonic "tiwm"
+
150C> replaces "suws" in header for surface data; mnemonic
+
151C> "borg" replaces "icli" in cat. 8 for aircraft data (will
+
152C> still work properly for input adpupa, adpsfc, aircft and
+
153C> aircar dump files prior to 3/2002).
+
154C> - Dennis Keyser 2013-03-20 Changes to run on wcoss, obtain value of
+
155C> bmiss set in calling program via call to bufrlib routine
+
156C> getbmiss rather than hardwiring it to 10e08 (or 10e10);
+
157C> use formatted print statements where previously
+
158C> unformatted print was used (wcoss splits unformatted
+
159C> print at 80 characters).
+
160C>
+
161C> @param[in] lunit fortran unit number for sequential data set containing
+
162C> packed bufr reports or packed and blocked office note 29/124 reports
+
163C> @param[out] obs array containing one report in unpacked office note
+
164C> 29/124 format. Format is mixed, user must equivalence
+
165C> integer and character arrays to this array (see
+
166C> docblock for w3fi64 in /nwprod/lib/sorc/w3nco
+
167C> or writeups on w3fi64, on29, on124 for help)
+
168C> the length of the array should be at least 1608.
+
169C> @param[out] ier return flag (equal to function value)
+
170C>
+
171C> Input files:
+
172C> - unit aa sequential bufr or office note 29/124 data set ("aa"
+
173C> is unit number specified by input argument "nunit")
+
174C>
+
175C> Output files:
+
176C> - unit 06 printout
+
177C>
+
178C> @note
+
179C> - if input data set is on29/124, it should be assigned in this way:
+
180C> - cray:
+
181C> - assign -a adpupa -fcos -cebcdic fort.xx
+
182C> - sgi:
+
183C> - assign -a adpupa -fcos fort.xx
+
184C> (note: -cebcdic is not possible on sgi, so call to w3nco
+
185C> routine "aea" takes care of the conversion as each
+
186C> on29 record is read in)
+
187C> - if input data set is bufr, it should be assigned in this way:
+
188C> - cray:
+
189C> - assign -a adpupa fort.xx
+
190C> - sgi:
+
191C> - assign -a adpupa -f cos fort.xx
+
192C>
+
193C> For input on29/124 data sets, a contingency has been built
+
194C> into this subroutine to perform the conversion from ebcdic to
+
195C> ascii in the event the assign does not perform the conversion
+
196C> the return flags in ier (and function iw3unp29 itself) are:
+
197C> - 0 Observation read and unpacked into location 'obs'.
+
198C> see writeup of w3fi64 for contents. (all character
+
199C> words are left-justified.) Next call to iw3unp29
+
200C> will return next observation in data set.
+
201C> - 1 A 40 byte header in the format described here
+
202C> (y2k compliant pseudo-office note 85) is returned
+
203C> in the first 10 words of 'obs' on a 4-byte machine
+
204C> (ibm) and in the first 5 words of 'obs' on an
+
205C> 8-byte machine (cray). Next call to
+
206C> iw3unp29 will return first obs. in this data set.
+
207C> (note: if input data set is a true on29/124 file
+
208C> with the y2k compliant pseudo-on85 header record,
+
209C> then the pseudo-on85 header record is actually
+
210C> read in and returned; if input data set is a true
+
211C> on29/124 file with a non-y2k compliant on85 header
+
212C> record, then a y2k compliant pseudo-on85 header
+
213C> record is constructed from it using the "windowing"
+
214C> technique to obtain a 4-digit year from a 2-digit
+
215C> year.)
+
216C> format for y2k compliant pseudo-on85 header record
+
217C> returned (40 bytes in character):
+
218C> - bytes 1- 8 -- data set name (as defined in on85 except up to
+
219C> eight ascii char., left justified with blank fill)
+
220C> - bytes 9-10 -- set type (as defined in on85)
+
221C> - bytes 11-20 -- center (analysis) date for data
+
222C> set (ten ascii characters in form "yyyymmddhh")
+
223C> - bytes 21-24 -- set initialize (dump) time, as dedined in on85)
+
224C> - bytes 25-34 -- always "washington" (as in on85)
+
225C> - bytes 35-36 -- source machine (as defined in on85)
+
226C> - bytes 37-40 -- blank fill characters
+
227C> - 2 end-of-file (never an empty or null file):
+
228C> - input on29/124 data set: the "endof file" record is
+
229C> encountered - no useful information in 'obs' array.
+
230C> next call to iw3unp29 will return physical end of
+
231C> file for data set in 'nunit' (see ier=3 below).
+
232C> - input bufr data set: the physical end of file is
+
233C> encountered.
+
234C> -3 end-of-file:
+
235C> Physical end of file encountered on data set -
+
236C> this can only happen for an empty (null) data set
+
237C> or for a true on29/124 data set. There are no
+
238C> more reports (or never were any if null) associated
+
239C> with data set in this unit number - no useful
+
240C> information in 'obs' array. Either all done (if
+
241C> no more unit numbers are to be read in), or reset
+
242C> 'nunit' to point to a new data set (in which case
+
243C> next call to iw3unp29 should return with ier=1).
+
244C> - 4 only valid for input on29/124 data set - i/o error
+
245C> reading the next record of reports - no useful
+
246C> information in 'obs' array. Calling program can
+
247C> choose to stop or again call iw3unp29 which will
+
248C> attempt to unpack the first observation in the next
+
249C> record of reports.
+
250C> - 999 applies only to non-empty data sets:
+
251C> - input on29/124 data set: first choice y2k compliant
+
252C> pseudo-on85 file header label not encountered where
+
253C> expected, and second choice non-y2k compliant on85
+
254C> file header label also not encountered.
+
255C> - input bufr data set either header label in
+
256C> format of pseudo-on85 could not be returned, or an
+
257C> abnormal error occurred in the attempt to decode an
+
258C> observation. For either input data set type, no
+
259C> useful information in 'obs' array. Calling program
+
260C> can choose to stop with non-zero condition code or
+
261C> reset 'nunit' to point to a new data set (in which
+
262C> case next call to iw3unp29 should return with
+
263C> ier=1).
+
264C> - input data set neither on29/124 nor bufr speaks for
+
265C> itself.
+
266C>
+
267C> @author Dennis Keyser @date 2013-03-20
+
268C>
+
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
+
294C THE FIRST TIME IN, INITIALIZE SOME DATA
+
295C (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES
+
296C TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON,
+
297C THE BLOCK DATA DOES NOT INITIALIZE DATA IN THE W3NCO LIBRARY
+
298C AVOID BLOCK DATA IN W3NCO/W3EMC)
+
299C --------------------------------------------------------------------
+
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
+
336C UNIT NUMBER OUT OF RANGE RETURNS A 999
+
337C --------------------------------------
+
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
+
350C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
+
351C ------------------------------------------------------------
+
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
+
464C***********************************************************************
+
465C***********************************************************************
+
466C***********************************************************************
+
467C> This function read obs files and returns error message.
+
468C> @param LUNIT full path of file
+
469C> @param HDR header of file
+
470C> @param IER missing or invalid data indicator
+
471C> @return Y2K COMPLIANT
+
472C>
+
473C> @author Dennis Keyser @date 2013-03-20
+
474C>
+
475C-----------------------------------------------------------------------
+
+
476 FUNCTION i01o29(LUNIT,HDR,IER)
+
477C ---> formerly FUNCTION IW3HDR
+
478
+
479 common/io29aa/jwfile(100),lastf
+
480
+
481 dimension hdr(*)
+
482
+
483 SAVE
+
484
+
485C UNIT NUMBER OUT OF RANGE RETURNS A 999
+
486C --------------------------------------
+
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
+
494C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
+
495C ------------------------------------------------------------
+
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
+
508C CAN'T READ FILE HEADER RETURNS A 999
+
509C ------------------------------------
+
510
+
511 print'(" ##IW3UNP29/I01O29 - CAN""T READ FILE HEADER -- ",
+
512 $ "IER = 999")'
+
513 GO TO 9999
+
514 END IF
+
515 ELSE
+
516
+
517C FILE ALREADY OPEN RETURNS A 999
+
518C -------------------------------
+
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
+
532C***********************************************************************
+
533C***********************************************************************
+
534C***********************************************************************
+
535
+
536C> This function read obs files and returns error message.
+
537C> @param LUNIT full path of file
+
538C> @param OBS data output
+
539C> @param IER missing or invalid data indicator
+
540C> @return Y2K COMPLIANT
+
541C>
+
542C> @author Dennis Keyser @date 2013-03-20
+
543C>
+
544
+
+
545 FUNCTION i02o29(LUNIT,OBS,IER)
+
546C ---> 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
+
565C IF FILE IS CLOSED TRY TO OPEN IT AND RETURN A Y2K COMPLIANT
+
566C PSEUDO-ON85 LABEL
+
567C -----------------------------------------------------------
+
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)
+
588cppppp
+
589 print'(" CENTER DATE (JDATE) = ",I4,4I3.2/" DUMP DATE (JDUMP)",
+
590 $ " (year not used anywhere) = "I4,4I3.2)',jdate,jdump
+
591cppppp
+
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
+
596C If 2-digit year returned in JDATE(1), must use "windowing" technique
+
597C 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
+
615C This next call, I believe, is needed only because SUBSET is not
+
616C 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
+
629C IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET
+
630C -------------------------------------------------------------------
+
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
+
642C FILE MUST BE OPEN FOR INPUT!
+
643C ----------------------------
+
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
+
653C> This function reads a true (see *) on29/124 data set and unpacks one
+
654C> report into the unpacked office note 29/124 format. the input and
+
655C> output arguments here have the same meaning as for iw3unp29.
+
656C> repeated calls of function will return a sequence of unpacked
+
657C> on29/124 reports. * - unlike original "true" on29/124 data sets,
+
658C> the "expected" file header label is a y2k compliant 40-byte
+
659C> pseudo-on85 version - if this is not encountered this code, as a
+
660C> temporary measure during the y2k transition period, will look for
+
661C> the original non-y2k compliant 32-byte on85 header label and use
+
662C> the "windowing" technique to convert the 2-digit year to a 4-digit
+
663C> year in preparation for returning a 40-byte pseudo-on85 label in
+
664C> the first C call. (see iw3unp29 docblock for format of 40-byte
+
665C> pseudo-on85 header label.)
+
666C>
+
667C> Program History Log:
+
668C> -1991-07-23 Dennis Keyser w3fi64 (f77) internal read error
+
669C> no longer causes calling program to fail but will move
+
670C> to next record if can't recover to next report
+
671C> -1993-10-07 Dennis Keyser -- adapted for use on cray (added save
+
672C> statement, removed ibm-specific code, etc.)
+
673C> -1993-10-15 R. E. Jones added code so if file is ebcdic it converts
+
674C> it to ascii
+
675C> -1996-10-04 Jack Woollen changed name to i03gad and incorporated
+
676C> into new w3lib routine iw3gad
+
677C> -2013-03-20 Dennis Keyser changes to run on wcoss
+
678C>
+
679C> @param[in] nunit fortran unit number for sequential data set containing
+
680C> packed and blocked office note 29/124 reports
+
681C> @param[out] obs array containing one report in unpacked office note
+
682C> - 29/124 format is mixed, user must equivalence
+
683C> - integer and character arrays to this array (see
+
684C> - docblock for w3fi64 in /nwprod/lib/sorc/w3nco
+
685C> - or writeups on w3fi64, on29, on124 for help)
+
686C> - the length of the array should be at least 1608
+
687C> @param[out] ier return flag (equal to function value) in iw3unp29 docblock
+
688C> @return Y2K COMPLIANT
+
689C>
+
690C> @note aa unit number specified by input argument "nunit")
+
691C> called by subprogram iw3unp29.
+
692C>
+
693C> @author keyser @date 2013-03-20
+
694C>
+
+
695 FUNCTION i03o29(NUNIT, OBS, IER)
+
696C ---> 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
+
710C TEST FOR NEW (OR PREVIOUSLY USED) NUNIT AND ADJUST 'NEXT'
+
711C (THIS ALLOWS USER TO SWITCH TO NEW NUNIT PRIOR TO READING TO
+
712C THE 'END OF FILE' ON AN OLD UNIT. ANY SWITCH TO A NEW UNIT WILL
+
713C START THE READ AT THE BEGINNING)
+
714C ----------------------------------------------------------------
+
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
+
725C THIS IS A NEW UNIT NUMBER, SET 'NEXT' TO 0 AND REWIND THIS UNIT
+
726C ---------------------------------------------------------------
+
727
+
728CDAKCDAK 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
+
742C COME HERE TO READ IN A NEW RECORD (EITHER REPORTS, Y2K COMPLIANT 40-
+
743C BYTE PSEUDO-ON85 LBL, NON-Y2K 32-BYTE COMPLIANT ON85 LBL, OR E-O-F)
+
744C --------------------------------------------------------------------
+
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
+
749C INPUT DATASET IS BUFR - EXIT IMMEDIATELY
+
750C ----------------------------------------
+
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
+
762C IF ISWT=1, CHARACTER DATA IN RECORD ARE EBCDIC - CONVERT TO ASCII
+
763C -----------------------------------------------------------------
+
764
+
765 IF(iswt.EQ.1) CALL aea(cbuff,cbuff,6432)
+
766
+
767 IF(nfile.EQ.0) THEN
+
768
+
769C TEST FOR EXPECTED HEADER LABEL
+
770C ------------------------------
+
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
+
778C QUICK CHECK SHOWS SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-
+
779C ON85 LBL OR NON-Y2K COMPLIANT ON85 LBL FOUND -- COULD MEAN CHARACTER
+
780C DATA ARE IN EBCDIC, SO SEE IF CONVERSION TO ASCII RECTIFIES THIS
+
781C ---------------------------------------------------------------------
+
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
+
794C THIS IS Y2K COMPLIANT 40-BYTE PSEUDO-ON85 LBL; RESET 'NEXT', SET
+
795C 'IER', FILL 'OBS(1)-(4)', AND QUIT
+
796C ---------------------------------------------------------------
+
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
+
804C THIS IS NON-Y2K COMPLIANT 32-BYTE ON85 LBL; RESET 'NEXT', SET
+
805C 'IER', USE "WINDOWING" TECHNIQUE TO CONTRUCT 4-DIGIT YEAR,
+
806C CONSTRUCT A 40-BYTE PSEUDO-ON85 LABE, FILL 'OBS(1)-(4)', AND QUIT
+
807C ------------------------------------------------------------------
+
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
+
843C SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-ON85 LBL OR
+
844C NON-Y2K COMPLIANT ON85 LBL FOUND; RESET 'NEXT', SET 'IER' AND QUIT
+
845C ------------------------------------------------------------------
+
846CDAKCDAK PRINT 88 CAN'T PRINT THIS ANYMORE
+
847CDA88 FORMAT(/' ##IW3UNP29/I03O29 - EXPECTED ON85 LABEL NOT FOUND IN ',
+
848CDAK $ '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
+
859C LOGICAL "ENDOF FILE" READ; RESET NEXT, SET IER, AND QUIT
+
860C --------------------------------------------------------
+
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
+
871C PHYSICAL END OF FILE; RESET 'NEXT', SET 'IER' AND QUIT
+
872C ------------------------------------------------------
+
873
+
874 next = 0
+
875 ier = 3
+
876 GO TO 90
+
877
+
878 9998 CONTINUE
+
879
+
880C I/O ERROR; RESET 'NEXT', SET 'IER' AND QUIT
+
881C -------------------------------------------
+
882
+
883cppppp
+
884 print'(" ##IW3UNP29/I03O29 - ERROR READING DATA RECORD")'
+
885cppppp
+
886 next = 0
+
887 ier = 4
+
888 GO TO 90
+
889
+
890 70 CONTINUE
+
891
+
892C WORKING WITHIN ACTUAL DATA REC. READ, CALL W3FI64 TO READ IN NEXT RPT
+
893C ---------------------------------------------------------------------
+
894
+
895 CALL w3fi64(cbuff,obs,next)
+
896
+
897 IF(next.GE.0) THEN
+
898
+
899C REPORT SUCCESSFULLY RETURNED IN ARRAY 'OBS'
+
900C -------------------------------------------
+
901
+
902 ier = 0
+
903
+
904 ELSE
+
905
+
906C HIT END-OF-RECORD, OR INTERNAL READ ERROR ENCOUNTERED & CAN'T RECOVER
+
907C -- READ IN NEXT RECORD OF REPORTS
+
908C ---------------------------------------------------------------------
+
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
+
921C***********************************************************************
+
922C> This function read subset and returns group name.
+
923C> @param SUBSET subset
+
924C> @return group name
+
925C>
+
926C> @author Dennis Keyser @date 2013-03-20
+
927C>
+
928C***********************************************************************
+
+
929 FUNCTION c01o29(SUBSET)
+
930C ---> 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
+
971C***********************************************************************
+
972C> This function read subset and returns corresponding file data.
+
973C> @param SUBSET subset
+
974C> @param LUNIT full path of file
+
975C> @param OBS data output
+
976C> @return file data
+
977C>
+
978C> @author Dennis Keyser @date 2013-03-20
+
979C>
+
980C***********************************************************************
+
+
981 FUNCTION r01o29(SUBSET,LUNIT,OBS)
+
982C ---> formerly FUNCTION ADC
+
983
+
984 CHARACTER*(*) subset
+
985 CHARACTER*6 c01o29,adpsub
+
986 dimension obs(*)
+
987
+
988 SAVE
+
989
+
990C FIND AN ON29/124 DATA TYPE AND CALL A TRANSLATOR
+
991C ------------------------------------------------
+
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
+
1005C***********************************************************************
+
1006C***********************************************************************
+
1007C***********************************************************************
+
1008 SUBROUTINE s01o29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
+
1009C ---> 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
+
1024C INITIALIZE THE UNPACK ARRAY TO MISSINGS
+
1025C ---------------------------------------
+
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
+
1039C WRITE THE RECEIPT TIME IN CHARACTERS
+
1040C ------------------------------------
+
1041
+
1042 rct = '9999 '
+
1043 IF(rch*100.LT.2401.AND.rch*100.GT.-1)
+
1044 $ WRITE(rct,'(I4.4)') nint(rch*100.)
+
1045
+
1046C STORE THE ON29 HEADER INFORMATION INTO UNP FORMAT
+
1047C -------------------------------------------------
+
1048
+
1049 rhdr( 1) = omiss
+
1050 IF(yob.LT.bmiss) rhdr( 1) = nint(100.*yob)
+
1051cppppp
+
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)
+
1055cppppp
+
1056 rhdr( 2) = omiss
+
1057 IF(xob.LT.bmiss) rhdr( 2) = nint(100.*mod(720.-xob,360.))
+
1058cppppp
+
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)
+
1062cppppp
+
1063 rhdr( 3) = omiss
+
1064 rhdr( 4) = omiss
+
1065 IF(rhr.LT.bmiss) rhdr( 4) = nint((100.*rhr)+0.0001)
+
1066cppppp
+
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)
+
1069cppppp
+
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
+
1096C STORE THE HEADER INTO A HOLDING ARRAY
+
1097C -------------------------------------
+
1098
+
1099 hdr = rhdr
+
1100
+
1101 RETURN
+
1102 END
+
1103C***********************************************************************
+
1104C***********************************************************************
+
1105C***********************************************************************
+
1106 SUBROUTINE s02o29(ICAT,N,*)
+
1107C ---> 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
+
1133cppppp-ID
+
1134 iprint = 0
+
1135c if(C11(1:4)//C12(1:2).eq.'59758 ') iprint = 1
+
1136c if(C11(1:4)//C12(1:2).eq.'59362 ') iprint = 1
+
1137c if(C11(1:4)//C12(1:2).eq.'57957 ') iprint = 1
+
1138c if(C11(1:4)//C12(1:2).eq.'74794 ') iprint = 1
+
1139c if(C11(1:4)//C12(1:2).eq.'74389 ') iprint = 1
+
1140c if(C11(1:4)//C12(1:2).eq.'96801A') iprint = 1
+
1141cppppp-ID
+
1142
+
1143 surf = .false.
+
1144 GOTO 1
+
1145
+
1146C ENTRY POINT SE01O29 FORCES DATA INTO THE SURFACE (FIRST) LEVEL
+
1147C --------------------------------------------------------------
+
1148
+
1149 entry se01o29(icat,n)
+
1150C ---> formerly ENTRY O29SFC
+
1151 surf = .true.
+
1152
+
1153C CHECK THE PARAMETERS COMING IN
+
1154C ------------------------------
+
1155
+
11561 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
+
1166C PARAMETER ICAT (ON29 CATEGORY) OUT OF BOUNDS RETURNS A 999
+
1167C ----------------------------------------------------------
+
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
+
1175C PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999
+
1176C -----------------------------------------------------
+
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
+
1184C MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01)
+
1185C -----------------------------------------------------------------
+
1186
+
1187 IF(n.EQ.0) THEN
+
1188 IF(kcat.EQ.1) RETURN
+
1189 ncat(kcat) = min(149,ncat(kcat)+1)
+
1190cppppp
+
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
+
1194cppppp
+
1195 RETURN
+
1196 END IF
+
1197
+
1198C FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER
+
1199C ------------------------------------------------------------
+
1200
+
1201 IF(kcat.EQ.1) THEN
+
1202 l = i04o29(pob(n)*.1)
+
1203 IF(l.EQ.999999) GO TO 9999
+
1204
+
1205C BAD MANDATORY LEVEL RETURNS A 999
+
1206C ---------------------------------
+
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)
+
1214cppppp
+
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)
+
1219cppppp
+
1220 ELSEIF(surf) THEN
+
1221 l = 1
+
1222 ncat(kcat) = max(ncat(kcat),1)
+
1223cppppp
+
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)
+
1228cppppp
+
1229 ELSE
+
1230 l = min(149,ncat(kcat)+1)
+
1231 IF(l.EQ.149) THEN
+
1232cppppp
+
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
+
1236cppppp
+
1237 RETURN
+
1238 END IF
+
1239 ncat(kcat) = l
+
1240cppppp
+
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)
+
1245cppppp
+
1246 END IF
+
1247
+
1248C EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT
+
1249C -----------------------------------------------
+
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
+
1271C MARK THE TROPOPAUSE LEVEL IN CAT. 3
+
1272
+
1273 IF(nint(vsg(n)).EQ.16) pqm(n) = 'T'
+
1274
+
1275C 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
+
1360C UNSUPPORTED CATEGORY RETURNS A 999
+
1361C ----------------------------------
+
1362
+
1363 print'(" ##IW3UNP29/S02O29 - CATEGORY ",I0," NOT SUPPORTED ",
+
1364 $ "-- IER = 999")', icat
+
1365 RETURN 1
+
1366 END IF
+
1367
+
1368C TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT
+
1369C -------------------------------------------------------
+
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
+
1379C***********************************************************************
+
1380C***********************************************************************
+
1381C***********************************************************************
+
1382 SUBROUTINE s03o29(UNP,SUBSET,*,*)
+
1383C ---> 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
+
1393C CALL TO SORT CATEGORIES 02, 03, 04, AND 08 LEVELS
+
1394C -------------------------------------------------
+
1395
+
1396 CALL s04o29
+
1397
+
1398C TRANSFER DATA FROM ALL CATEGORIES INTO UNP ARRAY & SET POINTERS
+
1399C ---------------------------------------------------------------
+
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
+
1418C UNPACKED ON29 REPORT CONTAINS MORE THAN 1608 WORDS - RETURNS A 999
+
1419C ------------------------------------------------------------------
+
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
+
1432C RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51, 52
+
1433C (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA)
+
1434C --------------------------------------------------------------------
+
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
+
1444C TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP
+
1445C -----------------------------------------------
+
1446
+
1447 unp(1:12) = hdr
+
1448 unp(13:42) = rcat(13:42)
+
1449
+
1450 RETURN
+
1451 END
+
1452C***********************************************************************
+
1453C***********************************************************************
+
1454C***********************************************************************
+
1455 SUBROUTINE s04o29
+
1456C ---> Formerly SUBROUTINE O29SRT
+
1457
+
1458 common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
1459cppppp
+
1460 character*8 c11,c12,sid
+
1461cppppp
+
1462
+
1463 dimension rcat(50,150),iord(150),iwork(65536),scat(50,150),rctl(3)
+
1464cppppp
+
1465 equivalence(c11,hdr(11)),(c12,hdr(12))
+
1466cppppp
+
1467
+
1468 SAVE
+
1469
+
1470cppppp
+
1471 sid = c11(1:4)//c12(1:4)
+
1472cppppp
+
1473
+
1474C SORT CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN EACH INTACT
+
1475C ------------------------------------------------------------------
+
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
+
1496cppppp
+
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
+
1506cppppp
+
1507 idup = 1
+
1508 ELSE
+
1509cppppp
+
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
+
1519cppppp
+
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
+
1534cppppp
+
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
+
1539cppppp
+
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
+
1548C SORT CATEGORY 08 BY CODE FIGURE
+
1549C -------------------------------
+
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
+
1567C NORMAL EXIT
+
1568C -----------
+
1569
+
1570 RETURN
+
1571 END
+
1572C***********************************************************************
+
1573C***********************************************************************
+
1574C***********************************************************************
+
1575 SUBROUTINE s05o29
+
1576C ---> 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
+
1590C SET THE INPUT DATA ARRAYS TO MISSING OR BLANK
+
1591C ---------------------------------------------
+
1592
+
1593 obs = bmiss
+
1594 qms = ' '
+
1595 sfo = bmiss
+
1596 sfq = ' '
+
1597
+
1598 RETURN
+
1599 END
+
1600C***********************************************************************
+
1601C***********************************************************************
+
1602C***********************************************************************
+
1603 FUNCTION i04o29(P)
+
1604C ---> 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
+
1648C***********************************************************************
+
1649C***********************************************************************
+
1650C***********************************************************************
+
1651 FUNCTION r02o29()
+
1652C ---> 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)
+
1680C ---> 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)
+
1685C ---> 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)
+
1707C ---> 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)
+
1712C ---> formerly ENTRY ONWDR
+
1713 e04o29 = wdr
+
1714 RETURN
+
1715 entry e05o29(wdr,wsp)
+
1716C ---> 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)
+
1725C ---> 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)
+
1732C ---> 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)
+
1737C ---> formerly ENTRY ONHGT
+
1738 e08o29 = hgt
+
1739 IF(hgt.LT.bmiss) e08o29 = (hgt/grav)
+
1740 RETURN
+
1741 entry e09o29(hvz)
+
1742C ---> 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)
+
1756C ---> formerly ENTRY ONPRW
+
1757 e10o29 = bmiss
+
1758 IF(prw.LT.bmiss) e10o29 = nint(mod(prw,100.))
+
1759 RETURN
+
1760 entry e11o29(paw)
+
1761C ---> formerly ENTRY ONPAW
+
1762 e11o29 = bmiss
+
1763 IF(paw.LT.bmiss) e11o29 = nint(mod(paw,10.))
+
1764 RETURN
+
1765 entry e12o29(ccn)
+
1766C ---> 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)
+
1790C ---> 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)
+
1803C ---> 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)
+
1816C ---> formerly ENTRY ONCTL, ONCTM, ONCTH
+
1817 e15o29 = ctlmh
+
1818 RETURN
+
1819 entry e18o29(chl,chm,chh,ctl,ctm,cth)
+
1820C ---> 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)
+
1853C ---> 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)
+
1858C ---> 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)
+
1867C ---> 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)
+
1876C ---> formerly ENTRY ONDOP
+
1877 e22o29 = bmiss
+
1878 IF(pc6.LT.bmiss) e22o29 = 1
+
1879 RETURN
+
1880 entry e23o29(per)
+
1881C ---> formerly ENTRY ONPOW, ONSWP
+
1882 e23o29 = nint(per)
+
1883 RETURN
+
1884 entry e24o29(hgt)
+
1885C ---> formerly ENTRY ONHOW, ONSWH
+
1886 e24o29 = hgt
+
1887 IF(hgt.LT.bmiss) e24o29 = nint(2.*hgt)
+
1888 RETURN
+
1889 entry e25o29(swd)
+
1890C ---> 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)
+
1901C ---> formerly ENTRY ONSPG
+
1902 e28o29 = spg
+
1903 RETURN
+
1904 entry e29o29(spd)
+
1905C ---> formerly ENTRY ONSPD
+
1906 e29o29 = spd
+
1907 RETURN
+
1908 entry e30o29(shc)
+
1909C ---> 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)
+
1914C ---> 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)
+
1919C ---> formerly ENTRY ONWES
+
1920 e32o29 = wes
+
1921 RETURN
+
1922 entry e33o29(subset,rpid)
+
1923C ---> 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
+
1935C LAND RADIOSONDE - FIXED
+
1936C -----------------------
+
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
+
1944C LAND RADIOSONDE - MOBILE
+
1945C ------------------------
+
1946
+
1947 e33o29 = 013
+
1948 END IF
+
1949 IF(subset.EQ.'NC002003') THEN
+
1950
+
1951C SHIP RADIOSONDE
+
1952C ---------------
+
1953
+
1954 e33o29 = 022
+
1955 IF(rpid(1:4).EQ.'SHIP') e33o29 = 023
+
1956 END IF
+
1957 IF(subset.EQ.'NC002004') THEN
+
1958
+
1959C DROPWINSONDE
+
1960C -------------
+
1961
+
1962 e33o29 = 031
+
1963 END IF
+
1964 IF(subset.EQ.'NC002005') THEN
+
1965
+
1966C PIBAL
+
1967C -----
+
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)
+
1981C ---> formerly ENTRY ONFIX
+
1982C - With Jeff Ator's fix on 1/30/97, don't need this anymore
+
1983cdak HGT0 = HGT
+
1984cdak IF(MOD(NINT(HGT),300).EQ.0.OR.MOD(NINT(HGT),500).EQ.0)
+
1985cdak $ HGT = HGT * 1.016
+
1986
+
1987C ALL WINDS-BY-HEIGHT HEIGHTS ARE TRUNCATED DOWN TO THE NEXT
+
1988C 10 METER LEVEL IF PART DD (ABOVE 100 MB LEVEL) (ON29 CONVENTION)
+
1989C -----------------------------------------------------------------
+
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
+
1995C - With Jeff Ator's fix on 1/30/97, don't need this anymore
+
1996cdak IF(HGT.NE.HGT0) THEN
+
1997cdak IF(MOD(NINT(HGT0),1500).EQ.0) HGT = HGT - 1.0
+
1998cdak ELSE
+
1999 IF(mod(nint(hgt/1.016),1500).EQ.0) hgt = nint(hgt - 1.0)
+
2000cdak 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
+
2018C***********************************************************************
+
2019C***********************************************************************
+
2020C***********************************************************************
+
2021 FUNCTION c02o29()
+
2022C ---> formerly FUNCTION ONCHR
+
2023 CHARACTER*8 c02o29,e35o29,e36o29
+
2024 CHARACTER*1 cprt(0:11),cmr29(0:15)
+
2025
+
2026 SAVE
+
2027
+
2028C (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure
+
2029C was set to 6 (instead of 14 or 12, resp.) to get around the
+
2030C 3-bit limit to ON29 pressure q.m. mnemonic "QMPR". The 3-bit
+
2031C limit on "QMPR" was changed to 4-bits with a decoder change
+
2032C in February 1999. However, the codes that write the q.m.'s
+
2033C out (EDTBUFR and QUIPC) were not changed to write out 14 or
+
2034C 12 for purge or reject until mid-March 1999. In order to
+
2035C allow old runs to work properly, a q.m. of 6 will continue
+
2036C to be interpreted as a "P". This would have to change if
+
2037C q.m.=6 ever has a defined meaning.)
+
2038
+
2039C Code Table Value: 0 1 2 3 4 5 6 7
+
2040
+
2041 DATA cmr29 /'H','A',' ','Q','C','F','P','F',
+
2042
+
2043C 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)
+
2052C ---> 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)
+
2057C ---> formerly ENTRY ONPRT
+
2058 e36o29 = ' '
+
2059 IF(nprt.LT.12) e36o29 = cprt(nprt)//' '
+
2060 RETURN
+
2061 END
+
2062C***********************************************************************
+
2063C***********************************************************************
+
2064C***********************************************************************
+
2065 FUNCTION l01o29()
+
2066C ---> 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)
+
2077C ---> formerly ENTRY ONBKS
+
2078 l02o29 = .false.
+
2079 READ(rpid,'(I5)',err=1) ibks
+
2080 l02o29 = .true.
+
20811 RETURN
+
2082 entry l03o29(rpid)
+
2083C ---> formerly ENTRY ONCAL
+
2084 l03o29 = .true.
+
2085 READ(rpid,'(I5)',err=2) ibks
+
2086 l03o29 = .false.
+
20872 RETURN
+
2088 END
+
2089C***********************************************************************
+
2090C***********************************************************************
+
2091C***********************************************************************
+
2092 FUNCTION r03o29(LUNIT,OBS)
+
2093C ---> 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
+
2133C CHECK IF THIS IS A PREPBUFR FILE
+
2134C --------------------------------
+
2135
+
2136 r03o29 = 99
+
2137c#V#V#dak - future
+
2138cdak IF(SUBSET.EQ.'ADPUPA') R03O29 = PRPUPA(LUNIT,OBS)
+
2139caaaaadak - future
+
2140 IF(r03o29.NE.99) RETURN
+
2141 r03o29 = 0
+
2142
+
2143 CALL s05o29
+
2144
+
2145C VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN ON29 CATEGORY
+
2146C --------------------------------------------------------
+
2147
+
2148C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING
+
2149C SIGNIFICANCE -- CODE TABLE FOLLOWS:
+
2150C 64 Surface
+
2151C processed as ON29 category 2 and/or 3 and/or 4
+
2152C 32 Standard (mandatory) level
+
2153C processed as ON29 category 1
+
2154C 16 Tropopause level
+
2155C processed as ON29 category 5
+
2156C 8 Maximum wind level
+
2157C processed as ON29 category 3 or 4
+
2158C 4 Significant level, temperature
+
2159C processed as ON29 category 2
+
2160C 2 Significant level, wind
+
2161C processed as ON29 category 3 or 4
+
2162C 1 ???????????????????????
+
2163C processed as ON29 category 6
+
2164C
+
2165C anything else - the level is not processed
+
2166
+
2167 CALL ufbint(lunit,vsg_8,1,255,nlev,'VSIG');vsg=vsg_8
+
2168
+
2169C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
2170C -------------------------------------------
+
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 '
+
2176cppppp-ID
+
2177 iprint = 0
+
2178c if(sid.eq.'59758 ') iprint = 1
+
2179c if(sid.eq.'61094 ') iprint = 1
+
2180c if(sid.eq.'62414 ') iprint = 1
+
2181c if(sid.eq.'59362 ') iprint = 1
+
2182c if(sid.eq.'57957 ') iprint = 1
+
2183c if(sid.eq.'74794 ') iprint = 1
+
2184c if(sid.eq.'74389 ') iprint = 1
+
2185c if(sid.eq.'96801A ') iprint = 1
+
2186 if(iprint.eq.1)
+
2187 $ print'(" @@@ START DIAGNOSTIC PRINTOUT FOR ID ",A)', sid
+
2188cppppp-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
+
2197cppppp
+
2198cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 1 type ",
+
2199cdak $ "Flight-level RECCO")', sid
+
2200cppppp
+
2201 irecco = 1
+
2202 ELSE IF(min(vsg(1),rpmsl,rgp10(1)).GE.bmiss.AND.rpsal.LT.
+
2203 $ bmiss)
+
2204 $ THEN
+
2205cppppp
+
2206cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 6 type ",
+
2207cdak $ "Flight-level RECCO (but reformatted into cat. 2/3)")', sid
+
2208cppppp
+
2209 irecco = 6
+
2210 ELSE IF(min(vsg(1),rgp10(1)).GE.bmiss.AND.max(rpmsl,rpsal)
+
2211 $ .LT.bmiss) THEN
+
2212cppppp
+
2213cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 2/3 type ",
+
2214cdak $ "Flight-level RECCO with valid PMSL")', sid
+
2215cppppp
+
2216 irecco = 23
+
2217 ELSE
+
2218cppppp
+
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
+
2226cppppp
+
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
+
2246cppppp
+
2247 print'(" IW3UNP29/R03O29: ID ",A," has a missing elev, so ",
+
2248 $ "elevation set to ZERO")', sid
+
2249cppppp
+
2250 IF((rtp.GT.20.AND.rtp.LT.24).OR.subset.EQ.'NC002004') elv = 0
+
2251 END IF
+
2252cdak 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
+
2257C PUT THE LEVEL DATA INTO ON29 UNITS
+
2258C ----------------------------------
+
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
+
2292cppppp
+
2293 print'(" ~~@@IW3UNP29/R03O29: ID ",A," has a ZERO or ",
+
2294 $ "negative reported pressure that is reset to missing")',
+
2295 $ sid
+
2296cppppp
+
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)))
+
2301cppppp
+
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
+
2306cppppp
+
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.
+
2317cppppp
+
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
+
2324cppppp
+
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)
+
2345cppppp
+
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
+
2353cppppp
+
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
+
2382C SURFACE DATA MUST GO FIRST
+
2383C --------------------------
+
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
+
2398cppppp
+
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
+
2406cppppp
+
2407 IF(pob(l).LT.bmiss.AND.(tob(l).LT.bmiss.OR.irecco.EQ.23))
+
2408 $ CALL se01o29(2,l)
+
2409cppppp
+
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
+
2414cppppp
+
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
+
2418cppppp
+
2419 if(iprint.eq.1) print'(" --> valid cat. 4 sfc. lvl ")'
+
2420cppppp
+
2421
+
2422C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
+
2423C -----------------------------------------------------------------
+
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
+
2435cppppp
+
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
+
2442cppppp
+
2443 IF(max(sob(ii),dob(ii)).GE.bmiss) THEN
+
2444 sob(ii) = sob(l)
+
2445 dob(ii) = dob(l)
+
2446cppppp
+
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
+
2452cppppp
+
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
+
2465cppppp
+
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
+
2472cppppp
+
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)
+
2478cppppp
+
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
+
2484cppppp
+
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
+
2494cppppp
+
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
+
2501cppppp
+
2502 IF(max(sob(ii),dob(ii)).GE.bmiss) THEN
+
2503 sob(ii) = sob(l)
+
2504 dob(ii) = dob(l)
+
2505cppppp
+
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
+
2511cppppp
+
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
+
2525C TAKE CARE OF 925 MB NEXT
+
2526C ------------------------
+
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
+
2541C REST OF THE DATA
+
2542C ----------------
+
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
+
2548cppppp
+
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
+
2555cppppp
+
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
+
2560cppppp
+
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
+
2572cppppp
+
2573 print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for ",
+
2574 $ "lvl ",I0," but pressure not mand.!! --> this level ",
+
2575 $ "not processed")', sid,l
+
2576cppppp
+
2577 ELSE IF(min(rcats(1,ll,1),rcats(2,ll,1)).LT.99999.) THEN
+
2578 IF(rcats(4,ll,1).GE.99998.) THEN
+
2579cppppp
+
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
+
2587cppppp
+
2588 CALL s02o29(1,l,*9999)
+
2589 ELSE
+
2590cppppp
+
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
+
2598cppppp
+
2599 CALL s02o29(3,l,*9999)
+
2600 END IF
+
2601 ELSE
+
2602cppppp
+
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
+
2609cppppp
+
2610 CALL s02o29(3,l,*9999)
+
2611 END IF
+
2612 ELSE
+
2613cppppp
+
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
+
2617cppppp
+
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
+
2626cppppp
+
2627 if(iprint.eq.1) then
+
2628 print'(" ==> For lvl ",I0,"; VSG= 4 --> valid cat. 2 ",
+
2629 $ "lvl")', l
+
2630 end if
+
2631cppppp
+
2632 IF(indx16.GT.0) THEN
+
2633 DO ii = 1,indx16
+
2634 IF(pob(l).EQ.p16(ii).AND.pob(l).LT.bmiss) THEN
+
2635cppppp
+
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
+
2642cppppp
+
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
+
2652cppppp
+
2653 if(iprint.eq.1) then
+
2654 print'(" ==> For lvl ",I0,"; VSG=16 --> valid cat. 3/5 ",
+
2655 $ "lvl")', l
+
2656 end if
+
2657cppppp
+
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
+
2664cppppp
+
2665 print'(" ~~IW3UNP29/R03O29: HERE IS A VSG =1, SET TO CAT.6, ",
+
2666 $ "AT ID ",A,"; SHOULD NEVER HAPPEN!!")', sid
+
2667cppppp
+
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
+
2672cppppp
+
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
+
2677cppppp
+
2678 CALL s02o29(3,l,*9999)
+
2679 ELSE
+
2680cppppp
+
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
+
2685cppppp
+
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
+
2691C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
+
2692C -------------------------------------------------------------
+
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)
+
2696cppppp
+
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
+
2704cppppp
+
2705
+
2706C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
+
2707C -----------------------------------------------------------------
+
2708
+
2709 zqm(l) = ' '
+
2710
+
2711 CALL s02o29(4,l,*9999)
+
2712 ELSE
+
2713cppppp
+
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
+
2718cppppp
+
2719 END IF
+
2720 vsg(l) = 0
+
2721 ELSEIF(nint(vsg(l)).EQ. 8 .AND. pob(l).LT.bmiss) THEN
+
2722cppppp
+
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
+
2727cppppp
+
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
+
2733C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
+
2734C -------------------------------------------------------------
+
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)
+
2738cppppp
+
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
+
2746cppppp
+
2747
+
2748C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
+
2749C -----------------------------------------------------------------
+
2750
+
2751 zqm(l) = ' '
+
2752
+
2753 CALL s02o29(4,l,*9999)
+
2754 ELSE
+
2755cppppp
+
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
+
2760cppppp
+
2761 END IF
+
2762 vsg(l) = 0
+
2763 END IF
+
2764 ENDDO
+
2765
+
2766C CHECK FOR LEVELS WHICH GOT LEFT OUT
+
2767C -----------------------------------
+
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
+
2781C CLOUD DATA GOES INTO CATEGORY 07
+
2782C --------------------------------
+
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
+
2818C -----------------------------------------------------
+
2819C MISC DATA GOES INTO CATEGORY 08
+
2820C -----------------------------------------------------
+
2821C CODE FIGURE 104 - RELEASE TIME IN .01*HR
+
2822C CODE FIGURE 105 - RECEIPT TIME IN .01*HR
+
2823C CODE FIGURE 106 - RADIOSONDE INSTR. TYPE,
+
2824C SOLAR/IR CORRECTION INDICATOR,
+
2825C TRACKING TECH/STATUS OF SYSTEM USED
+
2826C CODE FIGURE 925 - HEIGHT OF 925 LEVEL
+
2827C -----------------------------------------------------
+
2828
+
2829 CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
+
2830
+
2831C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS
+
2832C RECEIPT TIME SIGNIFICANCE -- CODE TABLE FOLLOWS:
+
2833C 0 General decoder receipt time
+
2834C 1 NCEP receipt time
+
2835C 2 OSO receipt time
+
2836C 3 ARINC ground station receipt time
+
2837C 4 Radiosonde TEMP AA part receipt time
+
2838C 5 Radiosonde TEMP BB part receipt time
+
2839C 6 Radiosonde TEMP CC part receipt time
+
2840C 7 Radiosonde TEMP DD part receipt time
+
2841C 8 Radiosonde PILOT AA part receipt time
+
2842C 9 Radiosonde PILOT BB part receipt time
+
2843C 10 Radiosonde PILOT CC part receipt time
+
2844C 11 Radiosonde PILOT DD part receipt time
+
2845C 12-62 Reserved for future use
+
2846C 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
+
2878C PUT THE UNPACKED ON29 REPORT INTO OBS
+
2879C -------------------------------------
+
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
+
2894C***********************************************************************
+
2895C***********************************************************************
+
2896C***********************************************************************
+
2897 FUNCTION r04o29(LUNIT,OBS)
+
2898C ---> 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
+
2935C CHECK IF THIS IS A PREPBUFR FILE
+
2936C --------------------------------
+
2937
+
2938 r04o29 = 99
+
2939c#V#V#dak - future
+
2940cdak IF(SUBSET.EQ.'ADPSFC') R04O29 = PRPSFC(LUNIT,OBS)
+
2941cdak IF(SUBSET.EQ.'SFCSHP') R04O29 = PRPSFC(LUNIT,OBS)
+
2942cdak IF(SUBSET.EQ.'SFCBOG') R04O29 = PRPSFC(LUNIT,OBS)
+
2943caaaaadak - future
+
2944 IF(r04o29.NE.99) RETURN
+
2945 r04o29 = 0
+
2946
+
2947 CALL s05o29
+
2948
+
2949C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
2950C -------------------------------------------
+
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
+
2964C I1 DEFINES SYNOPTIC FORMAT FLAG (SUBSET NC000001, NC000009)
+
2965C I1 DEFINES AUTOMATED STATION TYPE (SUBSET NC000003-NC000008,NC000010)
+
2966C I2 DEFINES CONVERTED HOURLY FLAG (SUBSET NC000xxx)
+
2967C 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
+
2990C THE 25'TH (RESERVE) CHARACTER IS INDICATOR FOR PRECIP. (INCL./EXCL.)
+
2991C THE 26'TH (RESERVE) CHARACTER IS INDICATOR FOR W SPEED (SOURCE/UNITS)
+
2992C '0' - Wind speed estimated in m/s (uncertified instrument)
+
2993C '1' - Wind speed obtained from anemometer in m/s (certified
+
2994C instrument)
+
2995C '3' - Wind speed estimated in knots (uncertified instrument)
+
2996C '4' - Wind speed obtained from anemometer in knots (certified
+
2997C instrument)
+
2998C '7' - Missing
+
2999C 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
+
3015C READ THE CATEGORY 51 SURFACE DATA FROM BUFR
+
3016C -------------------------------------------
+
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
+
3054C READ THE CATEGORY 52 SURFACE DATA FROM BUFR
+
3055C -------------------------------------------
+
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
+
3063cppppp
+
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")'
+
3067cppppp
+
3068 IF(p24.GE.bmiss.AND.nint(dop).EQ.24) p24 = pto
+
3069cppppp
+
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")'
+
3073cppppp
+
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
+
3084C 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
+
3104C SOME CLOUD DATA IS NEEDED FOR LOW, MIDDLE, AND HIGH CLOUDS IN CAT. 51
+
3105C ---------------------------------------------------------------------
+
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
+
3194C CALL FUNCTIONS TO TRANSFORM TO ON29/124 UNITS
+
3195C ---------------------------------------------
+
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
+
3214C 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
+
3260C MAKE THE UNPACKED ON29/124 REPORT INTO OBS
+
3261C ------------------------------------------
+
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
+
3268C ------------------------------------------------------------------
+
3269C MISC DATA GOES INTO CATEGORY 08
+
3270C ------------------------------------------------------------------
+
3271C CODE FIGURE 020 - ALTIMETER SETTING IN 0.1*MB
+
3272C CODE FIGURE 081 - CALENDAR DAY MAXIMUM TEMPERATURE
+
3273C CODE FIGURE 082 - CALENDAR DAY MINIMUM TEMPERATURE
+
3274C CODE FIGURE 083 - SIX HOUR MAXIMUM TEMPERATURE
+
3275C CODE FIGURE 084 - SIX HOUR MINIMUM TEMPERATURE
+
3276C CODE FIGURE 085 - PRECIPITATION OVER PAST HOUR IN 0.01*INCHES
+
3277C CODE FIGURE 098 - DURATION OF SUNSHINE FOR CALENDAR DAY IN MINUTES
+
3278C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
+
3279C ------------------------------------------------------------------
+
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
+
3366C***********************************************************************
+
3367C***********************************************************************
+
3368C***********************************************************************
+
3369 FUNCTION r05o29(LUNIT,OBS)
+
3370C ---> 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
+
3398C CHECK IF THIS IS A PREPBUFR FILE
+
3399C --------------------------------
+
3400
+
3401 r05o29 = 99
+
3402c#V#V#dak - future
+
3403cdak IF(SUBSET.EQ.'AIRCFT') R05O29 = PRPCFT(LUNIT,OBS)
+
3404cdak IF(SUBSET.EQ.'AIRCAR') R05O29 = PRPCFT(LUNIT,OBS)
+
3405caaaaadak - future
+
3406 IF(r05o29.NE.99) RETURN
+
3407 r05o29 = 0
+
3408
+
3409 CALL s05o29
+
3410
+
3411C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
3412C -------------------------------------------
+
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
+
3428C TRY TO FIND FIND THE FLIGHT LEVEL HEIGHT
+
3429C ----------------------------------------
+
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)
+
3436C FOR MDCARS ACARS DATA ONLY:
+
3437C UNCOMMENTING NEXT LINE WILL SET P-ALT TO REPORTED "IALT" VALUE --
+
3438C IN THIS CASE, PREPDATA WILL LATER GET PRESS. VIA STD. ATMOS. FCN.
+
3439C COMMENTING NEXT LINE WILL USE REPORTED PRESSURE "PRLC" TO GET
+
3440C P-ALT VIA INVERSE STD. ATMOS. FCN. -- IN THIS CASE, PREPDATA WILL
+
3441C LATER RETURN THIS SAME PRESS. VIA STD. ATMOS. FCN.
+
3442cdak 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
+
3447C ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29)
+
3448C --------------------------------------------------------------------
+
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
+
3468cvvvvv temporary?
+
3469 IF(ccl(1:4).EQ.'KAWN') THEN
+
3470
+
3471C This will toss all Carswell/Tinker Aircraft reports - until Jack
+
3472C fixes the dup-check to properly remove the duplicate Carswell
+
3473C reports, we are better off removing them all since they are
+
3474C often of less quality than the non-Carswell AIREP reports
+
3475C RIGHT NOW WE ARE HAPPY WITH DUP-CHECKER'S HANDLING OF THESE,
+
3476C SO COMMENT THIS OUT
+
3477
+
3478cdak R05O29 = -9999
+
3479cdak KSKACF(?) = KSKACF(?) + 1
+
3480cdak RETURN
+
3481 END IF
+
3482caaaaa temporary?
+
3483 IF(subset.EQ.'NC004003') THEN
+
3484
+
3485C ------------------------------------
+
3486C ASDAR/AMDAR AIRCRAFT TYPE COME HERE
+
3487C ------------------------------------
+
3488
+
3489cvvvvv temporary?
+
3490C Currently, we throw out any ASDAR/AMDAR reports with header "LFPW" -
+
3491C simply because they never appeared in NAS9000 ON29 AIRCFT data set
+
3492C (NOTE: These should all have ACID's that begin with "IT")
+
3493C (NOTE: These will not be removed from the new decoders, because
+
3494C they are apparently unique reports of reasonable
+
3495C quality. EMC just needs to test them in a parallel run
+
3496C to make sure prepacqc and the analysis handle them okay.)
+
3497
+
3498C NOTE: NO, NO DON'T THROW THEM OUT ANY MORE !!!!!!
+
3499C Keyser -- 6/13/97
+
3500
+
3501CDAKCDAK if(ccl(1:4).eq.'LFPW') then
+
3502cppppp
+
3503cdak print'(" IW3UNP29/R05O29: TOSS ""LFPW"" AMDAR with ID = ",A,
+
3504cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3505cppppp
+
3506CDAKCDAK R05O29 = -9999
+
3507CDAKCDAK kskacf(2) = kskacf(2) + 1
+
3508CDAKCDAK return
+
3509CDAKCDAK end if
+
3510caaaaa temporary?
+
3511
+
3512C MODIFY REPORT ID AS WAS DONE IN OLD ON29 AIRCRAFT PACKER
+
3513C --------------------------------------------------------
+
3514
+
3515 CALL s06o29(sid,sidmod)
+
3516 sido = sid
+
3517 sid = sidmod
+
3518
+
3519C THE 25'TH (RESERVE) CHARACTER INDICATES PHASE OF FLIGHT
+
3520C THE 26'TH (RESERVE) CHARACTER INDICATES TEMPERATURE PRECISION
+
3521C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL (NEVER HAPPENS)
+
3522C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
+
3523C "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
+
3534C ------------------------------
+
3535C ACARS AIRCRAFT TYPE COME HERE
+
3536C ------------------------------
+
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
+
3545C -----------------------------------------
+
3546C AIREP AND PIREP AIRCRAFT TYPES COME HERE
+
3547C -----------------------------------------
+
3548
+
3549C MAY POSSIBLY NEED TO MODIFY THE RPID HERE
+
3550C -----------------------------------------
+
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
+
3556cvvvvv temporary?
+
3557C Determined that Hickum AFB reports are much like Carswell - they have
+
3558C problems! They also are usually duplicates of either Carswell or
+
3559C non-Carswell reports. Apparently the front-end processing filters
+
3560C them out (according to B. Ballish). So, to make things match,
+
3561C we will do the same here.
+
3562C ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE
+
3563C SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt
+
3564C anything to keep this in here.
+
3565C (NOTE: These all have headers of "PHWR")
+
3566
+
3567 if(ccl(1:4).eq.'PHWR') then
+
3568cppppp
+
3569cdak print'(" IW3UNP29/R05O29: TOSS ""PHWR"" AIREP with ID = ",A,
+
3570cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3571cppppp
+
3572 r05o29 = -9999
+
3573 kskacf(8) = kskacf(8) + 1
+
3574 return
+
3575 end if
+
3576caaaaa temporary?
+
3577
+
3578cvvvvv temporary?
+
3579C 1) Carswell/Tinker AMDARS are processed as AIREP subtypes.
+
3580C Nearly all of them are duplicated as true non-Carswell AMDARS in
+
3581C the AMDAR subtype. The earlier version of the aircraft dup-
+
3582C checker could not remove such duplicates; the new verison now
+
3583C in operations can remove these. SO, WE HAVE COMMENTED THIS OUT.
+
3584C
+
3585C The Carswell AMDARS can be identified by the string " Sxyz" in
+
3586C the raw report (beyond byte 40), where y is 0,1, or 2.
+
3587C (NOTE: Apparently Carswell here applies to more headers than
+
3588C just "KAWN", so report header is not even checked.)
+
3589
+
3590C 2) Carswell/Tinker ACARS are processed as AIREP subtypes.
+
3591C These MAY duplicate true non-Carswell ACARS in the ACARS
+
3592C subtype. The NAS9000 decoder always excluded this type (no
+
3593C dup-checking was done). All of these will be removed here.
+
3594C The Carswell ACARS can be identified by the string " Sxyz" in
+
3595C the raw report (beyond byte 40), where y is 3 or greater.
+
3596C (NOTE: Apparently Carswell here applies to more headers than
+
3597C 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
+
3617cppppp
+
3618cdak print'(" IW3UNP29/R05O29: For ",A,", raw_8(",I0,") = ",A)',
+
3619cdak $ SID,ni+7,crawr(1:ni+7)
+
3620cppppp
+
3621 if(crawr(mm+3:mm+3).lt.'3') then
+
3622
+
3623C THIS IS A CARSWELL/TINKER AMDAR REPORT --> THROW OUT
+
3624C (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW)
+
3625C ----------------------------------------------------
+
3626
+
3627cppppp
+
3628cdak print'(" IW3UNP29/R05O29: Found a Carswell AMDAR for ",A,
+
3629cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3630cppppp
+
3631cdak R05O29 = -9999
+
3632cdak KSKACF(3) = KSKACF(3) + 1
+
3633cdak RETURN
+
3634 else
+
3635
+
3636C THIS IS A CARSWELL/TINKER ACARS REPORT --> THROW OUT
+
3637C ----------------------------------------------------
+
3638
+
3639cppppp
+
3640cdak print'(" IW3UNP29/R05O29: Found a Carswell ACARS for ",A,
+
3641cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3642cppppp
+
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
+
3656caaaaa temporary?
+
3657
+
3658C THE 25'TH (RESERVE) CHARACTER INDICATES 8'TH CHARACTER OF STATION ID
+
3659C THE 26'TH (RESERVE) CHARACTER INDICATES 7'TH CHARACTER OF STATION ID
+
3660C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL
+
3661C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
+
3662C "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
+
3669C -----------------------------
+
3670C ALL AIRCRAFT TYPES COME HERE
+
3671C -----------------------------
+
3672
+
3673 CALL ufbint(lunit,ufbint_8,1,1,iret,'DGOT');dgt=ufbint_8
+
3674
+
3675C PUT THE LEVEL DATA INTO ON29 UNITS
+
3676C ----------------------------------
+
3677
+
3678 CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
+
3679 DO l=1,nlev
+
3680
+
3681Cvvvvv temporary?
+
3682C Even though PREPDATA filters out any aircraft reports with a missing
+
3683C wind, or AIREP/PIREP and AMDAR reports below 100 and 2286 meters,
+
3684C respectively, it will be done here for now in order to help in
+
3685C the comparison between counts coming from the Cray dumps and the
+
3686C NAS9000 ON29 dumps (the NAS9000 ON29 maker filters these out).
+
3687
+
3688C NO, NO LET'S NOT FILTER HERE ANY MORE - LEAVE IT UP TO PREPDATA
+
3689C SINCE WE AREN'T COMPARING NAS9000 AND CRAY COUNTS ANY MORE
+
3690C Keyser -- 6/13/97
+
3691
+
3692CDAKCDAK if(arr(4,1).ge.bmiss.or.arr(5,1).ge.bmiss) then
+
3693CDAKCDAK R05O29 = -9999
+
3694CDAKCDAK kskacf(5) = kskacf(5) + 1
+
3695CDAKCDAK return
+
3696CDAKCDAK end if
+
3697CDAKCDAK if(subset.eq.'NC004003'.and.elev.lt.2286.) then
+
3698CDAKCDAK R05O29 = -9999
+
3699CDAKCDAK kskacf(6) = kskacf(6) + 1
+
3700CDAKCDAK return
+
3701CDAKCDAK else if(subset.ne.'NC004004'.and.elev.lt.100.) then
+
3702CDAKCDAK R05O29 = -9999
+
3703CDAKCDAK kskacf(7) = kskacf(7) + 1
+
3704CDAKCDAK return
+
3705CDAKCDAK end if
+
3706caaaaa 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
+
3721C ---------------------------------------------------------
+
3722C ACARS AIRCRAFT TYPE COME HERE FOR QUALITY MARK ASSIGNMENT
+
3723C ---------------------------------------------------------
+
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
+
3733C DEFAULT Q.MARK FOR WIND: "A"
+
3734C ----------------------------
+
3735
+
3736 IF(nlev.EQ.0.OR.arr(5,1).GE.bmiss) wqm(1) = 'A'
+
3737
+
3738 ELSE
+
3739
+
3740C --------------------------------------------------------------
+
3741C ALL OTHER AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT
+
3742C --------------------------------------------------------------
+
3743
+
3744 DO l=1,nlev
+
3745 arr(4,l) = 2
+
3746
+
3747C IF KEEP FLAG ON WIND, ENTIRE REPORT GETS KEEP FLAG ('H' IN ZQM)
+
3748C -- unless....
+
3749C IF PURGE FLAG ON WIND, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
+
3750C IF PURGE FLAG ON TEMP, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
+
3751C IF FAIL FLAG ON WIND, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM)
+
3752C IF FAIL FLAG ON TEMP, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM)
+
3753C -----------------------------------------------------------------
+
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
+
3767C DEGREE OF TURBULENCE IS STORED IN MOISTURE Q.M. SLOT
+
3768C ----------------------------------------------------
+
3769
+
3770 IF(nint(dgt).LT.15) qqm(l) = cturb(nint(dgt))
+
3771 ENDDO
+
3772
+
3773C DEFAULT Q.MARK FOR WIND: "C"
+
3774C ----------------------------
+
3775
+
3776 wqm(1) = 'C'
+
3777 END IF
+
3778
+
3779C PUT THE UNPACKED ON29 REPORT INTO OBS
+
3780C -------------------------------------
+
3781
+
3782 rsv2 = ' '
+
3783 CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
3784 CALL s02o29(6,1,*9999)
+
3785
+
3786C ------------------------------------------------------------------
+
3787C MISC DATA GOES INTO CATEGORY 08
+
3788C ------------------------------------------------------------------
+
3789C CODE FIGURE 021 - REPORT SEQUENCE NUMBER
+
3790C CODE FIGURE 917 - CHARACTERS 1 AND 2 OF ACTUAL STATION IDENTIFICATION
+
3791C (CURRENTLY ONLY FOR ASDAR/AMDAR)
+
3792C CODE FIGURE 918 - CHARACTERS 3 AND 4 OF ACTUAL STATION IDENTIFICATION
+
3793C (CURRENTLY ONLY FOR ASDAR/AMDAR)
+
3794C CODE FIGURE 919 - CHARACTERS 5 AND 6 OF ACTUAL STATION IDENTIFICATION
+
3795C (CURRENTLY ONLY FOR ASDAR/AMDAR)
+
3796C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
+
3797C (CURRENTLY ONLY FOR ASDAR/AMDAR AND ACARS)
+
3798C CODE FIGURE 921 - OBSERVATION TIME TO NEAREST 1000'TH OF AN HOUR
+
3799C (CURRENTLY ONLY FOR ACARS)
+
3800C CODE FIGURE 922 - FIRST TWO CHARACTERS OF BULLETIN BEING MONITORED
+
3801C CODE FIGURE 923 - LAST TWO CHARACTERS OF BULLETIN BEING MONITORED
+
3802C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
+
3803C ------------------------------------------------------------------
+
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
+
3868C***********************************************************************
+
3869C***********************************************************************
+
3870C***********************************************************************
+
3871 FUNCTION r06o29(LUNIT,OBS)
+
3872C ---> 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
+
3912C CHECK IF THIS IS A PREPBUFR FILE
+
3913C --------------------------------
+
3914
+
3915 r06o29 = 99
+
3916c#V#V#dak - future
+
3917cdak IF(SUBSET.EQ.'SATWND') R06O29 = PRPWND(LUNIT,OBS)
+
3918caaaaadak - future
+
3919 IF(r06o29.NE.99) RETURN
+
3920 r06o29 = 0
+
3921
+
3922 CALL s05o29
+
3923
+
3924C TRY TO FIND FIND THE HEIGHT ASSIGNMENT
+
3925C --------------------------------------
+
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
+
3932C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
3933C -------------------------------------------
+
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
+
3947C THE 25'TH (RESERVE) CHARACTER IS THE CLOUD MASK/DEEP LAYER INDICATOR
+
3948C {=2 - CLOUD TOP (NORMAL CLOUD DRIFT), =1 - DEEP LAYER,
+
3949C =9 - INDICATOR MISSING, THUS REVERTS TO DEFAULT CLOUD TOP}
+
3950C (=9 FOR ALL BUT U.S. HIGH-DENSITY SATWND TYPES)
+
3951C --------------------------------------------------------------------
+
3952
+
3953C THE 27'TH (RESERVE) CHARACTER INDICATES THE PRODUCER OF THE SATWND
+
3954C ------------------------------------------------------------------
+
3955
+
3956C THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE
+
3957C ----------------------------------------------
+
3958
+
3959 itp = 99
+
3960
+
3961C REPROCESS THE STN. ID
+
3962C ---------------------
+
3963
+
3964C REPROCESSED CHAR 1 -----> GOES: BUFR CHAR 1
+
3965C -----> METEOSAT: SAT. NO. 52, 56 GET 'X'
+
3966C SAT. NO. 53, 57 GET 'Y'
+
3967C SAT. NO. 50, 54, 58 GET 'Z'
+
3968C SAT. NO. 51, 55, 59 GET 'W'
+
3969C -----> GMS(JA): SAT. NO. 152,156 GET 'P'
+
3970C SAT. NO. 153,157 GET 'Q'
+
3971C SAT. NO. 150,154,158 GET 'R'
+
3972C SAT. NO. 151,155,159 GET 'O'
+
3973C -----> INSAT: SAT. NO. 499 GET 'V'
+
3974C REPROCESSED CHAR 2 -----> GOES: RETURNED VALUE IN BUFR FOR 'SWPR'
+
3975C (PRODUCER)
+
3976C -----> OTHERS: SAT. PRODUCER -- ESA GET 'C'
+
3977C -- GMS GET 'D'
+
3978C -- INSAT GET 'E'
+
3979C REPROCESSED CHAR 6 -----> GOES: BUFR CHAR 6
+
3980C -----> OTHERS -- INFRA-RED CLOUD DRIFT GET 'C'
+
3981C -- VISIBLE CLOUD DRIFT GET 'B'
+
3982C -- WATER VAPOR GET 'V'
+
3983C REPROCESSED CHAR 3-5 ---> SEQUENTIAL SERIAL INDEX (001 - 999)
+
3984C (UNIQUE FOR EACH BUFR CHAR 1/6 COMB.)
+
3985C REPROCESSED CHAR 7 -----> GROUP NUMBER FOR SERIAL INDEX IN
+
3986C REPROCESSED CHAR 3-5 (0 - 9, A - Z)
+
3987C 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
+
4030C PUT THE LEVEL DATA INTO ON29 UNITS
+
4031C ----------------------------------
+
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
+
4037C GROSS CHECK ON PRESSURE
+
4038C -----------------------
+
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
+
4056C DETERMINE QUALITY MARKERS
+
4057C -------------------------
+
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
+
4079C A REJECT, PURGE, OR FAIL FLAG ON WIND IS TRANSFERRED TO ALL VARIABLES
+
4080C ---------------------------------------------------------------------
+
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
+
4098C PUT THE UNPACKED ON29 REPORT INTO OBS
+
4099C -------------------------------------
+
4100
+
4101 rsv2 = ' '
+
4102 CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
4103 CALL s02o29(6,1,*9999)
+
4104
+
4105C ---------------------------------------------------------------------
+
4106C MISC DATA GOES INTO CATEGORY 08
+
4107C ---------------------------------------------------------------------
+
4108C CODE FIGURE 013 - PRESSURE
+
4109C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
+
4110C (CURRENTLY ONLY APPLIES TO U.S. SATWND TYPES)
+
4111C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
+
4112C ---------------------------------------------------------------------
+
4113C ---------------------------------------------------------------------
+
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
+
4153C***********************************************************************
+
4154C***********************************************************************
+
4155C***********************************************************************
+
4156 FUNCTION r07o29(LUNIT,OBS)
+
4157C ---> 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
+
4182C CHECK IF THIS IS A PREPBUFR FILE
+
4183C --------------------------------
+
4184
+
4185 r07o29 = 99
+
4186c#V#V#dak - future
+
4187cdak IF(SUBSET.EQ.'SPSSMI') R07O29 = PRPSMI(LUNIT,OBS)
+
4188caaaaadak - future
+
4189 IF(r07o29.NE.99) RETURN
+
4190 r07o29 = 0
+
4191
+
4192 CALL s05o29
+
4193
+
4194C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
4195C -------------------------------------------
+
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
+
4211C CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB
+
4212C (SATELLITE ID IS MISSING FOR SUPEROBS)
+
4213C -----------------------------------------------------------------
+
4214
+
4215 isupob = 1
+
4216 IF(hdr(8).LT.bmiss) isupob = 0
+
4217
+
4218C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
4219
+
4220 stdv = bmiss
+
4221
+
4222C PUT THE SSM/I DATA INTO ON29 UNITS (WILL RETURN TO HEADER DATA LATER)
+
4223C ALL PROCESSING GOES INTO CATEGORY 08
+
4224C ---------------------------------------------------------------------
+
4225
+
4226 IF(rtp.EQ.68) THEN
+
4227C ---------------------------------------------------------------------
+
4228C ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- REPORT TYPE 68 **
+
4229C ---------------------------------------------------------------------
+
4230C CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4231C CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4232C CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4233C CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4234C CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4235C CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4236C CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4237C ---------------------------------------------------------------------
+
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
+
4245C ---------------------------------------------------------------------
+
4246C ** ADDITIONAL PRODUCTS -- REPORT TYPE 575 **
+
4247C ---------------------------------------------------------------------
+
4248C CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6)
+
4249C CODE FIGURE 211 - ICE CONCENTRATION (PERCENT)
+
4250C CODE FIGURE 212 - ICE AGE (RANGE: 0,1)
+
4251C CODE FIGURE 213 - ICE EDGE (RANGE: 0,1)
+
4252C CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20)
+
4253C ---------------------------------------------------------------------
+
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
+
4264C ---------------------------------------------------------------------
+
4265C ** OCEAN SURFACE WIND SPEED PRODUCT -- REPORT TYPE 571 **
+
4266C ---------------------------------------------------------------------
+
4267C CODE FIGURE 196 - OCEANIC WIND SPEED (M/S * 10)
+
4268C (RAIN FLAG IN Q.M. BYTE 2)
+
4269C ---------------------------------------------------------------------
+
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
+
4292C ---------------------------------------------------------------------
+
4293C ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- REPORT TYPE 65 **
+
4294C ---------------------------------------------------------------------
+
4295C CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM * 10)
+
4296C (RAIN FLAG IN Q.M. BYTE 2)
+
4297C ---------------------------------------------------------------------
+
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
+
4320C ---------------------------------------------------------------------
+
4321C ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 **
+
4322C ---------------------------------------------------------------------
+
4323C CODE FIGURE 198 - RAINFALL RATE (MM/HR)
+
4324C ---------------------------------------------------------------------
+
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
+
4341C ---------------------------------------------------------------------
+
4342C ** SURFACE TEMPERATURE -- REPORT TYPE 576 **
+
4343C ---------------------------------------------------------------------
+
4344C CODE FIGURE 199 - SURFACE TEMPERATURE (DEGREES KELVIN)
+
4345C ---------------------------------------------------------------------
+
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
+
4362C ---------------------------------------------------------------------
+
4363C ** OCEAN CLOUD WATER -- REPORT TYPE 69 **
+
4364C ---------------------------------------------------------------------
+
4365C CODE FIGURE 200 - CLOUD WATER (MM * 100)
+
4366C ---------------------------------------------------------------------
+
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
+
4384C ---------------------------------------------------------------------
+
4385C ** SOIL MOISTURE -- REPORT TYPE 573 **
+
4386C ---------------------------------------------------------------------
+
4387C CODE FIGURE 201 - SOIL MOISTURE (MM)
+
4388C ---------------------------------------------------------------------
+
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
+
4405C ---------------------------------------------------------------------
+
4406C ** SNOW DEPTH -- REPORT TYPE 574 **
+
4407C ---------------------------------------------------------------------
+
4408C CODE FIGURE 202 - SNOW DEPTH (MM)
+
4409C ---------------------------------------------------------------------
+
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
+
4427C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
4428
+
4429C FINISH PUTTING THE HEADER INFORMATION INTO ON29 FORMAT
+
4430C ------------------------------------------------------
+
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
+
4457C PUT THE UNPACKED ON29 REPORT INTO OBS
+
4458C -------------------------------------
+
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
+
4474C> This subrountine modifies amdar reports so that last character ends
+
4475C> with 'Z'.
+
4476C> @param[in] IDEN Acft id
+
4477C> @param[out] ID Modified aircraft id.
+
4478C>
+
4479C> @author RAY CRAYTON @date 1992-02-16
+
4480
+
+
4481 SUBROUTINE s06o29(IDEN,ID)
+
4482C ---> 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
+
4507C THE ID INDICATES IT IS AN 8-CHARACTER ASDAR REPORT. COMPRESS IT BY
+
4508C DELETING THE 6TH AND 7TH CHARACTER
+
4509C ------------------------------------------------------------------
+
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
+
4520C UP THROUGH 6 CHARACTERS ARE LETTERS. CHANGE 6TH CHARACTER TO 'Z'
+
4521C ---------------------------------------------------------------
+
4522
+
4523 IF(n.GE.5) THEN
+
4524 id = iden
+
4525 id(6:6) = 'Z'
+
4526 ELSE
+
4527
+
4528C ZERO FILL AND ADD 'Z' TO MAKE 6 CHARAACTERS
+
4529C -------------------------------------------
+
4530
+
4531 id = iden(1:n)//zeroes(n+1:5)//'Z'
+
4532 END IF
+
4533
+
4534 ELSE IF(n.EQ.6) THEN
+
4535
+
4536C THE IDEN HAS 6 NUMERIC OR ALPHANUMERIC CHARACTERS
+
4537C -------------------------------------------------
+
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
+
4551C THE IDEN HAS 5 NUMERIC OR ALPHANUMERIC CHARACTERS
+
4552C -------------------------------------------------
+
4553
+
4554 id = iden(1:5)//'Z'
+
4555 ELSE
+
4556
+
4557C THE IDEN HAS 1-4 NUMERIC OR ALPHANUMERIC CHARACTERS
+
4558C ---------------------------------------------------
+
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
+
4575C> This function finds the location of the next numeric character
+
4576C> in a string of characters.
+
4577C>
+
4578C> @param[in] STRING Character array.
+
4579C> @param[in] NUM Number of characters to search in string.
+
4580C> @param[out] CHAR Character found.
+
4581C> @return I05O29 Integer*4 location of alphanumeric character, = 0 if not found.
+
4582C> @author Ray Crayton @date 1989-07-07
+
4583C>
+
+
4584 FUNCTION i05o29(STRING,NUM,CHAR)
+
4585C ---> 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
+
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
+
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
+
i01o29
function i01o29(lunit, hdr, ier)
This function read obs files and returns error message.
Definition iw3unp29.f:477
+
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
+
i02o29
function i02o29(lunit, obs, ier)
This function read obs files and returns error message.
Definition iw3unp29.f:546
+
c01o29
character *6 function c01o29(subset)
This function read subset and returns group name.
Definition iw3unp29.f:930
+
s06o29
subroutine s06o29(iden, id)
This subrountine modifies amdar reports so that last character ends with 'Z'.
Definition iw3unp29.f:4482
+
r01o29
function r01o29(subset, lunit, obs)
This function read subset and returns corresponding file data.
Definition iw3unp29.f:982
+
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
+
w3fa03
subroutine w3fa03(press, height, temp, theta)
Computes the standard height, temperature, and potential temperature given the pressure in millibars ...
Definition w3fa03.f:28
+
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/ixgb_8f.html b/ixgb_8f.html index d008903e..af4607ce 100644 --- a/ixgb_8f.html +++ b/ixgb_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: ixgb.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +

@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
ixgb.f File Reference
+
ixgb.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine ixgb (lugb, lskip, lgrib, nlen, nnum, mlen, cbuf)
 Byte 001-004: Bytes to skip in data file before grib message.
 

Detailed Description

This subprogram makes one index record.

@@ -107,8 +113,8 @@

Definition in file ixgb.f.

Function/Subroutine Documentation

- -

◆ ixgb()

+ +

◆ ixgb()

@@ -117,43 +123,43 @@

subroutine ixgb (   - LUGB, + lugb,   - LSKIP, + lskip,   - LGRIB, + lgrib,   - NLEN, + nlen,   - NNUM, + nnum,   - MLEN, + mlen, character, dimension(*)  - CBUF  + cbuf  @@ -195,7 +201,7 @@

  • src
  • ixgb.f
    • -
  • Generated by doxygen 1.9.1
    • +
  • Generated by doxygen 1.9.8

diff --git a/ixgb_8f.js b/ixgb_8f.js index 324f83a3..cfcc2aba 100644 --- a/ixgb_8f.js +++ b/ixgb_8f.js @@ -1,4 +1,4 @@ var ixgb_8f = [ - [ "ixgb", "ixgb_8f.html#a21b5f70c2205bfb68df79fbb83928066", null ] + [ "ixgb", "ixgb_8f.html#ab80631a0d3fc8e1450bee116bc16e205", null ] ]; \ No newline at end of file diff --git a/ixgb_8f_source.html b/ixgb_8f_source.html index 8cd52e27..f919e9ca 100644 --- a/ixgb_8f_source.html +++ b/ixgb_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: ixgb.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,169 +81,177 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
ixgb.f
+
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
-
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
-
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
-
sbytec
subroutine sbytec(OUT, IN, ISKIP, NBYTE)
This is a wrapper for sbytesc()
Definition: sbytec.f:14
+Go to the documentation of this file.
1C> @file
+
2C> @brief This subprogram makes one index record.
+
3C> @author Mark iredell @date 1995-10-31
+
4
+
5C> Byte 001-004: Bytes to skip in data file before grib message.
+
6C> Byte 005-008: Bytes to skip in message before pds.
+
7C> Byte 009-012: Bytes to skip in message before gds (0 if no gds).
+
8C> Byte 013-016: Bytes to skip in message before bms (0 if no bms).
+
9C> Byte 017-020: Bytes to skip in message before bds.
+
10C> Byte 021-024: Bytes total in the message.
+
11C> Byte 025-025: Grib version number.
+
12C> Byte 026-053: Product definition section (pds).
+
13C> Byte 054-095: Grid definition section (gds) (or nulls).
+
14C> Byte 096-101: First part of the bit map section (bms) (or nulls).
+
15C> Byte 102-112: First part of the binary data section (bds).
+
16C> Byte 113-172: (optional) bytes 41-100 of the pds.
+
17C> Byte 173-184: (optional) bytes 29-40 of the pds.
+
18C> Byte 185-320: (optional) bytes 43-178 of the gds.
+
19C>
+
20C> Program history log:
+
21C> - Mark iredell 1995-10-31
+
22C> - Mark iredell 1996-10-31 Augmented optional definitions to byte 320.
+
23C> - Mark iredell 2001-06-05 Apply linux port by ebisuzaki.
+
24C>
+
25C> @param[in] LUGB Integer logical unit of input grib file.
+
26C> @param[in] LSKIP Integer number of bytes to skip before grib message.
+
27C> @param[in] LGRIB Integer number of bytes in grib message.
+
28C> @param[in] NLEN Integer length of each index record in bytes.
+
29C> @param[in] NNUM Integer index record number to make.
+
30C> @param[out] MLEN Integer actual valid length of index record.
+
31C> @param[out] CBUF Character*1 (mbuf) buffer to receive index data.
+
32C>
+
33C> @author Mark iredell @date 1995-10-31
+
34C-----------------------------------------------------------------------
+
+
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)
+
45C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
46C 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)
+
51C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
52C 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
+
66C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
67C 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
+
85C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
86C 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
+
109C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
110C 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
+
123C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
124C 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)
+
134C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
135C 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)
+
140C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
141 RETURN
+
+
142 END
+
gbytec
subroutine gbytec(in, iout, iskip, nbyte)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition gbytec.f:14
+
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
+
sbytec
subroutine sbytec(out, in, iskip, nbyte)
This is a wrapper for sbytesc()
Definition sbytec.f:14
diff --git a/jquery.js b/jquery.js index 103c32d7..1dffb65b 100644 --- a/jquery.js +++ b/jquery.js @@ -1,12 +1,11 @@ -/*! 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 0+~]|"+M+")"+M+"*"),U=new RegExp(M+"|>"),X=new RegExp(F),V=new RegExp("^"+I+"$"),G={ID:new RegExp("^#("+I+")"),CLASS:new RegExp("^\\.("+I+")"),TAG:new RegExp("^("+I+"|[*])"),ATTR:new RegExp("^"+W),PSEUDO:new RegExp("^"+F),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-fA-F]{1,6}"+M+"?|\\\\([^\\r\\n\\f])","g"),ne=function(e,t){var n="0x"+e.slice(1)-65536;return t||(n<0?String.fromCharCode(n+65536):String.fromCharCode(n>>10|55296,1023&n|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(p.childNodes),p.childNodes),t[p.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&&(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&&!N[t+" "]&&(!v||!v.test(t))&&(1!==p||"object"!==e.nodeName.toLowerCase())){if(c=t,f=e,1===p&&(U.test(t)||z.test(t))){(f=ee.test(t)&&ye(e.parentNode)||e)===e&&d.scope||((s=e.getAttribute("id"))?s=s.replace(re,ie):e.setAttribute("id",s=S)),o=(l=h(t)).length;while(o--)l[o]=(s?"#"+s:":scope")+" "+xe(l[o]);c=l.join(",")}try{return H.apply(n,f.querySelectorAll(c)),n}catch(e){N(t,!0)}finally{s===S&&e.removeAttribute("id")}}}return g(t.replace($,"$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[S]=!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&&e.namespaceURI,n=e&&(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:p;return r!=C&&9===r.nodeType&&r.documentElement&&(a=(C=r).documentElement,E=!i(C),p!=C&&(n=C.defaultView)&&n.top!==n&&(n.addEventListener?n.addEventListener("unload",oe,!1):n.attachEvent&&n.attachEvent("onunload",oe)),d.scope=ce(function(e){return a.appendChild(e).appendChild(C.createElement("div")),"undefined"!=typeof e.querySelectorAll&&!e.querySelectorAll(":scope fieldset div").length}),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=S,!C.getElementsByName||!C.getElementsByName(S).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){var t;a.appendChild(e).innerHTML="",e.querySelectorAll("[msallowcapture^='']").length&&v.push("[*^$]="+M+"*(?:''|\"\")"),e.querySelectorAll("[selected]").length||v.push("\\["+M+"*(?:value|"+R+")"),e.querySelectorAll("[id~="+S+"-]").length||v.push("~="),(t=C.createElement("input")).setAttribute("name",""),e.appendChild(t),e.querySelectorAll("[name='']").length||v.push("\\["+M+"*name"+M+"*="+M+"*(?:''|\"\")"),e.querySelectorAll(":checked").length||v.push(":checked"),e.querySelectorAll("a#"+S+"+*").length||v.push(".#.+[+~]"),e.querySelectorAll("\\\f"),v.push("[\\r\\n\\f]")}),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("!=",F)}),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},j=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==p&&y(p,e)?-1:t==C||t.ownerDocument==p&&y(p,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]==p?-1:s[r]==p?1:0}),C},se.matches=function(e,t){return se(e,null,null,t)},se.matchesSelector=function(e,t){if(T(e),d.matchesSelector&&E&&!N[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){N(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=m[e+" "];return t||(t=new RegExp("(^|"+M+")"+e+"("+M+"|$)"))&&m(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)?S.grep(e,function(e,t){return!!n.call(e,t,e)!==r}):n.nodeType?S.grep(e,function(e){return e===n!==r}):"string"!=typeof n?S.grep(e,function(e){return-1)[^>]*|#([\w-]+))$/;(S.fn.init=function(e,t,n){var r,i;if(!e)return this;if(n=n||D,"string"==typeof e){if(!(r="<"===e[0]&&">"===e[e.length-1]&&3<=e.length?[null,e,null]:q.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 S?t[0]:t,S.merge(this,S.parseHTML(r[1],t&&t.nodeType?t.ownerDocument||t:E,!0)),N.test(r[1])&&S.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(S):S.makeArray(e,this)}).prototype=S.fn,D=S(E);var L=/^(?:parents|prev(?:Until|All))/,H={children:!0,contents:!0,next:!0,prev:!0};function O(e,t){while((e=e[t])&&1!==e.nodeType);return e}S.fn.extend({has:function(e){var t=S(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;ce=E.createDocumentFragment().appendChild(E.createElement("div")),(fe=E.createElement("input")).setAttribute("type","radio"),fe.setAttribute("checked","checked"),fe.setAttribute("name","t"),ce.appendChild(fe),y.checkClone=ce.cloneNode(!0).cloneNode(!0).lastChild.checked,ce.innerHTML="",y.noCloneChecked=!!ce.cloneNode(!0).lastChild.defaultValue,ce.innerHTML="",y.option=!!ce.lastChild;var ge={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)?S.merge([e],n):n}function ye(e,t){for(var n=0,r=e.length;n",""]);var me=/<|&#?\w+;/;function xe(e,t,n,r,i){for(var o,a,s,u,l,c,f=t.createDocumentFragment(),p=[],d=0,h=e.length;d\s*$/g;function je(e,t){return A(e,"table")&&A(11!==t.nodeType?t:t.firstChild,"tr")&&S(e).children("tbody")[0]||e}function De(e){return e.type=(null!==e.getAttribute("type"))+"/"+e.type,e}function qe(e){return"true/"===(e.type||"").slice(0,5)?e.type=e.type.slice(5):e.removeAttribute("type"),e}function Le(e,t){var n,r,i,o,a,s;if(1===t.nodeType){if(Y.hasData(e)&&(s=Y.get(e).events))for(i in Y.remove(t,"handle events"),s)for(n=0,r=s[i].length;n").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 _t,zt=[],Ut=/(=)\?(?=&|$)|\?\?/;S.ajaxSetup({jsonp:"callback",jsonpCallback:function(){var e=zt.pop()||S.expando+"_"+wt.guid++;return this[e]=!0,e}}),S.ajaxPrefilter("json jsonp",function(e,t,n){var r,i,o,a=!1!==e.jsonp&&(Ut.test(e.url)?"url":"string"==typeof e.data&&0===(e.contentType||"").indexOf("application/x-www-form-urlencoded")&&Ut.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(Ut,"$1"+r):!1!==e.jsonp&&(e.url+=(Tt.test(e.url)?"&":"?")+e.jsonp+"="+r),e.converters["script json"]=function(){return o||S.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?S(C).removeProp(r):C[r]=i,e[r]&&(e.jsonpCallback=t.jsonpCallback,zt.push(r)),o&&m(i)&&i(o[0]),o=i=void 0}),"script"}),y.createHTMLDocument=((_t=E.implementation.createHTMLDocument("").body).innerHTML="
",2===_t.childNodes.length),S.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=N.exec(e))?[t.createElement(i[1])]:(i=xe([e],t,o),o&&o.length&&S(o).remove(),S.merge([],i.childNodes)));var r,i,o},S.fn.load=function(e,t,n){var r,i,o,a=this,s=e.indexOf(" ");return-1").append(S.parseHTML(e)).find(r):e)}).always(n&&function(e,t){a.each(function(){n.apply(this,o||[e.responseText,t,e])})}),this},S.expr.pseudos.animated=function(t){return S.grep(S.timers,function(e){return t===e.elem}).length},S.offset={setOffset:function(e,t,n){var r,i,o,a,s,u,l=S.css(e,"position"),c=S(e),f={};"static"===l&&(e.style.position="relative"),s=c.offset(),o=S.css(e,"top"),u=S.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,S.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)}},S.fn.extend({offset:function(t){if(arguments.length)return void 0===t?this:this.each(function(e){S.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"===S.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"===S.css(e,"position"))e=e.parentNode;e&&e!==r&&1===e.nodeType&&((i=S(e).offset()).top+=S.css(e,"borderTopWidth",!0),i.left+=S.css(e,"borderLeftWidth",!0))}return{top:t.top-i.top-S.css(r,"marginTop",!0),left:t.left-i.left-S.css(r,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var e=this.offsetParent;while(e&&"static"===S.css(e,"position"))e=e.offsetParent;return e||re})}}),S.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(t,i){var o="pageYOffset"===i;S.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)}}),S.each(["top","left"],function(e,n){S.cssHooks[n]=Fe(y.pixelPosition,function(e,t){if(t)return t=We(e,n),Pe.test(t)?S(e).position()[n]+"px":t})}),S.each({Height:"height",Width:"width"},function(a,s){S.each({padding:"inner"+a,content:s,"":"outer"+a},function(r,o){S.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?S.css(e,t,i):S.style(e,t,n,i)},s,n?e:void 0,n)}})}),S.each(["ajaxStart","ajaxStop","ajaxComplete","ajaxError","ajaxSuccess","ajaxSend"],function(e,t){S.fn[t]=function(e){return this.on(t,e)}}),S.fn.extend({bind:function(e,t,n){return this.on(e,null,t,n)},unbind:function(e,t){return this.off(e,null,t)},delegate:function(e,t,n,r){return this.on(t,e,n,r)},undelegate:function(e,t,n){return 1===arguments.length?this.off(e,"**"):this.off(t,e||"**",n)},hover:function(e,t){return this.mouseenter(e).mouseleave(t||e)}}),S.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){S.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});/** +!function(t){"use strict";"function"==typeof define&&define.amd?define(["jquery"],t):t(jQuery)}(function(y){"use strict";y.ui=y.ui||{};y.ui.version="1.13.2";var n,i=0,h=Array.prototype.hasOwnProperty,a=Array.prototype.slice;y.cleanData=(n=y.cleanData,function(t){for(var e,i,s=0;null!=(i=t[s]);s++)(e=y._data(i,"events"))&&e.remove&&y(i).triggerHandler("remove");n(t)}),y.widget=function(t,i,e){var s,n,o,h={},a=t.split(".")[0],r=a+"-"+(t=t.split(".")[1]);return e||(e=i,i=y.Widget),Array.isArray(e)&&(e=y.extend.apply(null,[{}].concat(e))),y.expr.pseudos[r.toLowerCase()]=function(t){return!!y.data(t,r)},y[a]=y[a]||{},s=y[a][t],n=y[a][t]=function(t,e){if(!this||!this._createWidget)return new n(t,e);arguments.length&&this._createWidget(t,e)},y.extend(n,s,{version:e.version,_proto:y.extend({},e),_childConstructors:[]}),(o=new i).options=y.widget.extend({},o.options),y.each(e,function(e,s){function n(){return i.prototype[e].apply(this,arguments)}function o(t){return i.prototype[e].apply(this,t)}h[e]="function"==typeof s?function(){var t,e=this._super,i=this._superApply;return this._super=n,this._superApply=o,t=s.apply(this,arguments),this._super=e,this._superApply=i,t}:s}),n.prototype=y.widget.extend(o,{widgetEventPrefix:s&&o.widgetEventPrefix||t},h,{constructor:n,namespace:a,widgetName:t,widgetFullName:r}),s?(y.each(s._childConstructors,function(t,e){var i=e.prototype;y.widget(i.namespace+"."+i.widgetName,n,e._proto)}),delete s._childConstructors):i._childConstructors.push(n),y.widget.bridge(t,n),n},y.widget.extend=function(t){for(var e,i,s=a.call(arguments,1),n=0,o=s.length;n",options:{classes:{},disabled:!1,create:null},_createWidget:function(t,e){e=y(e||this.defaultElement||this)[0],this.element=y(e),this.uuid=i++,this.eventNamespace="."+this.widgetName+this.uuid,this.bindings=y(),this.hoverable=y(),this.focusable=y(),this.classesElementLookup={},e!==this&&(y.data(e,this.widgetFullName,this),this._on(!0,this.element,{remove:function(t){t.target===e&&this.destroy()}}),this.document=y(e.style?e.ownerDocument:e.document||e),this.window=y(this.document[0].defaultView||this.document[0].parentWindow)),this.options=y.widget.extend({},this.options,this._getCreateOptions(),t),this._create(),this.options.disabled&&this._setOptionDisabled(this.options.disabled),this._trigger("create",null,this._getCreateEventData()),this._init()},_getCreateOptions:function(){return{}},_getCreateEventData:y.noop,_create:y.noop,_init:y.noop,destroy:function(){var i=this;this._destroy(),y.each(this.classesElementLookup,function(t,e){i._removeClass(e,t)}),this.element.off(this.eventNamespace).removeData(this.widgetFullName),this.widget().off(this.eventNamespace).removeAttr("aria-disabled"),this.bindings.off(this.eventNamespace)},_destroy:y.noop,widget:function(){return this.element},option:function(t,e){var i,s,n,o=t;if(0===arguments.length)return y.widget.extend({},this.options);if("string"==typeof t)if(o={},t=(i=t.split(".")).shift(),i.length){for(s=o[t]=y.widget.extend({},this.options[t]),n=0;n
"),i=e.children()[0];return y("body").append(e),t=i.offsetWidth,e.css("overflow","scroll"),t===(i=i.offsetWidth)&&(i=e[0].clientWidth),e.remove(),s=t-i},getScrollInfo:function(t){var e=t.isWindow||t.isDocument?"":t.element.css("overflow-x"),i=t.isWindow||t.isDocument?"":t.element.css("overflow-y"),e="scroll"===e||"auto"===e&&t.widthx(D(s),D(n))?o.important="horizontal":o.important="vertical",p.using.call(this,t,o)}),h.offset(y.extend(l,{using:t}))})},y.ui.position={fit:{left:function(t,e){var i=e.within,s=i.isWindow?i.scrollLeft:i.offset.left,n=i.width,o=t.left-e.collisionPosition.marginLeft,h=s-o,a=o+e.collisionWidth-n-s;e.collisionWidth>n?0n?0=this.options.distance},_mouseDelayMet:function(){return this.mouseDelayMet},_mouseStart:function(){},_mouseDrag:function(){},_mouseStop:function(){},_mouseCapture:function(){return!0}}),y.ui.plugin={add:function(t,e,i){var s,n=y.ui[t].prototype;for(s in i)n.plugins[s]=n.plugins[s]||[],n.plugins[s].push([e,i[s]])},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;n
").css({overflow:"hidden",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,t={marginTop:this.originalElement.css("marginTop"),marginRight:this.originalElement.css("marginRight"),marginBottom:this.originalElement.css("marginBottom"),marginLeft:this.originalElement.css("marginLeft")},this.element.css(t),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(t),this._proportionallyResize()),this._setupHandles(),e.autoHide&&y(this.element).on("mouseenter",function(){e.disabled||(i._removeClass("ui-resizable-autohide"),i._handles.show())}).on("mouseleave",function(){e.disabled||i.resizing||(i._addClass("ui-resizable-autohide"),i._handles.hide())}),this._mouseInit()},_destroy:function(){this._mouseDestroy(),this._addedHandles.remove();function t(t){y(t).removeData("resizable").removeData("ui-resizable").off(".resizable")}var e;return this.elementIsWrapper&&(t(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),t(this.originalElement),this},_setOption:function(t,e){switch(this._super(t,e),t){case"handles":this._removeHandles(),this._setupHandles();break;case"aspectRatio":this._aspectRatio=!!e}},_setupHandles:function(){var t,e,i,s,n,o=this.options,h=this;if(this.handles=o.handles||(y(".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=y(),this._addedHandles=y(),this.handles.constructor===String)for("all"===this.handles&&(this.handles="n,e,s,w,se,sw,ne,nw"),i=this.handles.split(","),this.handles={},e=0;e"),this._addClass(n,"ui-resizable-handle "+s),n.css({zIndex:o.zIndex}),this.handles[t]=".ui-resizable-"+t,this.element.children(this.handles[t]).length||(this.element.append(n),this._addedHandles=this._addedHandles.add(n));this._renderAxis=function(t){var e,i,s;for(e in t=t||this.element,this.handles)this.handles[e].constructor===String?this.handles[e]=this.element.children(this.handles[e]).first().show():(this.handles[e].jquery||this.handles[e].nodeType)&&(this.handles[e]=y(this.handles[e]),this._on(this.handles[e],{mousedown:h._mouseDown})),this.elementIsWrapper&&this.originalElement[0].nodeName.match(/^(textarea|input|select|button)$/i)&&(i=y(this.handles[e],this.element),s=/sw|ne|nw|se|n|s/.test(e)?i.outerHeight():i.outerWidth(),i=["padding",/ne|nw|n/.test(e)?"Top":/se|sw|s/.test(e)?"Bottom":/^e$/.test(e)?"Right":"Left"].join(""),t.css(i,s),this._proportionallyResize()),this._handles=this._handles.add(this.handles[e])},this._renderAxis(this.element),this._handles=this._handles.add(this.element.find(".ui-resizable-handle")),this._handles.disableSelection(),this._handles.on("mouseover",function(){h.resizing||(this.className&&(n=this.className.match(/ui-resizable-(se|sw|ne|nw|n|e|s|w)/i)),h.axis=n&&n[1]?n[1]:"se")}),o.autoHide&&(this._handles.hide(),this._addClass("ui-resizable-autohide"))},_removeHandles:function(){this._addedHandles.remove()},_mouseCapture:function(t){var e,i,s=!1;for(e in this.handles)(i=y(this.handles[e])[0])!==t.target&&!y.contains(i,t.target)||(s=!0);return!this.options.disabled&&s},_mouseStart:function(t){var e,i,s=this.options,n=this.element;return this.resizing=!0,this._renderProxy(),e=this._num(this.helper.css("left")),i=this._num(this.helper.css("top")),s.containment&&(e+=y(s.containment).scrollLeft()||0,i+=y(s.containment).scrollTop()||0),this.offset=this.helper.offset(),this.position={left:e,top:i},this.size=this._helper?{width:this.helper.width(),height:this.helper.height()}:{width:n.width(),height:n.height()},this.originalSize=this._helper?{width:n.outerWidth(),height:n.outerHeight()}:{width:n.width(),height:n.height()},this.sizeDiff={width:n.outerWidth()-n.width(),height:n.outerHeight()-n.height()},this.originalPosition={left:e,top:i},this.originalMousePosition={left:t.pageX,top:t.pageY},this.aspectRatio="number"==typeof s.aspectRatio?s.aspectRatio:this.originalSize.width/this.originalSize.height||1,s=y(".ui-resizable-"+this.axis).css("cursor"),y("body").css("cursor","auto"===s?this.axis+"-resize":s),this._addClass("ui-resizable-resizing"),this._propagate("start",t),!0},_mouseDrag:function(t){var e=this.originalMousePosition,i=this.axis,s=t.pageX-e.left||0,e=t.pageY-e.top||0,i=this._change[i];return this._updatePrevProperties(),i&&(e=i.apply(this,[t,s,e]),this._updateVirtualBoundaries(t.shiftKey),(this._aspectRatio||t.shiftKey)&&(e=this._updateRatio(e,t)),e=this._respectSize(e,t),this._updateCache(e),this._propagate("resize",t),e=this._applyChanges(),!this._helper&&this._proportionallyResizeElements.length&&this._proportionallyResize(),y.isEmptyObject(e)||(this._updatePrevProperties(),this._trigger("resize",t,this.ui()),this._applyChanges())),!1},_mouseStop:function(t){this.resizing=!1;var e,i,s,n=this.options,o=this;return this._helper&&(s=(e=(i=this._proportionallyResizeElements).length&&/textarea/i.test(i[0].nodeName))&&this._hasScroll(i[0],"left")?0:o.sizeDiff.height,i=e?0:o.sizeDiff.width,e={width:o.helper.width()-i,height:o.helper.height()-s},i=parseFloat(o.element.css("left"))+(o.position.left-o.originalPosition.left)||null,s=parseFloat(o.element.css("top"))+(o.position.top-o.originalPosition.top)||null,n.animate||this.element.css(y.extend(e,{top:s,left:i})),o.helper.height(o.size.height),o.helper.width(o.size.width),this._helper&&!n.animate&&this._proportionallyResize()),y("body").css("cursor","auto"),this._removeClass("ui-resizable-resizing"),this._propagate("stop",t),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=this.options,n={minWidth:this._isNumber(s.minWidth)?s.minWidth:0,maxWidth:this._isNumber(s.maxWidth)?s.maxWidth:1/0,minHeight:this._isNumber(s.minHeight)?s.minHeight:0,maxHeight:this._isNumber(s.maxHeight)?s.maxHeight:1/0};(this._aspectRatio||t)&&(e=n.minHeight*this.aspectRatio,i=n.minWidth/this.aspectRatio,s=n.maxHeight*this.aspectRatio,t=n.maxWidth/this.aspectRatio,e>n.minWidth&&(n.minWidth=e),i>n.minHeight&&(n.minHeight=i),st.width,h=this._isNumber(t.height)&&e.minHeight&&e.minHeight>t.height,a=this.originalPosition.left+this.originalSize.width,r=this.originalPosition.top+this.originalSize.height,l=/sw|nw|w/.test(i),i=/nw|ne|n/.test(i);return o&&(t.width=e.minWidth),h&&(t.height=e.minHeight),s&&(t.width=e.maxWidth),n&&(t.height=e.maxHeight),o&&l&&(t.left=a-e.minWidth),s&&l&&(t.left=a-e.maxWidth),h&&i&&(t.top=r-e.minHeight),n&&i&&(t.top=r-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")];e<4;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;e
").css({overflow:"hidden"}),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:++e.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;return{left:this.originalPosition.left+e,width:i.width-e}},n:function(t,e,i){var s=this.originalSize;return{top:this.originalPosition.top+i,height:s.height-i}},s:function(t,e,i){return{height:this.originalSize.height+i}},se:function(t,e,i){return y.extend(this._change.s.apply(this,arguments),this._change.e.apply(this,[t,e,i]))},sw:function(t,e,i){return y.extend(this._change.s.apply(this,arguments),this._change.w.apply(this,[t,e,i]))},ne:function(t,e,i){return y.extend(this._change.n.apply(this,arguments),this._change.e.apply(this,[t,e,i]))},nw:function(t,e,i){return y.extend(this._change.n.apply(this,arguments),this._change.w.apply(this,[t,e,i]))}},_propagate:function(t,e){y.ui.plugin.call(this,t,[e,this.ui()]),"resize"!==t&&this._trigger(t,e,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}}}),y.ui.plugin.add("resizable","animate",{stop:function(e){var i=y(this).resizable("instance"),t=i.options,s=i._proportionallyResizeElements,n=s.length&&/textarea/i.test(s[0].nodeName),o=n&&i._hasScroll(s[0],"left")?0:i.sizeDiff.height,h=n?0:i.sizeDiff.width,n={width:i.size.width-h,height:i.size.height-o},h=parseFloat(i.element.css("left"))+(i.position.left-i.originalPosition.left)||null,o=parseFloat(i.element.css("top"))+(i.position.top-i.originalPosition.top)||null;i.element.animate(y.extend(n,o&&h?{top:o,left:h}:{}),{duration:t.animateDuration,easing:t.animateEasing,step:function(){var t={width:parseFloat(i.element.css("width")),height:parseFloat(i.element.css("height")),top:parseFloat(i.element.css("top")),left:parseFloat(i.element.css("left"))};s&&s.length&&y(s[0]).css({width:t.width,height:t.height}),i._updateCache(t),i._propagate("resize",e)}})}}),y.ui.plugin.add("resizable","containment",{start:function(){var i,s,n=y(this).resizable("instance"),t=n.options,e=n.element,o=t.containment,h=o instanceof y?o.get(0):/parent/.test(o)?e.parent().get(0):o;h&&(n.containerElement=y(h),/document/.test(o)||o===document?(n.containerOffset={left:0,top:0},n.containerPosition={left:0,top:0},n.parentData={element:y(document),left:0,top:0,width:y(document).width(),height:y(document).height()||document.body.parentNode.scrollHeight}):(i=y(h),s=[],y(["Top","Right","Left","Bottom"]).each(function(t,e){s[t]=n._num(i.css("padding"+e))}),n.containerOffset=i.offset(),n.containerPosition=i.position(),n.containerSize={height:i.innerHeight()-s[3],width:i.innerWidth()-s[1]},t=n.containerOffset,e=n.containerSize.height,o=n.containerSize.width,o=n._hasScroll(h,"left")?h.scrollWidth:o,e=n._hasScroll(h)?h.scrollHeight:e,n.parentData={element:h,left:t.left,top:t.top,width:o,height:e}))},resize:function(t){var e=y(this).resizable("instance"),i=e.options,s=e.containerOffset,n=e.position,o=e._aspectRatio||t.shiftKey,h={top:0,left:0},a=e.containerElement,t=!0;a[0]!==document&&/static/.test(a.css("position"))&&(h=s),n.left<(e._helper?s.left:0)&&(e.size.width=e.size.width+(e._helper?e.position.left-s.left:e.position.left-h.left),o&&(e.size.height=e.size.width/e.aspectRatio,t=!1),e.position.left=i.helper?s.left:0),n.top<(e._helper?s.top:0)&&(e.size.height=e.size.height+(e._helper?e.position.top-s.top:e.position.top),o&&(e.size.width=e.size.height*e.aspectRatio,t=!1),e.position.top=e._helper?s.top:0),i=e.containerElement.get(0)===e.element.parent().get(0),n=/relative|absolute/.test(e.containerElement.css("position")),i&&n?(e.offset.left=e.parentData.left+e.position.left,e.offset.top=e.parentData.top+e.position.top):(e.offset.left=e.element.offset().left,e.offset.top=e.element.offset().top),n=Math.abs(e.sizeDiff.width+(e._helper?e.offset.left-h.left:e.offset.left-s.left)),s=Math.abs(e.sizeDiff.height+(e._helper?e.offset.top-h.top:e.offset.top-s.top)),n+e.size.width>=e.parentData.width&&(e.size.width=e.parentData.width-n,o&&(e.size.height=e.size.width/e.aspectRatio,t=!1)),s+e.size.height>=e.parentData.height&&(e.size.height=e.parentData.height-s,o&&(e.size.width=e.size.height*e.aspectRatio,t=!1)),t||(e.position.left=e.prevPosition.left,e.position.top=e.prevPosition.top,e.size.width=e.prevSize.width,e.size.height=e.prevSize.height)},stop:function(){var t=y(this).resizable("instance"),e=t.options,i=t.containerOffset,s=t.containerPosition,n=t.containerElement,o=y(t.helper),h=o.offset(),a=o.outerWidth()-t.sizeDiff.width,o=o.outerHeight()-t.sizeDiff.height;t._helper&&!e.animate&&/relative/.test(n.css("position"))&&y(this).css({left:h.left-s.left-i.left,width:a,height:o}),t._helper&&!e.animate&&/static/.test(n.css("position"))&&y(this).css({left:h.left-s.left-i.left,width:a,height:o})}}),y.ui.plugin.add("resizable","alsoResize",{start:function(){var t=y(this).resizable("instance").options;y(t.alsoResize).each(function(){var t=y(this);t.data("ui-resizable-alsoresize",{width:parseFloat(t.width()),height:parseFloat(t.height()),left:parseFloat(t.css("left")),top:parseFloat(t.css("top"))})})},resize:function(t,i){var e=y(this).resizable("instance"),s=e.options,n=e.originalSize,o=e.originalPosition,h={height:e.size.height-n.height||0,width:e.size.width-n.width||0,top:e.position.top-o.top||0,left:e.position.left-o.left||0};y(s.alsoResize).each(function(){var t=y(this),s=y(this).data("ui-resizable-alsoresize"),n={},e=t.parents(i.originalElement[0]).length?["width","height"]:["width","height","top","left"];y.each(e,function(t,e){var i=(s[e]||0)+(h[e]||0);i&&0<=i&&(n[e]=i||null)}),t.css(n)})},stop:function(){y(this).removeData("ui-resizable-alsoresize")}}),y.ui.plugin.add("resizable","ghost",{start:function(){var t=y(this).resizable("instance"),e=t.size;t.ghost=t.originalElement.clone(),t.ghost.css({opacity:.25,display:"block",position:"relative",height:e.height,width:e.width,margin:0,left:0,top:0}),t._addClass(t.ghost,"ui-resizable-ghost"),!1!==y.uiBackCompat&&"string"==typeof t.options.ghost&&t.ghost.addClass(this.options.ghost),t.ghost.appendTo(t.helper)},resize:function(){var t=y(this).resizable("instance");t.ghost&&t.ghost.css({position:"relative",height:t.size.height,width:t.size.width})},stop:function(){var t=y(this).resizable("instance");t.ghost&&t.helper&&t.helper.get(0).removeChild(t.ghost.get(0))}}),y.ui.plugin.add("resizable","grid",{resize:function(){var t,e=y(this).resizable("instance"),i=e.options,s=e.size,n=e.originalSize,o=e.originalPosition,h=e.axis,a="number"==typeof i.grid?[i.grid,i.grid]:i.grid,r=a[0]||1,l=a[1]||1,u=Math.round((s.width-n.width)/r)*r,p=Math.round((s.height-n.height)/l)*l,d=n.width+u,c=n.height+p,f=i.maxWidth&&i.maxWidthd,s=i.minHeight&&i.minHeight>c;i.grid=a,m&&(d+=r),s&&(c+=l),f&&(d-=r),g&&(c-=l),/^(se|s|e)$/.test(h)?(e.size.width=d,e.size.height=c):/^(ne)$/.test(h)?(e.size.width=d,e.size.height=c,e.position.top=o.top-p):/^(sw)$/.test(h)?(e.size.width=d,e.size.height=c,e.position.left=o.left-u):((c-l<=0||d-r<=0)&&(t=e._getPaddingPlusBorderDimensions(this)),0 - + - - + + NCEPLIBS-w3emc: lengds.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +

@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
lengds.f File Reference
+
lengds.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

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

Detailed Description

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

@@ -107,8 +113,8 @@

Definition in file lengds.f.

Function/Subroutine Documentation

- -

◆ lengds()

+ +

◆ lengds()

@@ -117,7 +123,7 @@

function lengds ( integer, dimension(200)  - KGDS) + kgds) @@ -147,7 +153,7 @@

diff --git a/lengds_8f.js b/lengds_8f.js index 19857862..470b5463 100644 --- a/lengds_8f.js +++ b/lengds_8f.js @@ -1,4 +1,4 @@ var lengds_8f = [ - [ "lengds", "lengds_8f.html#a53ab57aefe7c9277606708b4c8af7b00", null ] + [ "lengds", "lengds_8f.html#af9d4e4b97b2d11e238290791aad2b989", null ] ]; \ No newline at end of file diff --git a/lengds_8f_source.html b/lengds_8f_source.html index e0b517fc..b96a290d 100644 --- a/lengds_8f_source.html +++ b/lengds_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: lengds.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,55 +81,63 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
lengds.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief GIven a grid description section (in w3fi63 format),
+
3C> return its size in terms of number of data points.
+
4C> @author Mark Iredell @date 1996-07-19
+
5
+
6C> Program history log:
+
7C> - Mark Iredell 1996-07-19
+
8C>
+
9C> @param[in] KGDS Integer (200) gds parameters in w3fi63 format.
+
10C> @return LENGDS Integer size of grid.
+
11C>
+
12C> @author Mark Iredell @date 1996-07-19
+
13C-----------------------------------------------------------------------
+
+
14 FUNCTION lengds(KGDS)
+
15 INTEGER kgds(200)
+
16C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
17C SPECIAL CASE OF STAGGERED ETA
+
18 IF(kgds(1).EQ.201) THEN
+
19 lengds=kgds(7)*kgds(8)-kgds(8)/2
+
20C SPECIAL CASE OF FILLED ETA
+
21 ELSEIF(kgds(1).EQ.202) THEN
+
22 lengds=kgds(7)*kgds(8)
+
23C SPECIAL CASE OF THINNED WAFS
+
24 ELSEIF(kgds(19).EQ.0.AND.kgds(20).NE.255) THEN
+
25 lengds=kgds(21)
+
26C GENERAL CASE
+
27 ELSE
+
28 lengds=kgds(2)*kgds(3)
+
29 ENDIF
+
30C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
31 END
+
lengds
function lengds(kgds)
Program history log:
Definition lengds.f:15
diff --git a/makgds_8f90.html b/makgds_8f90.html new file mode 100644 index 00000000..34d339e7 --- /dev/null +++ b/makgds_8f90.html @@ -0,0 +1,195 @@ + + + + + + + +NCEPLIBS-w3emc: makgds.f90 File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc 2.11.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
+
+ +
+
+Functions/Subroutines
+
makgds.f90 File Reference
+
+
+ +

Make or break a grid description section. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine makgds (iopt, kgds, gds, lengds, iret)
 This subprogram makes or breaks a grid description section.
 
+

Detailed Description

+

Make or break a grid description section.

+
Author
Mark Iredell
+
Date
April 1996
+ +

Definition in file makgds.f90.

+

Function/Subroutine Documentation

+ +

◆ makgds()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine makgds (integer, intent(in) iopt,
integer, dimension(200), intent(inout) kgds,
character, dimension(400), intent(inout) gds,
integer, intent(out) lengds,
integer, intent(out) iret 
)
+
+ +

This subprogram makes or breaks a grid description section.

+

It can do one of the following: (IOPT=-1) Unpack a gds into w3fi63 kgds integer form. (IOPT=255) Pack a gds from w3fi63 kgds integer form. (0<IOPT<255) Pack a gds from an ncep grid identification.

+

INPUT ARGUMENT LIST:

Parameters
+ + + + + + +
[in]ioptINTEGER OPTION
    +
  • IOPT=-1 TO UNPACK GDS INTO KGDS;
    • +
  • IOPT=255 TO USE KGDS TO PACK GDS;
    • +
  • 0<IOPT<255 NCEP GRID ID TO MAKE GDS AND KGDS.
    • +
+
[in,out]kgdsW3FI63-STYLE UNPACKED GDS (IF IOPT=255) ON INPUT ONLY FIRST 22 VALUES ARE ACCESSED IF KGDS(20)=255.) AS COPIED FROM THE W3FI63 DOCBLOCK. (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 LATITUDINAL DIRECTION OF INCREMENT (10) - DJ LONGITUDINAL 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 LATITUDINAL 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 " " " + (4) - M " " " (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]GDS- CHARACTER (400) GRID DEFINITION SECTION (IF IOPT>0)
[out]LENGDS- INTEGER LENGTH OF THE GDS (IF IOPT>0)
[out]IRET- INTEGER RETURN CODE 0 SUCCESSFUL 1 GRID REPRESENTATION TYPE NOT VALID 4 DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
+
+
+
Author
Mark Iredell
+
Date
April 1996
+ +

Definition at line 106 of file makgds.f90.

+ +
+
+
+
+ + + + diff --git a/makgds_8f90.js b/makgds_8f90.js new file mode 100644 index 00000000..77834272 --- /dev/null +++ b/makgds_8f90.js @@ -0,0 +1,4 @@ +var makgds_8f90 = +[ + [ "makgds", "makgds_8f90.html#a132c655a1a21b17ef23ee83108d7d4ac", null ] +]; \ No newline at end of file diff --git a/makgds_8f90_source.html b/makgds_8f90_source.html index 7145abf0..29cd5d5a 100644 --- a/makgds_8f90_source.html +++ b/makgds_8f90_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: makgds.f90 Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,63 +81,71 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
makgds.f90
+
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
-
fi633
subroutine fi633(MSGA, KPTR, KGDS, KRET)
Extract info from grib-gds.
Definition: w3fi63.f:981
-
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
-
w3fi74
subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
This subroutine constructs a GRIB grid definition section.
Definition: w3fi74.f:19
+Go to the documentation of this file.
1
+
4
+
+
106SUBROUTINE makgds(IOPT,KGDS,GDS,LENGDS,IRET)
+
107 IMPLICIT NONE
+
108
+
109 CHARACTER, INTENT(INOUT) :: GDS(400)
+
110 INTEGER, INTENT(IN ) :: IOPT
+
111 INTEGER, INTENT(INOUT) :: KGDS(200)
+
112 INTEGER, INTENT( OUT) :: IRET, LENGDS
+
113 INTEGER :: ICOMP, IPDS(200), IGDS(200)
+
114 INTEGER :: KPTR(200), KPDS(200), NPTS
+
115
+
116 DATA kptr/200*0/, kpds/200*0/
+
117 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
118 ! UNPACK GDS INTO KGDS
+
119 IF(iopt.EQ.-1) THEN
+
120 CALL fi633(gds,kptr,kgds,iret)
+
121 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
122 ! USE KGDS TO PACK GDS
+
123 ELSEIF(iopt.EQ.255) THEN
+
124 CALL r63w72(kpds,kgds,ipds,igds)
+
125 icomp=mod(igds(8)/8,2)
+
126 CALL w3fi74(igds,icomp,gds,lengds,npts,iret)
+
127 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
128 ! USE NCEP GRID ID TO MAKE GDS AND KGDS
+
129 ELSEIF(iopt.GT.0.AND.iopt.LT.255) THEN
+
130 CALL w3fi71(iopt,igds,iret)
+
131 IF(iret.EQ.0) THEN
+
132 icomp=mod(igds(8)/8,2)
+
133 CALL w3fi74(igds,icomp,gds,lengds,npts,iret)
+
134 IF(iret.EQ.0) CALL fi633(gds,kptr,kgds,iret)
+
135 ENDIF
+
136 ENDIF
+
137 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
138END SUBROUTINE makgds
+
makgds
subroutine makgds(iopt, kgds, gds, lengds, iret)
This subprogram makes or breaks a grid description section.
Definition makgds.f90:107
+
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
+
fi633
subroutine fi633(msga, kptr, kgds, kret)
Extract info from grib-gds.
Definition w3fi63.f:981
+
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
+
w3fi74
subroutine w3fi74(igds, icomp, gds, lengds, npts, igerr)
This subroutine constructs a GRIB grid definition section.
Definition w3fi74.f:19
diff --git a/makwmo_8f.html b/makwmo_8f.html index 2fdc23ad..4160ea27 100644 --- a/makwmo_8f.html +++ b/makwmo_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: makwmo.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +

@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
makwmo.f File Reference
+
makwmo.f File Reference
@@ -94,11 +100,11 @@

Go to the source code of this file.

- - - - + + +

+

Functions/Subroutines

subroutine makwmo (BULHED, IDAY, IHOUR, KWBX, HEADER)
 Program history log: More...
 
subroutine makwmo (bulhed, iday, ihour, kwbx, header)
 Program history log:
 

Detailed Description

FORMS THE WMO HEADER FOR A GIVEN BULLETIN.

@@ -107,8 +113,8 @@

Definition in file makwmo.f.

Function/Subroutine Documentation

- -

◆ makwmo()

+ +

◆ makwmo()

@@ -117,31 +123,31 @@

subroutine makwmo ( character * 6  - BULHED, + bulhed,   - IDAY, + iday,   - IHOUR, + ihour, character * 4  - KWBX, + kwbx, character * 1, dimension (*)  - HEADER  + header  @@ -182,7 +188,7 @@

diff --git a/makwmo_8f.js b/makwmo_8f.js index 5c3d88f5..1c368046 100644 --- a/makwmo_8f.js +++ b/makwmo_8f.js @@ -1,4 +1,4 @@ var makwmo_8f = [ - [ "makwmo", "makwmo_8f.html#a8fd8c7e636856ca63ccdd4a0d786636d", null ] + [ "makwmo", "makwmo_8f.html#acb3df40c99edbb45efe0d6b9a53af7de", null ] ]; \ No newline at end of file diff --git a/makwmo_8f_source.html b/makwmo_8f_source.html index 1072fa9e..77702f40 100644 --- a/makwmo_8f_source.html +++ b/makwmo_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: makwmo.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,102 +81,110 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
makwmo.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief FORMS THE WMO HEADER FOR A GIVEN BULLETIN.
+
3C> @author Farley @date 1984-07-06
+
4
+
5C> Program history log:
+
6C> - Farley 1984-07-06
+
7C> - Ralph Jones 1994-10-10 Changes for cray.
+
8C> - Ralph Jones 1995-10-18 Add parameter KWBX to call.
+
9C> - Stephen Gilbert 1998-06-16 Changed argument list to pass in day and hour
+
10C> instead of the old O.N. 84 date word.
+
11C> - Stephen Gilbert 2003-03-28 Removed equivalences.
+
12C>
+
13C> @param[in] BULHED TTAAII bulletin header. FT10
+
14C> @param[in] IDAY Day of Month.
+
15C> @param[in] IHOUR Hour of Day.
+
16C> @param[in] KWBX 4 characters (KWBC to KWBQ)
+
17C> @param[out] HEADER Complete WMO header in ASCII.
+
18C>
+
19C> @author Farley @date 1984-07-06
+
+
20 SUBROUTINE makwmo (BULHED,IDAY,IHOUR,KWBX,HEADER)
+
21C
+
22 CHARACTER * 6 BULHED
+
23 CHARACTER * 1 HEADER (*)
+
24 CHARACTER * 1 WMOHDR (21)
+
25 CHARACTER * 4 KWBX
+
26 CHARACTER * 2 CTEMP
+
27C
+
28C--------------------------------------------------------------------
+
29C
+
30C$ 1. CREATE WMO HEADER.
+
31C
+
32C$ 1.1 CONVERT BULHED FROM EBCDIC TO ASCII.
+
33C
+
34C WRITE (6,FMT='('' MADE IT TO MAKWMO'')')
+
35C
+
36 DO i = 1,6
+
37 wmohdr(i) = bulhed(i:i)
+
38 END DO
+
39 wmohdr(7)=char(32) ! ASCII BLANK
+
40C
+
41C MOVE KWBX INTO WMO HEADER
+
42C
+
43 DO i = 1,4
+
44 wmohdr(i+7) = kwbx(i:i)
+
45 END DO
+
46 wmohdr(12)=char(32) ! ASCII BLANK
+
47C
+
48C$ 1.2 PICK OFF THE DAY OF MONTH (YY)
+
49C$ AND CONVERT TO ASCII.
+
50C
+
51 write(ctemp,fmt='(I2.2)') iday
+
52 wmohdr(13)=ctemp(1:1)
+
53 wmohdr(14)=ctemp(2:2)
+
54C
+
55C$ 1.3 PICK OFF THE HOUR(GG) AND CONVERT TO ASCII.
+
56C
+
57 write(ctemp,fmt='(I2.2)') ihour
+
58 wmohdr(15)=ctemp(1:1)
+
59 wmohdr(16)=ctemp(2:2)
+
60C
+
61C 1.4 FIL IN REST OF HEADER
+
62C
+
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'
+
68C
+
69C--------------------------------------------------------------------
+
70C
+
71C$ 2. MOVE WMOHDR TO OUTPUT FIELD.
+
72C
+
73 DO 200 i = 1,21
+
74 header(i) = wmohdr(i)
+
75 200 CONTINUE
+
76C
+
77 RETURN
+
+
78 END
+
makwmo
subroutine makwmo(bulhed, iday, ihour, kwbx, header)
Program history log:
Definition makwmo.f:21
diff --git a/menu.js b/menu.js index 2fe2214f..b0b26936 100644 --- a/menu.js +++ b/menu.js @@ -28,7 +28,15 @@ function initMenu(relPath,searchEnabled,serverSide,searchPage,search) { if ('children' in data) { result+='
    '; for (var i in data.children) { - result+='
  • '+ + var url; + var link; + link = data.children[i].url; + if (link.substring(0,1)=='^') { + url = link.substring(1); + } else { + url = relPath+link; + } + result+='
  • '+ data.children[i].text+''+ makeTree(data.children[i],relPath)+'
    • '; } @@ -36,15 +44,92 @@ function initMenu(relPath,searchEnabled,serverSide,searchPage,search) { } return result; } - - $('#main-nav').append(makeTree(menudata,relPath)); - $('#main-nav').children(':first').addClass('sm sm-dox').attr('id','main-menu'); + var searchBoxHtml; if (searchEnabled) { if (serverSide) { - $('#main-menu').append('
    • '); + searchBoxHtml='
    '+ + '
    '+ + '
     '+ + ''+ + '
    '+ + '
    '+ + '
    '+ + '
    '; } else { - $('#main-menu').append('
    • '); + searchBoxHtml='
    '+ + ''+ + ' '+ + ''+ + ''+ + ''+ + ''+ + ''+ + '
    '; + } + } + + $('#main-nav').before('
    '+ + ''+ + ''+ + '
    '); + $('#main-nav').append(makeTree(menudata,relPath)); + $('#main-nav').children(':first').addClass('sm sm-dox').attr('id','main-menu'); + if (searchBoxHtml) { + $('#main-menu').append('
  • '); + } + var $mainMenuState = $('#main-menu-state'); + var prevWidth = 0; + if ($mainMenuState.length) { + function initResizableIfExists() { + if (typeof initResizable==='function') initResizable(); + } + // animate mobile menu + $mainMenuState.change(function(e) { + var $menu = $('#main-menu'); + var options = { duration: 250, step: initResizableIfExists }; + if (this.checked) { + options['complete'] = function() { $menu.css('display', 'block') }; + $menu.hide().slideDown(options); + } else { + options['complete'] = function() { $menu.css('display', 'none') }; + $menu.show().slideUp(options); + } + }); + // set default menu visibility + function resetState() { + var $menu = $('#main-menu'); + var $mainMenuState = $('#main-menu-state'); + var newWidth = $(window).outerWidth(); + if (newWidth!=prevWidth) { + if ($(window).outerWidth()<768) { + $mainMenuState.prop('checked',false); $menu.hide(); + $('#searchBoxPos1').html(searchBoxHtml); + $('#searchBoxPos2').hide(); + } else { + $menu.show(); + $('#searchBoxPos1').empty(); + $('#searchBoxPos2').html(searchBoxHtml); + $('#searchBoxPos2').show(); + } + if (typeof searchBox!=='undefined') { + searchBox.CloseResultsWindow(); + } + prevWidth = newWidth; + } } + $(window).ready(function() { resetState(); initResizableIfExists(); }); + $(window).resize(resetState); } $('#main-menu').smartmenus(); } diff --git a/menudata.js b/menudata.js index 89a07920..fab9e759 100644 --- a/menudata.js +++ b/menudata.js @@ -29,8 +29,11 @@ var menudata={children:[ {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:"Data Types",url:"annotated.html",children:[ +{text:"Data Types List",url:"annotated.html"}, +{text:"Data Fields",url:"functions.html",children:[ +{text:"All",url:"functions.html"}, +{text:"Functions/Subroutines",url:"functions_func.html"}]}]}, {text:"Files",url:"files.html",children:[ {text:"File List",url:"files.html"}, {text:"Globals",url:"globals.html",children:[ diff --git a/mersenne__twister_8f.html b/mersenne__twister_8f.html index 6b7654c1..6f908966 100644 --- a/mersenne__twister_8f.html +++ b/mersenne__twister_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: mersenne_twister.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
@@ -62,7 +62,7 @@

@@ -76,18 +76,25 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Data Types | Modules | -Functions/Subroutines
-
-
mersenne_twister.f File Reference
+Functions/Subroutines | +Variables
+
mersenne_twister.f File Reference
@@ -96,26 +103,44 @@

Go to the source code of this file.

- + + + + + + + + + + +

+

+Data Types

interface  mersenne_twister::random_gauss
 
interface  mersenne_twister::random_index
 
interface  mersenne_twister::random_number
 
interface  mersenne_twister::random_setseed
 
type  mersenne_twister::random_stat
 
+ - +

Modules

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

+Variables

type(random_stat), save mersenne_twister::sstat
 

Detailed Description

Modern random number generator.

@@ -129,7 +154,7 @@ diff --git a/mersenne__twister_8f.js b/mersenne__twister_8f.js index 397ebbb4..ce332f70 100644 --- a/mersenne__twister_8f.js +++ b/mersenne__twister_8f.js @@ -1,30 +1,12 @@ var mersenne__twister_8f = [ + [ "mersenne_twister::random_gauss", "interfacemersenne__twister_1_1random__gauss.html", "interfacemersenne__twister_1_1random__gauss" ], + [ "mersenne_twister::random_index", "interfacemersenne__twister_1_1random__index.html", "interfacemersenne__twister_1_1random__index" ], + [ "mersenne_twister::random_number", "interfacemersenne__twister_1_1random__number.html", "interfacemersenne__twister_1_1random__number" ], + [ "mersenne_twister::random_setseed", "interfacemersenne__twister_1_1random__setseed.html", "interfacemersenne__twister_1_1random__setseed" ], + [ "mersenne_twister::random_stat", "structmersenne__twister_1_1random__stat.html", null ], [ "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 ] + [ "random_seed", "mersenne__twister_8f.html#ab5807578f927f719be280774b17803ad", null ] ]; \ No newline at end of file diff --git a/mersenne__twister_8f_source.html b/mersenne__twister_8f_source.html index a14dcfd5..4d1b8d79 100644 --- a/mersenne__twister_8f_source.html +++ b/mersenne__twister_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: mersenne_twister.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,338 +81,405 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
mersenne_twister.f
+
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
This module calculates random numbers using the Mersenne twister.
Definition: mersenne_twister.f:90
-
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_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_index_f
integer function, public random_index_f(imax)
Generates random indices in functional mode.
Definition: mersenne_twister.f:397
-
mersenne_twister::random_gauss_f
real function, public random_gauss_f()
Generates Gaussian random numbers in functional mode.
Definition: mersenne_twister.f:306
+Go to the documentation of this file.
1
+
4
+
95 module mersenne_twister
+
96 private
+
97! Public declarations
+
98 public random_stat
+
99 public random_seed
+
100 public random_setseed
+
101 public random_number
+
102 public random_number_f
+
103 public random_gauss
+
104 public random_gauss_f
+
105 public random_index
+
106 public random_index_f
+
107! Parameters
+
108 integer,parameter:: n=624
+
109 integer,parameter:: m=397
+
110 integer,parameter:: mata=-1727483681 ! constant vector a
+
111 integer,parameter:: umask=-2147483648 ! most significant w-r bits
+
112 integer,parameter:: lmask =2147483647 ! least significant r bits
+
113 integer,parameter:: tmaskb=-1658038656 ! tempering parameter
+
114 integer,parameter:: tmaskc=-272236544 ! tempering parameter
+
115 integer,parameter:: mag01(0:1)=(/0,mata/)
+
116 integer,parameter:: iseed=4357
+
117 integer,parameter:: nrest=n+6
+
118! Defined types
+
+
119 type random_stat
+
120 private
+
121 integer:: mti=n+1
+
122 integer:: mt(0:n-1)
+
123 integer:: iset
+
124 real:: gset
+
125 end type
+
+
126! Saved data
+
127 type(random_stat),save:: sstat
+
128! Overloaded interfaces
+
+
129 interface random_setseed
+
130 module procedure random_setseed_s
+
131 module procedure random_setseed_t
+
+
132 end interface
+
+
133 interface random_number
+
134 module procedure random_number_i
+
135 module procedure random_number_s
+
136 module procedure random_number_t
+
+
137 end interface
+
+
138 interface random_gauss
+
139 module procedure random_gauss_i
+
140 module procedure random_gauss_s
+
141 module procedure random_gauss_t
+
+
142 end interface
+
+
143 interface random_index
+
144 module procedure random_index_i
+
145 module procedure random_index_s
+
146 module procedure random_index_t
+
+
147 end interface
+
148! All the subprograms
+
149 contains
+
150
+
+
158 subroutine random_seed(size,put,get,stat)
+
159 implicit none
+
160 integer,intent(out),optional:: size
+
161 integer,intent(in),optional:: put(nrest)
+
162 integer,intent(out),optional:: get(nrest)
+
163 type(random_stat),intent(inout),optional:: stat
+
164 if(present(size)) then ! return size of seed array
+
165! if(present(put).or.present(get))&
+
166! call errmsg('RANDOM_SEED: more than one option set - some ignored')
+
167 size=nrest
+
168 elseif(present(put)) then ! restore from seed array
+
169! if(present(get))&
+
170! call errmsg('RANDOM_SEED: more than one option set - some ignored')
+
171 if(present(stat)) then
+
172 stat%mti=put(1)
+
173 stat%mt=put(2:n+1)
+
174 stat%iset=put(n+2)
+
175 stat%gset=transfer(put(n+3:nrest),stat%gset)
+
176 if(stat%mti.lt.0.or.stat%mti.gt.n.or.any(stat%mt.eq.0).or.
+
177 & stat%iset.lt.0.or.stat%iset.gt.1) then
+
178 call random_setseed_t(iseed,stat)
+
179! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used')
+
180 endif
+
181 else
+
182 sstat%mti=put(1)
+
183 sstat%mt=put(2:n+1)
+
184 sstat%iset=put(n+2)
+
185 sstat%gset=transfer(put(n+3:nrest),sstat%gset)
+
186 if(sstat%mti.lt.0.or.sstat%mti.gt.n.or.any(sstat%mt.eq.0)
+
187 & .or.sstat%iset.lt.0.or.sstat%iset.gt.1) then
+
188 call random_setseed_t(iseed,sstat)
+
189! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used')
+
190 endif
+
191 endif
+
192 elseif(present(get)) then ! save to seed array
+
193 if(present(stat)) then
+
194 if(stat%mti.eq.n+1) call random_setseed_t(iseed,stat)
+
195 get(1)=stat%mti
+
196 get(2:n+1)=stat%mt
+
197 get(n+2)=stat%iset
+
198 get(n+3:nrest)=transfer(stat%gset,get,nrest-(n+3)+1)
+
199 else
+
200 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
201 get(1)=sstat%mti
+
202 get(2:n+1)=sstat%mt
+
203 get(n+2)=sstat%iset
+
204 get(n+3:nrest)=transfer(sstat%gset,get,nrest-(n+3)+1)
+
205 endif
+
206 else ! reset default seed
+
207 if(present(stat)) then
+
208 call random_setseed_t(iseed,stat)
+
209 else
+
210 call random_setseed_t(iseed,sstat)
+
211 endif
+
212 endif
+
+
213 end subroutine
+
214
+
+
219 subroutine random_setseed_s(inseed)
+
220 implicit none
+
221 integer,intent(in):: inseed
+
222 call random_setseed_t(inseed,sstat)
+
+
223 end subroutine
+
224
+
+
230 subroutine random_setseed_t(inseed,stat)
+
231 implicit none
+
232 integer,intent(in):: inseed
+
233 type(random_stat),intent(out):: stat
+
234 integer ii,mti
+
235 ii=inseed
+
236 if(ii.eq.0) ii=iseed
+
237 stat%mti=n
+
238 stat%mt(0)=iand(ii,-1)
+
239 do mti=1,n-1
+
240 stat%mt(mti)=iand(69069*stat%mt(mti-1),-1)
+
241 enddo
+
242 stat%iset=0
+
243 stat%gset=0.
+
+
244 end subroutine
+
245
+
+
250 function random_number_f() result(harvest)
+
251 implicit none
+
252 real:: harvest
+
253 real h(1)
+
254 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
255 call random_number_t(h,sstat)
+
256 harvest=h(1)
+
+
257 end function
+
258
+
+
264 subroutine random_number_i(harvest,inseed)
+
265 implicit none
+
266 real,intent(out):: harvest(:)
+
267 integer,intent(in):: inseed
+
268 type(random_stat) stat
+
269 call random_setseed_t(inseed,stat)
+
270 call random_number_t(harvest,stat)
+
+
271 end subroutine
+
272
+
+
277 subroutine random_number_s(harvest)
+
278 implicit none
+
279 real,intent(out):: harvest(:)
+
280 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
281 call random_number_t(harvest,sstat)
+
+
282 end subroutine
+
283
+
+
289 subroutine random_number_t(harvest,stat)
+
290 implicit none
+
291 real,intent(out):: harvest(:)
+
292 type(random_stat),intent(inout):: stat
+
293 integer j,kk,y
+
294 integer tshftu,tshfts,tshftt,tshftl
+
295 tshftu(y)=ishft(y,-11)
+
296 tshfts(y)=ishft(y,7)
+
297 tshftt(y)=ishft(y,15)
+
298 tshftl(y)=ishft(y,-18)
+
299 do j=1,size(harvest)
+
300 if(stat%mti.ge.n) then
+
301 do kk=0,n-m-1
+
302 y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask))
+
303 stat%mt(kk)=ieor(ieor(stat%mt(kk+m),ishft(y,-1)),
+
304 & mag01(iand(y,1)))
+
305 enddo
+
306 do kk=n-m,n-2
+
307 y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask))
+
308 stat%mt(kk)=ieor(ieor(stat%mt(kk+(m-n)),ishft(y,-1)),
+
309 & mag01(iand(y,1)))
+
310 enddo
+
311 y=ior(iand(stat%mt(n-1),umask),iand(stat%mt(0),lmask))
+
312 stat%mt(n-1)=ieor(ieor(stat%mt(m-1),ishft(y,-1)),
+
313 & mag01(iand(y,1)))
+
314 stat%mti=0
+
315 endif
+
316 y=stat%mt(stat%mti)
+
317 y=ieor(y,tshftu(y))
+
318 y=ieor(y,iand(tshfts(y),tmaskb))
+
319 y=ieor(y,iand(tshftt(y),tmaskc))
+
320 y=ieor(y,tshftl(y))
+
321 if(y.lt.0) then
+
322 harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0)
+
323 else
+
324 harvest(j)=real(y)/(2.0**32-1.0)
+
325 endif
+
326 stat%mti=stat%mti+1
+
327 enddo
+
+
328 end subroutine
+
329
+
+
334 function random_gauss_f() result(harvest)
+
335 implicit none
+
336 real:: harvest
+
337 real h(1)
+
338 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
339 call random_gauss_t(h,sstat)
+
340 harvest=h(1)
+
+
341 end function
+
342
+
+
348 subroutine random_gauss_i(harvest,inseed)
+
349 implicit none
+
350 real,intent(out):: harvest(:)
+
351 integer,intent(in):: inseed
+
352 type(random_stat) stat
+
353 call random_setseed_t(inseed,stat)
+
354 call random_gauss_t(harvest,stat)
+
+
355 end subroutine
+
356
+
+
361 subroutine random_gauss_s(harvest)
+
362 implicit none
+
363 real,intent(out):: harvest(:)
+
364 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
365 call random_gauss_t(harvest,sstat)
+
+
366 end subroutine
+
367
+
+
373 subroutine random_gauss_t(harvest,stat)
+
374 implicit none
+
375 real,intent(out):: harvest(:)
+
376 type(random_stat),intent(inout):: stat
+
377 integer mx,my,mz,j
+
378 real r2(2),r,g1,g2
+
379 mz=size(harvest)
+
380 if(mz.le.0) return
+
381 mx=0
+
382 if(stat%iset.eq.1) then
+
383 mx=1
+
384 harvest(1)=stat%gset
+
385 stat%iset=0
+
386 endif
+
387 my=(mz-mx)/2*2+mx
+
388 do
+
389 call random_number_t(harvest(mx+1:my),stat)
+
390 do j=mx,my-2,2
+
391 call rgauss(harvest(j+1),harvest(j+2),r,g1,g2)
+
392 if(r.lt.1.) then
+
393 harvest(mx+1)=g1
+
394 harvest(mx+2)=g2
+
395 mx=mx+2
+
396 endif
+
397 enddo
+
398 if(mx.eq.my) exit
+
399 enddo
+
400 if(my.lt.mz) then
+
401 do
+
402 call random_number_t(r2,stat)
+
403 call rgauss(r2(1),r2(2),r,g1,g2)
+
404 if(r.lt.1.) exit
+
405 enddo
+
406 harvest(mz)=g1
+
407 stat%gset=g2
+
408 stat%iset=1
+
409 endif
+
410 contains
+
411
+
420 subroutine rgauss(r1,r2,r,g1,g2)
+
421 real,intent(in):: r1,r2
+
422 real,intent(out):: r,g1,g2
+
423 real v1,v2,fac
+
424 v1=2.*r1-1.
+
425 v2=2.*r2-1.
+
426 r=v1**2+v2**2
+
427 if(r.lt.1.) then
+
428 fac=sqrt(-2.*log(r)/r)
+
429 g1=v1*fac
+
430 g2=v2*fac
+
431 endif
+
432 end subroutine
+
+
433 end subroutine
+
434
+
+
440 function random_index_f(imax) result(iharvest)
+
441 implicit none
+
442 integer,intent(in):: imax
+
443 integer:: iharvest
+
444 integer ih(1)
+
445 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
446 call random_index_t(imax,ih,sstat)
+
447 iharvest=ih(1)
+
+
448 end function
+
449
+
+
456 subroutine random_index_i(imax,iharvest,inseed)
+
457 implicit none
+
458 integer,intent(in):: imax
+
459 integer,intent(out):: iharvest(:)
+
460 integer,intent(in):: inseed
+
461 type(random_stat) stat
+
462 call random_setseed_t(inseed,stat)
+
463 call random_index_t(imax,iharvest,stat)
+
+
464 end subroutine
+
465
+
+
471 subroutine random_index_s(imax,iharvest)
+
472 implicit none
+
473 integer,intent(in):: imax
+
474 integer,intent(out):: iharvest(:)
+
475 if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
+
476 call random_index_t(imax,iharvest,sstat)
+
+
477 end subroutine
+
478
+
+
485 subroutine random_index_t(imax,iharvest,stat)
+
486 implicit none
+
487 integer,intent(in):: imax
+
488 integer,intent(out):: iharvest(:)
+
489 type(random_stat),intent(inout):: stat
+
490 integer,parameter:: mh=n
+
491 integer i1,i2,mz
+
492 real h(mh)
+
493 mz=size(iharvest)
+
494 do i1=1,mz,mh
+
495 i2=min((i1-1)+mh,mz)
+
496 call random_number_t(h(:i2-(i1-1)),stat)
+
497 iharvest(i1:i2)=max(ceiling(h(:i2-(i1-1))*imax),1)
+
498 enddo
+
+
499 end subroutine
+
500 end module
+
mersenne_twister::random_gauss
Definition mersenne_twister.f:138
+
mersenne_twister::random_index
Definition mersenne_twister.f:143
+
mersenne_twister::random_number
Definition mersenne_twister.f:133
+
mersenne_twister::random_setseed
Definition mersenne_twister.f:129
+
mersenne_twister
This module calculates random numbers using the Mersenne twister.
Definition mersenne_twister.f:95
+
mersenne_twister::random_number_f
real function, public random_number_f()
Generates random numbers in functional mode.
Definition mersenne_twister.f:251
+
mersenne_twister::random_seed
subroutine, public random_seed(size, put, get, stat)
Sets and gets state; overloads Fortran 90 standard.
Definition mersenne_twister.f:159
+
mersenne_twister::random_index_f
integer function, public random_index_f(imax)
Generates random indices in functional mode.
Definition mersenne_twister.f:441
+
mersenne_twister::random_gauss_f
real function, public random_gauss_f()
Generates Gaussian random numbers in functional mode.
Definition mersenne_twister.f:335
+
mersenne_twister::random_stat
Definition mersenne_twister.f:119
diff --git a/minus.svg b/minus.svg new file mode 100644 index 00000000..f70d0c1a --- /dev/null +++ b/minus.svg @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/minusd.svg b/minusd.svg new file mode 100644 index 00000000..5f8e8796 --- /dev/null +++ b/minusd.svg @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/mkfldsep_8f.html b/mkfldsep_8f.html index a079476e..36306f81 100644 --- a/mkfldsep_8f.html +++ b/mkfldsep_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: mkfldsep.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@

@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
mkfldsep.f File Reference
+
mkfldsep.f File Reference
@@ -94,10 +100,10 @@

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...
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.
 

Detailed Description

@@ -107,8 +113,8 @@

Definition in file mkfldsep.f.

Function/Subroutine Documentation

- -

◆ mkfldsep()

+ +

◆ mkfldsep()

@@ -152,8 +158,8 @@

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.

+

See [File Transfer Input Service Guide - Input examples and how to FTP files to the Gateway] (https://www.weather.gov/tg/ftpingest).

+

This routine can generate different flag field separator blocks depending on the value of variable iopt. For details see [GATEWAY File Standards & Content Structures] (https://www.weather.gov/tg/fstandrd).

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

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

@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
mova2i.f File Reference
+
mova2i.f File Reference
@@ -94,10 +100,10 @@

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...
integer function mova2i (a)
 This Function copies a bit string from a Character*1 variable to an integer variable.
 

Detailed Description

@@ -107,8 +113,8 @@

Definition in file mova2i.f.

Function/Subroutine Documentation

- -

◆ mova2i()

+ +

◆ mova2i()

@@ -147,7 +153,7 @@

diff --git a/mova2i_8f_source.html b/mova2i_8f_source.html index 23116c48..d2d02971 100644 --- a/mova2i_8f_source.html +++ b/mova2i_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: mova2i.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,59 +81,67 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
mova2i.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief This Function copies a bit string from a Character*1 variable
+
3C> to an integer variable.
+
4C> @author Stephen Gilbert @date 1998-12-15
+
5
+
6C> This Function copies a bit string from a Character*1 variable
+
7C> to an integer variable. It is intended to replace the Fortran Intrinsic
+
8C> Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the
+
9C> IBM SP. If "a" is greater than 127 in the collating sequence,
+
10C> ICHAR(a) does not return the expected bit value when the -qhot
+
11C> ( and therefore -qsmp) option is used when compiling.
+
12C> This function can be used for all values 0 <= ICHAR(a) <= 255 and
+
13C> will work with or without the -qhot compiler option.
+
14C>
+
15C> Program history log:
+
16C> - Stephen Gilbert 1998-12-15
+
17C> - Stephen Gilbert 2001-06-11 Added a step to fill an 8-byte character
+
18C> array with the same value so that the f90 transfer function is more
+
19C> predictable. All bytes will now contain the desired value.
+
20C>
+
21C> @param[in] a Character*1 variable that holds the bitstring to extract.
+
22C> @return mova2i() Integer value of the bitstring in character a.
+
23C>
+
+
24 Integer Function mova2i(a)
+
25C
+
26 integer mold
+
27 character(len=1) a
+
28 character(len=1) ctemp(8)
+
29
+
30 ctemp(1:8)=a
+
31c 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/namespaceargs__mod.html b/namespaceargs__mod.html deleted file mode 100644 index 44114d86..00000000 --- a/namespaceargs__mod.html +++ /dev/null @@ -1,127 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: args_mod Module Reference - - - - - - - - - - - - - -
-
- - - - - - -
-
NCEPLIBS-w3emc -  2.11.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/namespaceargs__mod.js b/namespaceargs__mod.js deleted file mode 100644 index 565809d9..00000000 --- a/namespaceargs__mod.js +++ /dev/null @@ -1,7 +0,0 @@ -var namespaceargs__mod = -[ - [ "getarg", "interfaceargs__mod_1_1getarg.html", "interfaceargs__mod_1_1getarg" ], - [ "iargc", "interfaceargs__mod_1_1iargc.html", "interfaceargs__mod_1_1iargc" ], - [ "getarg_8", "namespaceargs__mod.html#a7ba1ffe2c151a1c87049a23730fa9ea6", null ], - [ "iargc_8", "namespaceargs__mod.html#a6abd46d69fad0b63bbdd0eddc14db1fe", null ] -]; \ No newline at end of file diff --git a/namespacemembers.html b/namespacemembers.html index 456d66bc..e1fc2795 100644 --- a/namespacemembers.html +++ b/namespacemembers.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Module Members @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@

@@ -76,32 +76,31 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Here is a list of all documented module members with links to the modules they belong to:
diff --git a/namespacemembers_func.html b/namespacemembers_func.html index 42e213d9..7161fcfe 100644 --- a/namespacemembers_func.html +++ b/namespacemembers_func.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Module Members @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,32 +76,31 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
- 
diff --git a/namespacemersenne__twister.html b/namespacemersenne__twister.html index 2f0ac2a5..4c76fbe6 100644 --- a/namespacemersenne__twister.html +++ b/namespacemersenne__twister.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: mersenne_twister Module Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,44 +76,74 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Data Types | -Functions/Subroutines
-
-
mersenne_twister Module Reference
+Functions/Subroutines | +Variables
+
mersenne_twister Module Reference

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

- + + + + + + + + + + +

+

+Data Types

interface  random_gauss
 
interface  random_index
 
interface  random_number
 
interface  random_setseed
 
type  random_stat
 
+ - - + + - - + + - - + + - - + + +

Functions/Subroutines

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

+Variables

type(random_stat), save sstat
 

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.

+

(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
      +
    • 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
      • @@ -150,16 +180,16 @@
    • 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)
      • +
    • 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.
    +
    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()

+ +

◆ random_gauss_f()

@@ -171,14 +201,16 @@

Generates Gaussian random numbers in functional mode.

-
Returns
harvest Real number output.
+
Returns
harvest Real number output.
+
Author
Mark Iredell
+
Date
2005-06-14
-

Definition at line 305 of file mersenne_twister.f.

+

Definition at line 334 of file mersenne_twister.f.

- -

◆ random_index_f()

+ +

◆ random_index_f()

@@ -200,14 +232,16 @@

Returns
iharvest Integer number output
+
Returns
iharvest Integer number output
+
Author
Mark Iredell
+
Date
2005-06-14
-

Definition at line 396 of file mersenne_twister.f.

+

Definition at line 440 of file mersenne_twister.f.

- -

◆ random_number_f()

+ +

◆ random_number_f()

@@ -219,14 +253,16 @@

Generates random numbers in functional mode.

-
Returns
harvest Real number output.
+
Returns
harvest Real number output.
+
Author
Mark Iredell
+
Date
2005-06-14
-

Definition at line 233 of file mersenne_twister.f.

+

Definition at line 250 of file mersenne_twister.f.

- -

◆ random_seed()

+ +

◆ random_seed()

@@ -252,7 +288,7 @@

- type(random_stat), intent(inout), optional  + type(random_stat), intent(inout), optional  stat  @@ -269,12 +305,31 @@

[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). + [in,out]statOptional type(random_stat) (thread-safe mode). +
Author
Mark Iredell
+
Date
2005-06-14
+ +

Definition at line 158 of file mersenne_twister.f.

+ +

+
+

Variable Documentation

+ +

◆ sstat

+ +
+
+ + + + +
type(random_stat), save mersenne_twister::sstat
+
-

Definition at line 150 of file mersenne_twister.f.

+

Definition at line 127 of file mersenne_twister.f.

@@ -284,7 +339,7 @@

diff --git a/namespacemersenne__twister.js b/namespacemersenne__twister.js new file mode 100644 index 00000000..e0ed8749 --- /dev/null +++ b/namespacemersenne__twister.js @@ -0,0 +1,12 @@ +var namespacemersenne__twister = +[ + [ "random_gauss", "interfacemersenne__twister_1_1random__gauss.html", "interfacemersenne__twister_1_1random__gauss" ], + [ "random_index", "interfacemersenne__twister_1_1random__index.html", "interfacemersenne__twister_1_1random__index" ], + [ "random_number", "interfacemersenne__twister_1_1random__number.html", "interfacemersenne__twister_1_1random__number" ], + [ "random_setseed", "interfacemersenne__twister_1_1random__setseed.html", "interfacemersenne__twister_1_1random__setseed" ], + [ "random_stat", "structmersenne__twister_1_1random__stat.html", null ], + [ "random_gauss_f", "namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437", null ], + [ "random_index_f", "namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e", null ], + [ "random_number_f", "namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a", null ], + [ "random_seed", "namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad", null ] +]; \ No newline at end of file diff --git a/namespaces.html b/namespaces.html index 079d825a..8c86fc52 100644 --- a/namespaces.html +++ b/namespaces.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: Modules List @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,22 +76,30 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
Modules List
+
Modules List
Here is a list of all documented modules with brief descriptions:
[detail level 12]
- - - - + + + + + +
 ▼Nargs_modThis Fortran Module acts as a wrapper to the system routines IARGC and GETARG
 Cgetarg
 Ciargc
 Nmersenne_twisterThis module calculates random numbers using the Mersenne twister
 ▼Mmersenne_twisterThis module calculates random numbers using the Mersenne twister
 Crandom_gauss
 Crandom_index
 Crandom_number
 Crandom_setseed
 Crandom_stat
@@ -99,7 +107,7 @@ diff --git a/namespaces_dup.js b/namespaces_dup.js index c57b2507..02193fe1 100644 --- a/namespaces_dup.js +++ b/namespaces_dup.js @@ -1,32 +1,4 @@ var namespaces_dup = [ - [ "args_mod", "namespaceargs__mod.html", "namespaceargs__mod" ], - [ "mersenne_twister", "namespacemersenne__twister.html", [ - [ "random_gauss_f", "namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437", null ], - [ "random_gauss_i", "namespacemersenne__twister.html#ab7560f4ac03fad6c0c5b1a393ab7af80", null ], - [ "random_gauss_s", "namespacemersenne__twister.html#ad3e61a71aa72a0b9654626b15296dbec", null ], - [ "random_gauss_t", "namespacemersenne__twister.html#a4e3b13adf5b25114f982e3e977bef004", null ], - [ "random_index_f", "namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e", null ], - [ "random_index_i", "namespacemersenne__twister.html#a9c1b3fcd1cb4e6b20a46607a0991e75c", null ], - [ "random_index_s", "namespacemersenne__twister.html#a9b5f511523152deb897819b9f5b35dba", null ], - [ "random_index_t", "namespacemersenne__twister.html#a9c03281caf481123f41fac129244685c", null ], - [ "random_number_f", "namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a", null ], - [ "random_number_i", "namespacemersenne__twister.html#a715dd6280653ef8f2b0a6cd7076d870d", null ], - [ "random_number_s", "namespacemersenne__twister.html#a52fb0e5bfcfd792c8060b8fa96f20610", null ], - [ "random_number_t", "namespacemersenne__twister.html#a3652cf0177c16351a259362f05c52be6", null ], - [ "random_seed", "namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad", null ], - [ "random_setseed_s", "namespacemersenne__twister.html#a017f5f4708314e41f34e087c48a44daf", null ], - [ "random_setseed_t", "namespacemersenne__twister.html#ae7c1227f3e7c3774b3731a3ee2f4e519", null ], - [ "iseed", "namespacemersenne__twister.html#a58ab3b5d65dcd05266b45662309f5f55", null ], - [ "lmask", "namespacemersenne__twister.html#a6385e50a4db3a7ca25b92d761374957b", null ], - [ "m", "namespacemersenne__twister.html#a6a4ca59c1e8484f3d42a3e9dc7a693b0", null ], - [ "mag01", "namespacemersenne__twister.html#adf6d74a10cc19bef891508c741282476", null ], - [ "mata", "namespacemersenne__twister.html#acf08832d5cbe3032b51a9f67a1b89c05", null ], - [ "n", "namespacemersenne__twister.html#a6ab34baf3b5aece50818d2c7cc4357b7", null ], - [ "nrest", "namespacemersenne__twister.html#a18afbd0bb0326af3129bc4bec59aee46", null ], - [ "sstat", "namespacemersenne__twister.html#a2373934764432b7b64b31c4e82340a34", null ], - [ "tmaskb", "namespacemersenne__twister.html#ab0fb126acb98e7500c8fda1aa4508ddb", null ], - [ "tmaskc", "namespacemersenne__twister.html#ae97528980ebbb1a68b7b0787721cb543", null ], - [ "umask", "namespacemersenne__twister.html#a722ec0932b5a922b6c91aec4b658adef", null ] - ] ] + [ "mersenne_twister", "namespacemersenne__twister.html", "namespacemersenne__twister" ] ]; \ No newline at end of file diff --git a/nav_fd.png b/nav_fd.png new file mode 100644 index 0000000000000000000000000000000000000000..032fbdd4c54f54fa9a2e6423b94ef4b2ebdfaceb GIT binary patch literal 169 zcmeAS@N?(olHy`uVBq!ia0vp^j6iI`!2~2XGqLUlQU#tajv*C{Z|C~*H7f|XvG1G8 zt7aS*L7xwMeS}!z6R#{C5tIw-s~AJ==F^i}x3XyJseHR@yF& zerFf(Zf;Dd{+(0lDIROL@Sj-Ju2JQ8&-n%4%q?>|^bShc&lR?}7HeMo@BDl5N(aHY Uj$gdr1MOz;boFyt=akR{0D!zeaR2}S literal 0 HcmV?d00001 diff --git a/nav_hd.png b/nav_hd.png new file mode 100644 index 0000000000000000000000000000000000000000..de80f18ad6488b9990303f267a76fdc83f0ffd80 GIT binary patch literal 114 zcmeAS@N?(olHy`uVBq!ia0vp^j6lr8!2~3AUOE6t21`#D$B+ufw|9379#G(63FK{W z5s6W-eg#Jd_@e6*DPn)w;=|1H}Zvm9l6xXXB%>yL=NQU;mg M>FVdQ&MBb@0Bdt1Qvd(} literal 0 HcmV?d00001 diff --git a/navtree.css b/navtree.css index 33341a67..69211d4a 100644 --- a/navtree.css +++ b/navtree.css @@ -22,8 +22,13 @@ #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); + color: var(--nav-text-active-color); + text-shadow: var(--nav-text-active-shadow); +} + +#nav-tree .selected .arrow { + color: var(--nav-arrow-selected-color); + text-shadow: none; } #nav-tree img { @@ -37,13 +42,12 @@ 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; + font: 12px var(--font-family-nav); } #nav-tree .label a { @@ -52,7 +56,7 @@ #nav-tree .selected a { text-decoration:none; - color:#fff; + color:var(--nav-text-active-color); } #nav-tree .children_ul { @@ -67,7 +71,6 @@ #nav-tree { padding: 0px 0px; - background-color: #FAFAFF; font-size:14px; overflow:auto; } @@ -86,7 +89,8 @@ display:block; position: absolute; left: 0px; - width: 250px; + width: $width; + overflow : hidden; } .ui-resizable .ui-resizable-handle { @@ -94,7 +98,7 @@ } .ui-resizable-e { - background-image:url("splitbar.png"); + background-image:var(--nav-splitbar-image); background-size:100%; background-repeat:repeat-y; background-attachment: scroll; @@ -117,9 +121,8 @@ } #nav-tree { - background-image:url('nav_h.png'); background-repeat:repeat-x; - background-color: #F9FAFC; + background-color: var(--nav-background-color); -webkit-overflow-scrolling : touch; /* iOS 5+ */ } diff --git a/navtree.js b/navtree.js index 1e272d31..93dd3d46 100644 --- a/navtree.js +++ b/navtree.js @@ -94,7 +94,7 @@ function cachedLink() } } -function getScript(scriptName,func,show) +function getScript(scriptName,func) { var head = document.getElementsByTagName("head")[0]; var script = document.createElement('script'); @@ -124,7 +124,7 @@ function createIndent(o,domNode,node,level) node.plus_img.innerHTML=arrowRight; node.expanded = false; } else { - expandNode(o, node, false, false); + expandNode(o, node, false, true); } } node.expandToggle.appendChild(imgNode); @@ -265,15 +265,15 @@ function showRoot() })(); } -function expandNode(o, node, imm, showRoot) +function expandNode(o, node, imm, setFocus) { 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); + expandNode(o, node, imm, setFocus); + }); } else { if (!node.childrenVisited) { getNode(o, node); @@ -281,6 +281,9 @@ function expandNode(o, node, imm, showRoot) $(node.getChildrenUL()).slideDown("fast"); node.plus_img.innerHTML = arrowDown; node.expanded = true; + if (setFocus) { + $(node.expandToggle).focus(); + } } } } @@ -325,11 +328,14 @@ function selectAndHighlight(hash,n) $(n.itemDiv).addClass('selected'); $(n.itemDiv).attr('id','selected'); } + var topOffset=5; + if (typeof page_layout!=='undefined' && page_layout==1) { + topOffset+=$('#top').outerHeight(); + } if ($('#nav-tree-contents .item:first').hasClass('selected')) { - $('#nav-sync').css('top','30px'); - } else { - $('#nav-sync').css('top','5px'); + topOffset+=25; } + $('#nav-sync').css('top',topOffset+'px'); showRoot(); } @@ -341,7 +347,7 @@ function showNode(o, node, index, hash) getScript(node.relpath+varName,function(){ node.childrenData = getData(varName); showNode(o,node,index,hash); - },true); + }); } else { if (!node.childrenVisited) { getNode(o, node); @@ -359,11 +365,11 @@ function showNode(o, node, index, hash) n.childrenData = getData(varName); node.expanded=false; showNode(o,node,index,hash); // retry with child node expanded - },true); + }); } else { var rootBase = stripPath(o.toroot.replace(/\..+$/, '')); if (rootBase=="index" || rootBase=="pages" || rootBase=="search") { - expandNode(o, n, true, true); + expandNode(o, n, true, false); } selectAndHighlight(hash,n); } @@ -441,7 +447,7 @@ function navTo(o,root,hash,relpath) if (navTreeSubIndices[i]) { gotoNode(o,i,root,hash,relpath); } - },true); + }); } } @@ -542,5 +548,12 @@ function initNavTree(toroot,relpath) navTo(o,toroot,hashUrl(),relpath); } }) + + $("div.toc a[href]").click(function(e) { + e.preventDefault(); + var docContent = $('#doc-content'); + var aname = $(this).attr("href"); + gotoAnchor($(aname),aname,true); + }) } /* @license-end */ diff --git a/navtreedata.js b/navtreedata.js index 034db7ec..60f3391b 100644 --- a/navtreedata.js +++ b/navtreedata.js @@ -25,18 +25,43 @@ var NAVTREE = [ [ "NCEPLIBS-w3emc", "index.html", [ + [ "Introduction", "index.html#autotoc_md0", [ + [ "GRIB1 Parameters", "index.html#autotoc_md1", null ], + [ "Reading GRIB1 Files", "index.html#autotoc_md2", null ], + [ "Packing and Writing GRIB1 Files", "index.html#autotoc_md3", null ], + [ "Product Definition Section", "index.html#autotoc_md4", null ], + [ "Grid Description Section", "index.html#autotoc_md5", null ], + [ "WMO Headers", "index.html#autotoc_md6", null ], + [ "Reading Formats", "index.html#autotoc_md7", null ], + [ "Index Files for GRIB1 Files", "index.html#autotoc_md8", null ], + [ "Bit and Byte Manipulation", "index.html#autotoc_md9", null ], + [ "Date/Time", "index.html#autotoc_md10", null ], + [ "Sorting", "index.html#autotoc_md11", null ], + [ "Error Handling", "index.html#autotoc_md12", null ], + [ "Command Line Arguments", "index.html#autotoc_md13", null ], + [ "Code Instrumentation", "index.html#autotoc_md14", null ], + [ "Dummy Subroutines", "index.html#autotoc_md15", null ], + [ "Conversions", "index.html#autotoc_md16", null ], + [ "Coordinates", "index.html#autotoc_md17", null ], + [ "Office-Note 85 Subroutines", "index.html#autotoc_md18", null ], + [ "9-Point Smoother", "index.html#autotoc_md19", null ], + [ "Printing", "index.html#autotoc_md20", null ], + [ "Transformation", "index.html#autotoc_md21", null ] + ] ], + [ "Documentation for Previous Versions", "index.html#autotoc_md22", null ], [ "Modules", "namespaces.html", [ - [ "NCEPLIBS-w3emc", "index.html#autotoc_md0", null ], - [ "Documentation for Previous Versions", "index.html#autotoc_md1", null ], - [ "Introduction", "index.html#autotoc_md2", null ], [ "Modules List", "namespaces.html", "namespaces_dup" ], [ "Module Members", "namespacemembers.html", [ [ "All", "namespacemembers.html", null ], [ "Functions/Subroutines", "namespacemembers_func.html", null ] ] ] ] ], - [ "Data Types List", "annotated.html", [ - [ "Data Types List", "annotated.html", "annotated_dup" ] + [ "Data Types", "annotated.html", [ + [ "Data Types List", "annotated.html", "annotated_dup" ], + [ "Data Fields", "functions.html", [ + [ "All", "functions.html", null ], + [ "Functions/Subroutines", "functions_func.html", null ] + ] ] ] ], [ "Files", "files.html", [ [ "File List", "files.html", "files_dup" ], @@ -51,10 +76,9 @@ var NAVTREE = var NAVTREEINDEX = [ "aea_8f.html", -"namespacemersenne__twister.html#a52fb0e5bfcfd792c8060b8fa96f20610", -"w3ai18_8f_source.html", -"w3fi85_8f.html#a17405ce8ebd7d06c0bedf0bea6ae2105", -"w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a" +"namespacemersenne__twister.html", +"w3fi63_8f.html#a275d433403624224a7d8da4c820b76be", +"w3ft21_8f.html" ]; var SYNCONMSG = 'click to disable panel synchronisation'; diff --git a/navtreeindex0.js b/navtreeindex0.js index fdb0ca27..af19f94d 100644 --- a/navtreeindex0.js +++ b/navtreeindex0.js @@ -1,253 +1,253 @@ var NAVTREEINDEX0 = { -"aea_8f.html":[2,0,0], -"aea_8f.html#a9c58c678406a71b9db512ab40864666c":[2,0,0,0], -"aea_8f_source.html":[2,0,0], -"annotated.html":[1,0], -"args__mod_8f.html":[2,0,1], -"args__mod_8f.html#a6abd46d69fad0b63bbdd0eddc14db1fe":[2,0,1,3], -"args__mod_8f.html#a7ba1ffe2c151a1c87049a23730fa9ea6":[2,0,1,2], -"args__mod_8f_source.html":[2,0,1], -"errexit_8f.html":[2,0,2], -"errexit_8f.html#abcd4c3fc1b8b684d5dc7b9412891de91":[2,0,2,0], -"errexit_8f_source.html":[2,0,2], -"errmsg_8f.html":[2,0,3], -"errmsg_8f.html#acb908fdaebb814b3210e63ecae74c996":[2,0,3,0], -"errmsg_8f_source.html":[2,0,3], -"files.html":[2,0], -"fparsei_8f.html":[2,0,4], -"fparsei_8f.html#a36e302a33bf921be9c7990e94ccc1a1f":[2,0,4,0], -"fparsei_8f_source.html":[2,0,4], -"fparser_8f.html":[2,0,5], -"fparser_8f.html#afd0eece805c9f9aa1afa5b5496298aa5":[2,0,5,0], -"fparser_8f_source.html":[2,0,5], -"gbyte_8f.html":[2,0,6], -"gbyte_8f.html#ad73b69048043b0e9876125b1d839e5c6":[2,0,6,0], -"gbyte_8f_source.html":[2,0,6], -"gbytec_8f.html":[2,0,7], -"gbytec_8f.html#adcae5457ea7270b3b95a379fec9233d7":[2,0,7,0], -"gbytec_8f_source.html":[2,0,7], -"gbytes_8f.html":[2,0,8], -"gbytes_8f.html#ac957b0c87f1261d8460c52bfec7d0308":[2,0,8,0], -"gbytes_8f_source.html":[2,0,8], -"gbytesc_8f.html":[2,0,9], -"gbytesc_8f.html#a8fd2d6beeef9feaf3ef1e927f66678db":[2,0,9,0], -"gbytesc_8f_source.html":[2,0,9], -"getbit_8f.html":[2,0,10], -"getbit_8f.html#a4f6601b376b03ad983fefd25058f1de9":[2,0,10,0], -"getbit_8f_source.html":[2,0,10], -"getgb1_8f.html":[2,0,12], -"getgb1_8f.html#a124fccd25cd6967ce2b5ba8629e3707c":[2,0,12,0], -"getgb1_8f_source.html":[2,0,12], -"getgb1r_8f.html":[2,0,13], -"getgb1r_8f.html#a38f437c2ae06e0aecb78f8841749a09d":[2,0,13,0], -"getgb1r_8f_source.html":[2,0,13], -"getgb1re_8f.html":[2,0,14], -"getgb1re_8f.html#a964db1a320f7b795dd353fbd292c06d7":[2,0,14,0], -"getgb1re_8f_source.html":[2,0,14], -"getgb1s_8f.html":[2,0,15], -"getgb1s_8f.html#a112566bbdfcf96f3ce3f7c5e2ba8618f":[2,0,15,0], -"getgb1s_8f_source.html":[2,0,15], -"getgb_8f.html":[2,0,11], -"getgb_8f.html#ab1cec03904b6e6c41840726cd53a69ce":[2,0,11,0], -"getgb_8f_source.html":[2,0,11], -"getgbe_8f.html":[2,0,16], -"getgbe_8f.html#a947b6d97db47adbcce8dde953f7e5de2":[2,0,16,0], -"getgbe_8f_source.html":[2,0,16], -"getgbeh_8f.html":[2,0,17], -"getgbeh_8f.html#ae52a0759ee42423a1ad4d714665cdb64":[2,0,17,0], -"getgbeh_8f_source.html":[2,0,17], -"getgbem_8f.html":[2,0,18], -"getgbem_8f.html#a1b647652df8027c1858a12f78234d246":[2,0,18,0], -"getgbem_8f_source.html":[2,0,18], -"getgbemh_8f.html":[2,0,19], -"getgbemh_8f.html#af515ecda0ec8361b15a4596b5773bd5f":[2,0,19,0], -"getgbemh_8f_source.html":[2,0,19], -"getgbemn_8f.html":[2,0,20], -"getgbemn_8f.html#aa8900c58b55dacd248734fa3e97c1482":[2,0,20,0], -"getgbemn_8f_source.html":[2,0,20], -"getgbemp_8f.html":[2,0,21], -"getgbemp_8f.html#a3703b88e4d6f0e0dc3a8643d7662137c":[2,0,21,0], -"getgbemp_8f_source.html":[2,0,21], -"getgbens_8f.html":[2,0,22], -"getgbens_8f.html#a0ab50ed386ca101b034a86b960de28b4":[2,0,22,0], -"getgbens_8f_source.html":[2,0,22], -"getgbep_8f.html":[2,0,23], -"getgbep_8f.html#a0f50efcce1cf858f28518c9f3dd19b40":[2,0,23,0], -"getgbep_8f_source.html":[2,0,23], -"getgbex_8f.html":[2,0,24], -"getgbex_8f.html#a2dec8fa1731d77d4d81cd9609f04f8f5":[2,0,24,0], -"getgbex_8f_source.html":[2,0,24], -"getgbexm_8f.html":[2,0,25], -"getgbexm_8f.html#ab15467040c53a0346d4857a0496c4762":[2,0,25,0], -"getgbexm_8f_source.html":[2,0,25], -"getgbh_8f.html":[2,0,26], -"getgbh_8f.html#ad15e85bb8f0d1057394c1732840fa128":[2,0,26,0], -"getgbh_8f_source.html":[2,0,26], -"getgbm_8f.html":[2,0,27], -"getgbm_8f.html#ac004e0201adb9928c5fada5c7372fd78":[2,0,27,0], -"getgbm_8f_source.html":[2,0,27], -"getgbmh_8f.html":[2,0,28], -"getgbmh_8f.html#ac4c2d81dcaf427548139d55ca7041022":[2,0,28,0], -"getgbmh_8f_source.html":[2,0,28], -"getgbmp_8f.html":[2,0,29], -"getgbmp_8f.html#a3dce03b33b45a2c4f9c859774615cb5a":[2,0,29,0], -"getgbmp_8f_source.html":[2,0,29], -"getgbp_8f.html":[2,0,30], -"getgbp_8f.html#afc5ba2c9bbd49e77d7a725bf08bcccfd":[2,0,30,0], -"getgbp_8f_source.html":[2,0,30], -"getgi_8f.html":[2,0,31], -"getgi_8f.html#aa6b511267e410648a9961a1aa2e4d27f":[2,0,31,0], -"getgi_8f_source.html":[2,0,31], -"getgir_8f.html":[2,0,32], -"getgir_8f.html#abcd2305cabdf6bb6a000fbb948c608a1":[2,0,32,0], -"getgir_8f_source.html":[2,0,32], -"globals.html":[2,1,0], -"globals.html":[2,1,0,0], -"globals_b.html":[2,1,0,1], -"globals_c.html":[2,1,0,2], -"globals_e.html":[2,1,0,3], -"globals_f.html":[2,1,0,4], -"globals_func.html":[2,1,1], -"globals_func.html":[2,1,1,0], -"globals_func_b.html":[2,1,1,1], -"globals_func_c.html":[2,1,1,2], -"globals_func_e.html":[2,1,1,3], -"globals_func_f.html":[2,1,1,4], -"globals_func_g.html":[2,1,1,5], -"globals_func_i.html":[2,1,1,6], -"globals_func_l.html":[2,1,1,7], -"globals_func_m.html":[2,1,1,8], -"globals_func_o.html":[2,1,1,9], -"globals_func_p.html":[2,1,1,10], -"globals_func_q.html":[2,1,1,11], -"globals_func_r.html":[2,1,1,12], -"globals_func_s.html":[2,1,1,13], -"globals_func_u.html":[2,1,1,14], -"globals_func_v.html":[2,1,1,15], -"globals_func_w.html":[2,1,1,16], -"globals_func_x.html":[2,1,1,17], -"globals_g.html":[2,1,0,5], -"globals_i.html":[2,1,0,6], -"globals_l.html":[2,1,0,7], -"globals_m.html":[2,1,0,8], -"globals_o.html":[2,1,0,9], -"globals_p.html":[2,1,0,10], -"globals_q.html":[2,1,0,11], -"globals_r.html":[2,1,0,12], -"globals_s.html":[2,1,0,13], -"globals_u.html":[2,1,0,14], -"globals_v.html":[2,1,0,15], -"globals_w.html":[2,1,0,16], -"globals_x.html":[2,1,0,17], -"gtbits_8f.html":[2,0,33], -"gtbits_8f.html#a31c0ebc8937002fb7b104298f8c439ec":[2,0,33,0], -"gtbits_8f_source.html":[2,0,33], -"idsdef_8f.html":[2,0,34], -"idsdef_8f.html#a55d6afd1ffb535e0b76701cd33c997e3":[2,0,34,0], -"idsdef_8f_source.html":[2,0,34], +"aea_8f.html":[4,0,0,0], +"aea_8f.html#a7658132d90c68ca690e04be7d7ef6681":[4,0,0,0,0], +"aea_8f_source.html":[4,0,0,0], +"annotated.html":[3,0], +"dir_68267d1309a1af8e8297ef4c3efbcdba.html":[4,0,0], +"errexit_8f.html":[4,0,0,1], +"errexit_8f.html#acdfe2a7413809994b26b8cbc335326d8":[4,0,0,1,0], +"errexit_8f_source.html":[4,0,0,1], +"errmsg_8f.html":[4,0,0,2], +"errmsg_8f.html#aa029ec617c24e6ff25756009764a254a":[4,0,0,2,0], +"errmsg_8f_source.html":[4,0,0,2], +"files.html":[4,0], +"fparsei_8f.html":[4,0,0,3], +"fparsei_8f.html#a3f5e219fe4f03b8ccb20e4a7e5cbe832":[4,0,0,3,0], +"fparsei_8f_source.html":[4,0,0,3], +"fparser_8f.html":[4,0,0,4], +"fparser_8f.html#a614ee9606f217b051a2643684051df50":[4,0,0,4,0], +"fparser_8f_source.html":[4,0,0,4], +"functions.html":[3,1,0], +"functions_func.html":[3,1,1], +"gbyte_8f.html":[4,0,0,5], +"gbyte_8f.html#ad8ac424552647ef42f4b054733f7b7b1":[4,0,0,5,0], +"gbyte_8f_source.html":[4,0,0,5], +"gbytec_8f.html":[4,0,0,6], +"gbytec_8f.html#a43bd8d585799cf64eb09804156200064":[4,0,0,6,0], +"gbytec_8f_source.html":[4,0,0,6], +"gbytes_8f.html":[4,0,0,7], +"gbytes_8f.html#a69f5a171f262da1e5a75f8a3810f4a82":[4,0,0,7,0], +"gbytes_8f_source.html":[4,0,0,7], +"gbytesc_8f.html":[4,0,0,8], +"gbytesc_8f.html#ad46c14caec87fa3f7d379d52fd8173bc":[4,0,0,8,0], +"gbytesc_8f_source.html":[4,0,0,8], +"getbit_8f.html":[4,0,0,9], +"getbit_8f.html#a4d5fdf661844c7978d879e815608d8f0":[4,0,0,9,0], +"getbit_8f_source.html":[4,0,0,9], +"getgb1_8f.html":[4,0,0,11], +"getgb1_8f.html#a75aa7f2cd8878c41dc74056854b7bade":[4,0,0,11,0], +"getgb1_8f_source.html":[4,0,0,11], +"getgb1r_8f.html":[4,0,0,12], +"getgb1r_8f.html#a982dff5bb7d495326427c13fc654d7bb":[4,0,0,12,0], +"getgb1r_8f_source.html":[4,0,0,12], +"getgb1re_8f.html":[4,0,0,13], +"getgb1re_8f.html#a58c5662f20d4a9ed1881394b25818565":[4,0,0,13,0], +"getgb1re_8f_source.html":[4,0,0,13], +"getgb1s_8f.html":[4,0,0,14], +"getgb1s_8f.html#a5005a2bc8cb1f85d4ab9d897c73e8344":[4,0,0,14,0], +"getgb1s_8f_source.html":[4,0,0,14], +"getgb_8f.html":[4,0,0,10], +"getgb_8f.html#a98040aebeda65b55ed5c61d891e49ccf":[4,0,0,10,0], +"getgb_8f_source.html":[4,0,0,10], +"getgbe_8f.html":[4,0,0,15], +"getgbe_8f.html#a131d2957b2e9ec6248fde892f7c82a01":[4,0,0,15,0], +"getgbe_8f_source.html":[4,0,0,15], +"getgbeh_8f.html":[4,0,0,16], +"getgbeh_8f.html#a880ba6974d201e5b100eda8d57251dbe":[4,0,0,16,0], +"getgbeh_8f_source.html":[4,0,0,16], +"getgbem_8f.html":[4,0,0,17], +"getgbem_8f.html#a52148a120ff1d3de25afdc5e7843c3e9":[4,0,0,17,0], +"getgbem_8f_source.html":[4,0,0,17], +"getgbemh_8f.html":[4,0,0,18], +"getgbemh_8f.html#a0cfcd2b0adf1907f29efd836cee13554":[4,0,0,18,0], +"getgbemh_8f_source.html":[4,0,0,18], +"getgbemn_8f.html":[4,0,0,19], +"getgbemn_8f.html#aac1e0617524cfcef1651f92133f0c959":[4,0,0,19,0], +"getgbemn_8f_source.html":[4,0,0,19], +"getgbemp_8f.html":[4,0,0,20], +"getgbemp_8f.html#a6f58776aeb1ed2f7e367bf4a01a1ad35":[4,0,0,20,0], +"getgbemp_8f_source.html":[4,0,0,20], +"getgbens_8f.html":[4,0,0,21], +"getgbens_8f.html#ac722b1ceb7e6a1af1c810c6c84434dcf":[4,0,0,21,0], +"getgbens_8f_source.html":[4,0,0,21], +"getgbep_8f.html":[4,0,0,22], +"getgbep_8f.html#a9cbd8064fd141a45c07846c00931eab0":[4,0,0,22,0], +"getgbep_8f_source.html":[4,0,0,22], +"getgbex_8f.html":[4,0,0,23], +"getgbex_8f.html#a6767d5f6b448d03e5f0a154bf7ed4090":[4,0,0,23,0], +"getgbex_8f_source.html":[4,0,0,23], +"getgbexm_8f.html":[4,0,0,24], +"getgbexm_8f.html#a660f20529705ee3731e6544771eedf4d":[4,0,0,24,0], +"getgbexm_8f_source.html":[4,0,0,24], +"getgbh_8f.html":[4,0,0,25], +"getgbh_8f.html#afe4595036ec84fc5868e9a0cdaa75a4c":[4,0,0,25,0], +"getgbh_8f_source.html":[4,0,0,25], +"getgbm_8f.html":[4,0,0,26], +"getgbm_8f.html#a13e5b7b94989de452f47d062a917e8f9":[4,0,0,26,0], +"getgbm_8f_source.html":[4,0,0,26], +"getgbmh_8f.html":[4,0,0,27], +"getgbmh_8f.html#a0fe386a75ceff44f8914bc6d883c28f4":[4,0,0,27,0], +"getgbmh_8f_source.html":[4,0,0,27], +"getgbmp_8f.html":[4,0,0,28], +"getgbmp_8f.html#a87989f48a32883137be354ba99db080b":[4,0,0,28,0], +"getgbmp_8f_source.html":[4,0,0,28], +"getgbp_8f.html":[4,0,0,29], +"getgbp_8f.html#ab997b10791523905a4bbd1c6d3d4d258":[4,0,0,29,0], +"getgbp_8f_source.html":[4,0,0,29], +"getgi_8f.html":[4,0,0,30], +"getgi_8f.html#acdad122216fa099a6a3a45cbf85ec1c2":[4,0,0,30,0], +"getgi_8f_source.html":[4,0,0,30], +"getgir_8f.html":[4,0,0,31], +"getgir_8f.html#a1d594876e11881c99690d52b4091849f":[4,0,0,31,0], +"getgir_8f_source.html":[4,0,0,31], +"globals.html":[4,1,0], +"globals.html":[4,1,0,0], +"globals_b.html":[4,1,0,1], +"globals_c.html":[4,1,0,2], +"globals_e.html":[4,1,0,3], +"globals_f.html":[4,1,0,4], +"globals_func.html":[4,1,1,0], +"globals_func.html":[4,1,1], +"globals_func_b.html":[4,1,1,1], +"globals_func_c.html":[4,1,1,2], +"globals_func_e.html":[4,1,1,3], +"globals_func_f.html":[4,1,1,4], +"globals_func_g.html":[4,1,1,5], +"globals_func_i.html":[4,1,1,6], +"globals_func_l.html":[4,1,1,7], +"globals_func_m.html":[4,1,1,8], +"globals_func_o.html":[4,1,1,9], +"globals_func_p.html":[4,1,1,10], +"globals_func_q.html":[4,1,1,11], +"globals_func_r.html":[4,1,1,12], +"globals_func_s.html":[4,1,1,13], +"globals_func_u.html":[4,1,1,14], +"globals_func_v.html":[4,1,1,15], +"globals_func_w.html":[4,1,1,16], +"globals_func_x.html":[4,1,1,17], +"globals_g.html":[4,1,0,5], +"globals_i.html":[4,1,0,6], +"globals_l.html":[4,1,0,7], +"globals_m.html":[4,1,0,8], +"globals_o.html":[4,1,0,9], +"globals_p.html":[4,1,0,10], +"globals_q.html":[4,1,0,11], +"globals_r.html":[4,1,0,12], +"globals_s.html":[4,1,0,13], +"globals_u.html":[4,1,0,14], +"globals_v.html":[4,1,0,15], +"globals_w.html":[4,1,0,16], +"globals_x.html":[4,1,0,17], +"gtbits_8f.html":[4,0,0,32], +"gtbits_8f.html#a0f90e24d4c196fe0bdf31f938110c704":[4,0,0,32,0], +"gtbits_8f_source.html":[4,0,0,32], +"idsdef_8f.html":[4,0,0,33], +"idsdef_8f.html#af116d5532c9d7b1e288ff59b1e75800c":[4,0,0,33,0], +"idsdef_8f_source.html":[4,0,0,33], "index.html":[], "index.html#autotoc_md0":[0], -"index.html#autotoc_md1":[1], -"index.html#autotoc_md2":[2], -"instrument_8f.html":[2,0,35], -"instrument_8f.html#a1bf5314dfe3e0adf03773a63dadf6173":[2,0,35,0], -"instrument_8f_source.html":[2,0,35], -"interfaceargs__mod_1_1getarg.html":[1,0,0,0], -"interfaceargs__mod_1_1getarg.html#a61fa2902b253a2ff76970e6ff787ee18":[1,0,0,0,1], -"interfaceargs__mod_1_1getarg.html#aeb54b5295376abb7ec7b2a6a2de13613":[1,0,0,0,0], -"interfaceargs__mod_1_1iargc.html":[1,0,0,1], -"interfaceargs__mod_1_1iargc.html#af4538b3ec9b539460c2490f71df060c9":[1,0,0,1,0], -"isrchne_8f.html":[2,0,36], -"isrchne_8f.html#aa2ad73a774eaa79cc4134b5a30210c19":[2,0,36,0], -"isrchne_8f_source.html":[2,0,36], -"iw3jdn_8f.html":[2,0,37], -"iw3jdn_8f.html#accbe8d5a05413129a72efa183f1fa3b6":[2,0,37,0], -"iw3jdn_8f_source.html":[2,0,37], -"iw3mat_8f.html":[2,0,38], -"iw3mat_8f.html#a2fba35a09957d0d2a2e37b8c63e9ef4f":[2,0,38,0], -"iw3mat_8f_source.html":[2,0,38], -"iw3pds_8f.html":[2,0,39], -"iw3pds_8f.html#a445f0e2409ada1e8ece3e1a24f9cd361":[2,0,39,0], -"iw3pds_8f_source.html":[2,0,39], -"iw3unp29_8f.html":[2,0,40], -"iw3unp29_8f.html#a0d3c45449c312f0e99cdb92777a3220a":[2,0,40,2], -"iw3unp29_8f.html#a128244e0131b7729a0cd5a8394884823":[2,0,40,1], -"iw3unp29_8f.html#a1de5e205645a3843697845185ffaaeb1":[2,0,40,7], -"iw3unp29_8f.html#a2ad28b39cd4d3b38df93a51a15a56555":[2,0,40,19], -"iw3unp29_8f.html#a2d15cb33d16ceab9921e8add94c30a42":[2,0,40,21], -"iw3unp29_8f.html#a416026063ded48e8480b8e3b0896e74c":[2,0,40,14], -"iw3unp29_8f.html#a46ccc2cccd3cb6bcd7b03d70675f4ca1":[2,0,40,13], -"iw3unp29_8f.html#a46e52ce72580afe04ee309c16200108b":[2,0,40,12], -"iw3unp29_8f.html#a50f37364b576374fbe3c899bf5ba8d0b":[2,0,40,16], -"iw3unp29_8f.html#a7ae1a11087922d6d32c47d99994dc861":[2,0,40,8], -"iw3unp29_8f.html#a8734122f4e8dc4d7c3bee6b20163dc3f":[2,0,40,5], -"iw3unp29_8f.html#a89e6f36d2a7dae698c0dff8a77b078a2":[2,0,40,6], -"iw3unp29_8f.html#a93f8486c638db70b2a2a61ac05bcdcac":[2,0,40,15], -"iw3unp29_8f.html#abde82aa52df7bac07bc64ff10e069651":[2,0,40,17], -"iw3unp29_8f.html#abf74c81fb101796c5ab245b59b0ab2ad":[2,0,40,11], -"iw3unp29_8f.html#ac80679ca645813f0da98c23fe6bc79a4":[2,0,40,20], -"iw3unp29_8f.html#ada2cb47a16ee97b27de331a013882382":[2,0,40,18], -"iw3unp29_8f.html#ade469dc7a458658c23096016179ff9e2":[2,0,40,0], -"iw3unp29_8f.html#ae23b98e3d9c9097a9ea45e9473aee287":[2,0,40,10], -"iw3unp29_8f.html#ae9e0c357df4d0c782d851fdd8ce09e14":[2,0,40,3], -"iw3unp29_8f.html#af0213dc1cf8d73c372bcacc88c16fdf9":[2,0,40,4], -"iw3unp29_8f.html#af252340bc4d8811a4d6e799bdf1c3790":[2,0,40,9], -"iw3unp29_8f_source.html":[2,0,40], -"ixgb_8f.html":[2,0,41], -"ixgb_8f.html#a21b5f70c2205bfb68df79fbb83928066":[2,0,41,0], -"ixgb_8f_source.html":[2,0,41], -"lengds_8f.html":[2,0,42], -"lengds_8f.html#a53ab57aefe7c9277606708b4c8af7b00":[2,0,42,0], -"lengds_8f_source.html":[2,0,42], -"makgds_8f90_source.html":[2,0,43], -"makwmo_8f.html":[2,0,44], -"makwmo_8f.html#a8fd8c7e636856ca63ccdd4a0d786636d":[2,0,44,0], -"makwmo_8f_source.html":[2,0,44], -"mersenne__twister_8f.html":[2,0,45], -"mersenne__twister_8f.html#a017f5f4708314e41f34e087c48a44daf":[2,0,45,13], -"mersenne__twister_8f.html#a18afbd0bb0326af3129bc4bec59aee46":[2,0,45,22], -"mersenne__twister_8f.html#a2373934764432b7b64b31c4e82340a34":[2,0,45,23], -"mersenne__twister_8f.html#a3652cf0177c16351a259362f05c52be6":[2,0,45,11], -"mersenne__twister_8f.html#a4e3b13adf5b25114f982e3e977bef004":[2,0,45,3], -"mersenne__twister_8f.html#a52fb0e5bfcfd792c8060b8fa96f20610":[2,0,45,10], -"mersenne__twister_8f.html#a58ab3b5d65dcd05266b45662309f5f55":[2,0,45,16], -"mersenne__twister_8f.html#a6385e50a4db3a7ca25b92d761374957b":[2,0,45,17], -"mersenne__twister_8f.html#a6a4ca59c1e8484f3d42a3e9dc7a693b0":[2,0,45,18], -"mersenne__twister_8f.html#a6ab34baf3b5aece50818d2c7cc4357b7":[2,0,45,21], -"mersenne__twister_8f.html#a70e1a1b6a0642c45700bcb0e01a16b6b":[2,0,45,15], -"mersenne__twister_8f.html#a715dd6280653ef8f2b0a6cd7076d870d":[2,0,45,9], -"mersenne__twister_8f.html#a722ec0932b5a922b6c91aec4b658adef":[2,0,45,26], -"mersenne__twister_8f.html#a72d5b1cd21e6af407325bb8b0e18481a":[2,0,45,8], -"mersenne__twister_8f.html#a9b5f511523152deb897819b9f5b35dba":[2,0,45,6], -"mersenne__twister_8f.html#a9c03281caf481123f41fac129244685c":[2,0,45,7], -"mersenne__twister_8f.html#a9c1b3fcd1cb4e6b20a46607a0991e75c":[2,0,45,5], -"mersenne__twister_8f.html#ab0fb126acb98e7500c8fda1aa4508ddb":[2,0,45,24], -"mersenne__twister_8f.html#ab5807578f927f719be280774b17803ad":[2,0,45,12], -"mersenne__twister_8f.html#ab7560f4ac03fad6c0c5b1a393ab7af80":[2,0,45,1], -"mersenne__twister_8f.html#acc59b5b06bcd98e292ffeaeae88c9c5e":[2,0,45,4], -"mersenne__twister_8f.html#acd01aa05ecfbe1c3283dc3552fc9a437":[2,0,45,0], -"mersenne__twister_8f.html#acf08832d5cbe3032b51a9f67a1b89c05":[2,0,45,20], -"mersenne__twister_8f.html#ad3e61a71aa72a0b9654626b15296dbec":[2,0,45,2], -"mersenne__twister_8f.html#adf6d74a10cc19bef891508c741282476":[2,0,45,19], -"mersenne__twister_8f.html#ae7c1227f3e7c3774b3731a3ee2f4e519":[2,0,45,14], -"mersenne__twister_8f.html#ae97528980ebbb1a68b7b0787721cb543":[2,0,45,25], -"mersenne__twister_8f_source.html":[2,0,45], -"mkfldsep_8f.html":[2,0,46], -"mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045":[2,0,46,0], -"mkfldsep_8f_source.html":[2,0,46], -"mova2i_8f.html":[2,0,47], -"mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0":[2,0,47,0], -"mova2i_8f_source.html":[2,0,47], -"namespaceargs__mod.html":[0,3,0], -"namespaceargs__mod.html#a6abd46d69fad0b63bbdd0eddc14db1fe":[0,3,0,3], -"namespaceargs__mod.html#a7ba1ffe2c151a1c87049a23730fa9ea6":[0,3,0,2], -"namespacemembers.html":[0,4,0], -"namespacemembers_func.html":[0,4,1], -"namespacemersenne__twister.html":[0,3,1], -"namespacemersenne__twister.html#a017f5f4708314e41f34e087c48a44daf":[0,3,1,13], -"namespacemersenne__twister.html#a18afbd0bb0326af3129bc4bec59aee46":[0,3,1,21], -"namespacemersenne__twister.html#a2373934764432b7b64b31c4e82340a34":[0,3,1,22], -"namespacemersenne__twister.html#a3652cf0177c16351a259362f05c52be6":[0,3,1,11], -"namespacemersenne__twister.html#a4e3b13adf5b25114f982e3e977bef004":[0,3,1,3] +"index.html#autotoc_md1":[0,0], +"index.html#autotoc_md10":[0,9], +"index.html#autotoc_md11":[0,10], +"index.html#autotoc_md12":[0,11], +"index.html#autotoc_md13":[0,12], +"index.html#autotoc_md14":[0,13], +"index.html#autotoc_md15":[0,14], +"index.html#autotoc_md16":[0,15], +"index.html#autotoc_md17":[0,16], +"index.html#autotoc_md18":[0,17], +"index.html#autotoc_md19":[0,18], +"index.html#autotoc_md2":[0,1], +"index.html#autotoc_md20":[0,19], +"index.html#autotoc_md21":[0,20], +"index.html#autotoc_md22":[1], +"index.html#autotoc_md3":[0,2], +"index.html#autotoc_md4":[0,3], +"index.html#autotoc_md5":[0,4], +"index.html#autotoc_md6":[0,5], +"index.html#autotoc_md7":[0,6], +"index.html#autotoc_md8":[0,7], +"index.html#autotoc_md9":[0,8], +"instrument_8f.html":[4,0,0,34], +"instrument_8f.html#a9e01b91f60a070be2a253f818d3d9732":[4,0,0,34,0], +"instrument_8f_source.html":[4,0,0,34], +"interfacemersenne__twister_1_1random__gauss.html":[2,0,0,0], +"interfacemersenne__twister_1_1random__gauss.html":[3,0,0,0], +"interfacemersenne__twister_1_1random__gauss.html#a2ab29e2f6e4efe8ffd858ff257747173":[3,0,0,0,0], +"interfacemersenne__twister_1_1random__gauss.html#a2ab29e2f6e4efe8ffd858ff257747173":[2,0,0,0,0], +"interfacemersenne__twister_1_1random__gauss.html#a50af58f1f0525f0d68b14e6362305b1c":[3,0,0,0,1], +"interfacemersenne__twister_1_1random__gauss.html#a50af58f1f0525f0d68b14e6362305b1c":[2,0,0,0,1], +"interfacemersenne__twister_1_1random__gauss.html#afea5a15176c49f9829db24f555692278":[3,0,0,0,2], +"interfacemersenne__twister_1_1random__gauss.html#afea5a15176c49f9829db24f555692278":[2,0,0,0,2], +"interfacemersenne__twister_1_1random__index.html":[2,0,0,1], +"interfacemersenne__twister_1_1random__index.html":[3,0,0,1], +"interfacemersenne__twister_1_1random__index.html#ab4356f122440e3e8eb2eccfd16968c84":[3,0,0,1,1], +"interfacemersenne__twister_1_1random__index.html#ab4356f122440e3e8eb2eccfd16968c84":[2,0,0,1,1], +"interfacemersenne__twister_1_1random__index.html#adb086879ee9eabb64d4026daacf40567":[2,0,0,1,0], +"interfacemersenne__twister_1_1random__index.html#adb086879ee9eabb64d4026daacf40567":[3,0,0,1,0], +"interfacemersenne__twister_1_1random__index.html#af137b7c612966c256b47c9949f8095ba":[3,0,0,1,2], +"interfacemersenne__twister_1_1random__index.html#af137b7c612966c256b47c9949f8095ba":[2,0,0,1,2], +"interfacemersenne__twister_1_1random__number.html":[2,0,0,2], +"interfacemersenne__twister_1_1random__number.html":[3,0,0,2], +"interfacemersenne__twister_1_1random__number.html#a0f53661cf413d88e71aef77a9a9468ae":[2,0,0,2,2], +"interfacemersenne__twister_1_1random__number.html#a0f53661cf413d88e71aef77a9a9468ae":[3,0,0,2,2], +"interfacemersenne__twister_1_1random__number.html#a4df934289beedb0e333c1260489949e6":[3,0,0,2,0], +"interfacemersenne__twister_1_1random__number.html#a4df934289beedb0e333c1260489949e6":[2,0,0,2,0], +"interfacemersenne__twister_1_1random__number.html#a94e918a10214cfe0c24c303d220452e7":[3,0,0,2,1], +"interfacemersenne__twister_1_1random__number.html#a94e918a10214cfe0c24c303d220452e7":[2,0,0,2,1], +"interfacemersenne__twister_1_1random__setseed.html":[2,0,0,3], +"interfacemersenne__twister_1_1random__setseed.html":[3,0,0,3], +"interfacemersenne__twister_1_1random__setseed.html#a21dac133ee7db7e53a1161f36efe9d11":[2,0,0,3,1], +"interfacemersenne__twister_1_1random__setseed.html#a21dac133ee7db7e53a1161f36efe9d11":[3,0,0,3,1], +"interfacemersenne__twister_1_1random__setseed.html#af25a7d71ddbad282dd5eb407c0bd907d":[2,0,0,3,0], +"interfacemersenne__twister_1_1random__setseed.html#af25a7d71ddbad282dd5eb407c0bd907d":[3,0,0,3,0], +"isrchne_8f.html":[4,0,0,35], +"isrchne_8f.html#a53cf06203460280eb4f894b66282b5fd":[4,0,0,35,0], +"isrchne_8f_source.html":[4,0,0,35], +"iw3jdn_8f.html":[4,0,0,36], +"iw3jdn_8f.html#a2bb3a8c7551117779d303813bf2d7a2c":[4,0,0,36,0], +"iw3jdn_8f_source.html":[4,0,0,36], +"iw3mat_8f.html":[4,0,0,37], +"iw3mat_8f.html#aa53ca2552f7a06ad9141f16197b82fda":[4,0,0,37,0], +"iw3mat_8f_source.html":[4,0,0,37], +"iw3pds_8f.html":[4,0,0,38], +"iw3pds_8f.html#ab3b0c789b44fe2ae4b1422c6beb6a4f1":[4,0,0,38,0], +"iw3pds_8f_source.html":[4,0,0,38], +"iw3unp29_8f.html":[4,0,0,39], +"iw3unp29_8f.html#a291446927c470179df611e56fbc0ff6f":[4,0,0,39,3], +"iw3unp29_8f.html#a5cb8ae5d00bc1141f789b08555083739":[4,0,0,39,4], +"iw3unp29_8f.html#a687b1ecdce871d1cf438f4fb2be95425":[4,0,0,39,1], +"iw3unp29_8f.html#a79f04733a38667022a957e6c1b9093b6":[4,0,0,39,5], +"iw3unp29_8f.html#a83aa538c2e5a51c40a981974247d82c7":[4,0,0,39,2], +"iw3unp29_8f.html#a8f442c71c59f776fbf89cfed665f90a4":[4,0,0,39,0], +"iw3unp29_8f.html#aaa7ab7bf0bec88768b0fcb9921f07ff1":[4,0,0,39,7], +"iw3unp29_8f.html#af86e22354050944e4507e85c314114a0":[4,0,0,39,6], +"iw3unp29_8f_source.html":[4,0,0,39], +"ixgb_8f.html":[4,0,0,40], +"ixgb_8f.html#ab80631a0d3fc8e1450bee116bc16e205":[4,0,0,40,0], +"ixgb_8f_source.html":[4,0,0,40], +"lengds_8f.html":[4,0,0,41], +"lengds_8f.html#af9d4e4b97b2d11e238290791aad2b989":[4,0,0,41,0], +"lengds_8f_source.html":[4,0,0,41], +"makgds_8f90.html":[4,0,0,42], +"makgds_8f90.html#a132c655a1a21b17ef23ee83108d7d4ac":[4,0,0,42,0], +"makgds_8f90_source.html":[4,0,0,42], +"makwmo_8f.html":[4,0,0,43], +"makwmo_8f.html#acb3df40c99edbb45efe0d6b9a53af7de":[4,0,0,43,0], +"makwmo_8f_source.html":[4,0,0,43], +"mersenne__twister_8f.html":[4,0,0,44], +"mersenne__twister_8f.html#a72d5b1cd21e6af407325bb8b0e18481a":[4,0,0,44,7], +"mersenne__twister_8f.html#ab5807578f927f719be280774b17803ad":[4,0,0,44,8], +"mersenne__twister_8f.html#acc59b5b06bcd98e292ffeaeae88c9c5e":[4,0,0,44,6], +"mersenne__twister_8f.html#acd01aa05ecfbe1c3283dc3552fc9a437":[4,0,0,44,5], +"mersenne__twister_8f_source.html":[4,0,0,44], +"mkfldsep_8f.html":[4,0,0,45], +"mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045":[4,0,0,45,0], +"mkfldsep_8f_source.html":[4,0,0,45], +"mova2i_8f.html":[4,0,0,46], +"mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0":[4,0,0,46,0], +"mova2i_8f_source.html":[4,0,0,46], +"namespacemembers.html":[2,1,0], +"namespacemembers_func.html":[2,1,1] }; diff --git a/navtreeindex1.js b/navtreeindex1.js index 6f362616..427be65c 100644 --- a/navtreeindex1.js +++ b/navtreeindex1.js @@ -1,253 +1,253 @@ var NAVTREEINDEX1 = { -"namespacemersenne__twister.html#a52fb0e5bfcfd792c8060b8fa96f20610":[0,3,1,10], -"namespacemersenne__twister.html#a58ab3b5d65dcd05266b45662309f5f55":[0,3,1,15], -"namespacemersenne__twister.html#a6385e50a4db3a7ca25b92d761374957b":[0,3,1,16], -"namespacemersenne__twister.html#a6a4ca59c1e8484f3d42a3e9dc7a693b0":[0,3,1,17], -"namespacemersenne__twister.html#a6ab34baf3b5aece50818d2c7cc4357b7":[0,3,1,20], -"namespacemersenne__twister.html#a715dd6280653ef8f2b0a6cd7076d870d":[0,3,1,9], -"namespacemersenne__twister.html#a722ec0932b5a922b6c91aec4b658adef":[0,3,1,25], -"namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a":[0,3,1,8], -"namespacemersenne__twister.html#a9b5f511523152deb897819b9f5b35dba":[0,3,1,6], -"namespacemersenne__twister.html#a9c03281caf481123f41fac129244685c":[0,3,1,7], -"namespacemersenne__twister.html#a9c1b3fcd1cb4e6b20a46607a0991e75c":[0,3,1,5], -"namespacemersenne__twister.html#ab0fb126acb98e7500c8fda1aa4508ddb":[0,3,1,23], -"namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad":[0,3,1,12], -"namespacemersenne__twister.html#ab7560f4ac03fad6c0c5b1a393ab7af80":[0,3,1,1], -"namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e":[0,3,1,4], -"namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437":[0,3,1,0], -"namespacemersenne__twister.html#acf08832d5cbe3032b51a9f67a1b89c05":[0,3,1,19], -"namespacemersenne__twister.html#ad3e61a71aa72a0b9654626b15296dbec":[0,3,1,2], -"namespacemersenne__twister.html#adf6d74a10cc19bef891508c741282476":[0,3,1,18], -"namespacemersenne__twister.html#ae7c1227f3e7c3774b3731a3ee2f4e519":[0,3,1,14], -"namespacemersenne__twister.html#ae97528980ebbb1a68b7b0787721cb543":[0,3,1,24], -"namespaces.html":[0,3], -"orders_8f.html":[2,0,48], -"orders_8f.html#a0d08639e724c57aca8fba5548dac6670":[2,0,48,0], -"orders_8f.html#a311c2453b613d259dc8e998f6d6aa944":[2,0,48,3], -"orders_8f.html#a384818081314939dbda21524cf8efc95":[2,0,48,2], -"orders_8f.html#a67b0efbe9479a73fe938f47f80520c50":[2,0,48,1], -"orders_8f_source.html":[2,0,48], +"namespacemersenne__twister.html":[2,0,0], +"namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a":[2,0,0,7], +"namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad":[2,0,0,8], +"namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e":[2,0,0,6], +"namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437":[2,0,0,5], +"namespaces.html":[2,0], +"orders_8f.html":[4,0,0,47], +"orders_8f.html#a606ed1b385c755d9ebbc4de760349893":[4,0,0,47,0], +"orders_8f_source.html":[4,0,0,47], "pages.html":[], -"pdsens_8f.html":[2,0,49], -"pdsens_8f.html#ac0ab2fe3df3fc664f2c413214700206e":[2,0,49,0], -"pdsens_8f_source.html":[2,0,49], -"pdseup_8f.html":[2,0,50], -"pdseup_8f.html#a62cf775ad87c64a28b7e395792eabfca":[2,0,50,0], -"pdseup_8f_source.html":[2,0,50], -"putgb_8f.html":[2,0,51], -"putgb_8f.html#aa61b5b2b00eb09531ef126983ad1d724":[2,0,51,0], -"putgb_8f_source.html":[2,0,51], -"putgbe_8f.html":[2,0,52], -"putgbe_8f.html#aff43ef1fa54eed421433340d5954fcfe":[2,0,52,0], -"putgbe_8f_source.html":[2,0,52], -"putgben_8f.html":[2,0,53], -"putgben_8f.html#a094e5a410a4e995f25665a750ac2bc8c":[2,0,53,0], -"putgben_8f_source.html":[2,0,53], -"putgbens_8f.html":[2,0,54], -"putgbens_8f.html#a1a125225f33ac856c34ce692adeef0b2":[2,0,54,0], -"putgbens_8f_source.html":[2,0,54], -"putgbex_8f.html":[2,0,55], -"putgbex_8f.html#a64977c953757490ae3b8b72a5fd7c4cb":[2,0,55,0], -"putgbex_8f_source.html":[2,0,55], -"putgbn_8f.html":[2,0,56], -"putgbn_8f.html#ad639ec06d322cda9f568c75b98aacc67":[2,0,56,0], -"putgbn_8f_source.html":[2,0,56], -"q9ie32_8f.html":[2,0,57], -"q9ie32_8f.html#a7cfc294cd548b96adbe4ccd72fc656c1":[2,0,57,0], -"q9ie32_8f_source.html":[2,0,57], -"r63w72_8f.html":[2,0,58], -"r63w72_8f.html#a071601493ea893c59ed2b8fac3cf9116":[2,0,58,0], -"r63w72_8f_source.html":[2,0,58], -"sbyte_8f.html":[2,0,59], -"sbyte_8f.html#afbbfa5a4daed1898e1235a221dcf54b2":[2,0,59,0], -"sbyte_8f_source.html":[2,0,59], -"sbytec_8f.html":[2,0,60], -"sbytec_8f.html#aa252e1e9e9f8808f95473792d319231b":[2,0,60,0], -"sbytec_8f_source.html":[2,0,60], -"sbytes_8f.html":[2,0,61], -"sbytes_8f.html#a1035e9be6e9ea85af3581de7da3e90bc":[2,0,61,0], -"sbytes_8f_source.html":[2,0,61], -"sbytesc_8f.html":[2,0,62], -"sbytesc_8f.html#aa527f56385adc86efba0d8605f251088":[2,0,62,0], -"sbytesc_8f_source.html":[2,0,62], -"skgb_8f.html":[2,0,63], -"skgb_8f.html#a7654c30923c8fa28091b5cb300c93311":[2,0,63,0], -"skgb_8f_source.html":[2,0,63], -"summary_8c.html":[2,0,64], -"summary_8c.html#a013eb31a0d2f7caf88a59e53b4dbb10c":[2,0,64,135], -"summary_8c.html#a01ef0e511f889598d8bea5fcccd9e474":[2,0,64,127], -"summary_8c.html#a0681b3770e0eb8056e2ed3e35310da4a":[2,0,64,92], -"summary_8c.html#a0a36e75197127097bdffaa9bb9689768":[2,0,64,124], -"summary_8c.html#a0ac76d4f1d76d40d499700499781885b":[2,0,64,38], -"summary_8c.html#a0b30c3f65ce506a2a04098e0d2c31c64":[2,0,64,126], -"summary_8c.html#a0d299f4055cfd86606b089e19be86621":[2,0,64,10], -"summary_8c.html#a103ed1c4797d36d7418f3e8a3fc8dffe":[2,0,64,33], -"summary_8c.html#a118cad54a817ac93b88012250dd6ce16":[2,0,64,138], -"summary_8c.html#a124310bdb5f17de6f56ccc25194dede0":[2,0,64,52], -"summary_8c.html#a13ee506c2a8d4c6a1c9bb2ca6af24338":[2,0,64,60], -"summary_8c.html#a144e9a3ce7f907c1f5a909030aa1d23e":[2,0,64,121], -"summary_8c.html#a165395c8ebe7c4039f84bbbe969e2c44":[2,0,64,71], -"summary_8c.html#a1708f19bbcbee673142de58879a995a9":[2,0,64,73], -"summary_8c.html#a19d4b62d0047d54a3296076522d40f6e":[2,0,64,98], -"summary_8c.html#a1c5e2b28e66709fe08d97343a92d4826":[2,0,64,101], -"summary_8c.html#a1da536176214b2e7b5ccaab09c3da934":[2,0,64,63], -"summary_8c.html#a2245ce70794b38eeb74b9bb980d4e443":[2,0,64,57], -"summary_8c.html#a23dd794cefb7971ff0ca30772a34431b":[2,0,64,27], -"summary_8c.html#a26c99f29011e8cdf3258177c223de426":[2,0,64,41], -"summary_8c.html#a2a8359613c949a5a3f6455f561d4c5ad":[2,0,64,56], -"summary_8c.html#a2c6b7c1f73844eae1ecd931d1bfc55c3":[2,0,64,130], -"summary_8c.html#a2cdf05b0a53642321b7107358118bd0d":[2,0,64,120], -"summary_8c.html#a2f75be153f43f026a70f3df9b651ce3b":[2,0,64,146], -"summary_8c.html#a304efc367f6903d35848e20233315218":[2,0,64,23], -"summary_8c.html#a31331609bb19c361321575e990585798":[2,0,64,64], -"summary_8c.html#a32d9b2f126d7ea1c9dfbd07a564b1f27":[2,0,64,134], -"summary_8c.html#a332b1d3c4af749906617bb41764246de":[2,0,64,13], -"summary_8c.html#a34f9930772a2a2f51d1fb599fada8097":[2,0,64,65], -"summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0":[2,0,64,4], -"summary_8c.html#a37fe0b295099c3b2c7e191b9c0bce462":[2,0,64,49], -"summary_8c.html#a389c7c1d3463a433be1d5311eb945fc7":[2,0,64,141], -"summary_8c.html#a3ad334b34de6b33e80f0df352228b745":[2,0,64,18], -"summary_8c.html#a3e0c85a19f4c1d2a25f45c50e2f36563":[2,0,64,132], -"summary_8c.html#a3e65cb73000c63acc54dc632d0f7c8e0":[2,0,64,58], -"summary_8c.html#a41cdb4a229a3d71837d607124f8a07a4":[2,0,64,142], -"summary_8c.html#a424a5e562902c316c88909a26acb2c61":[2,0,64,22], -"summary_8c.html#a430c901b4584328d0cd8c616afd77e6c":[2,0,64,78], -"summary_8c.html#a45599b5df94f2e1582f50a84e22824ed":[2,0,64,114], -"summary_8c.html#a4a88193fca9ebe61ea6eab56cd9befc9":[2,0,64,145], -"summary_8c.html#a4d94fd6b8925abf20dec9d4b3a456f15":[2,0,64,15], -"summary_8c.html#a4d9ac415b892403cd9d81603c304a35d":[2,0,64,147], -"summary_8c.html#a5032732c2a1862bbc57f96af8a977ab9":[2,0,64,86], -"summary_8c.html#a529e42f6f92b1ebac2ad14371f8edc85":[2,0,64,100], -"summary_8c.html#a52c7f23b6a85a53fa92d4f75b84363ca":[2,0,64,112], -"summary_8c.html#a5365870332fef1d02410663a44f58f1c":[2,0,64,87], -"summary_8c.html#a538189ebb31693d5ad6f7ba1f3f6d80e":[2,0,64,68], -"summary_8c.html#a552fe939a67643f7c430c5372bcf1201":[2,0,64,80], -"summary_8c.html#a574692b8069ffc0a2f6f20bd471130bd":[2,0,64,25], -"summary_8c.html#a585b71c74faea63d161810774ef8da9e":[2,0,64,5], -"summary_8c.html#a5c53ec2b21790bdeb3bcdeec9a5d32b0":[2,0,64,51], -"summary_8c.html#a5c5678e05ce08da171d237db078d2c30":[2,0,64,2], -"summary_8c.html#a5e6a1e9100ac23cb6f3fa698ad79799f":[2,0,64,42], -"summary_8c.html#a5ec9634520c3df4561d5e9a5dfbdf20a":[2,0,64,139], -"summary_8c.html#a609972981d9e0d89a9818d67c43ec47e":[2,0,64,111], -"summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110":[2,0,64,8], -"summary_8c.html#a64e80bb7555f90e7fdf6060f18d78042":[2,0,64,133], -"summary_8c.html#a67a621ea35ad8ab625a6087006bc6341":[2,0,64,128], -"summary_8c.html#a67e785f2dd7e8ea603021417f97dcb7c":[2,0,64,14], -"summary_8c.html#a6a2564455d5080402cf42c4b49ee68af":[2,0,64,125], -"summary_8c.html#a6cd6e07cefa9e1534636ff7e7911e49d":[2,0,64,30], -"summary_8c.html#a6d0dcf8f28b8ad13c7c11ff5c0b13df9":[2,0,64,20], -"summary_8c.html#a6f189801f4fd3bbe4dd5e4e119b42546":[2,0,64,149], -"summary_8c.html#a6f6fd8f50986414c088aced1a2673f7c":[2,0,64,24], -"summary_8c.html#a705bece7100f009b8e11a2211b113a9b":[2,0,64,85], -"summary_8c.html#a709e2b3208f9fced286cbf14fe8dcc09":[2,0,64,72], -"summary_8c.html#a73575684d3072d0f7b21c43c0d7f7ba9":[2,0,64,137], -"summary_8c.html#a744258e78f5ea78f646751f699250ea7":[2,0,64,82], -"summary_8c.html#a77aa528389f4aabc677b37c69ed2d273":[2,0,64,55], -"summary_8c.html#a793ab58960f1a8ffd5db6d1bc1e907e5":[2,0,64,40], -"summary_8c.html#a7bec6e7e8062862594eb54d2925c8850":[2,0,64,45], -"summary_8c.html#a7bf19ae5fce740bae9e4c99c7fc3bb22":[2,0,64,44], -"summary_8c.html#a7cd23e366bcf87578b65731fb6b90ed8":[2,0,64,122], -"summary_8c.html#a8032faf2beae02017ddbf2580ca03e01":[2,0,64,26], -"summary_8c.html#a826c278d990ab9b300161cfbe7896703":[2,0,64,102], -"summary_8c.html#a85f50c91b93171e345aa393946e62aa9":[2,0,64,1], -"summary_8c.html#a8866d80f4e23bcb3ed0937542d0ddd9d":[2,0,64,97], -"summary_8c.html#a88fa76175a8290858e0bcb3f1958d82d":[2,0,64,29], -"summary_8c.html#a8c68a5508755545d18df4e0275e15b9b":[2,0,64,53], -"summary_8c.html#a8cce40fe10eac5a02f682f049899c542":[2,0,64,83], -"summary_8c.html#a8d62e6e10c4660c07db3d9ab31d4d04b":[2,0,64,117], -"summary_8c.html#a8dce0c8af1194fad38fde639bdc4c906":[2,0,64,106], -"summary_8c.html#a8e437726cd46292cc3d35e9d27a225e2":[2,0,64,36], -"summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7":[2,0,64,7], -"summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22":[2,0,64,3], -"summary_8c.html#a92f552c67909fb4d2179d40efeaa4874":[2,0,64,108], -"summary_8c.html#a966379facb3b4a533100776877c26a85":[2,0,64,59], -"summary_8c.html#a9c034ede980053b065250459a44a8739":[2,0,64,69], -"summary_8c.html#a9cf3ff9bf9134241c2aef429c1546107":[2,0,64,19], -"summary_8c.html#a9ed990b4797de73eb6d75d76cde88c86":[2,0,64,81], -"summary_8c.html#a9f59baa0114b00d5aa7a2816956e72cd":[2,0,64,9], -"summary_8c.html#aa065f30aa9f5f9a42132c82c787ee70b":[2,0,64,12], -"summary_8c.html#aa18cd3eba4355ba908e0832354e71807":[2,0,64,28], -"summary_8c.html#aa1c573c70b697b92861ec8d0fd96035f":[2,0,64,96], -"summary_8c.html#aa283f1f1288f0c09f4297c174953e774":[2,0,64,74], -"summary_8c.html#aa3dc17da4681ab6f806ce43e400ce9de":[2,0,64,110], -"summary_8c.html#aa478ea147dd03240882bdeb14f4a9754":[2,0,64,113], -"summary_8c.html#aa4c0c0f68d1493772573327bf11f206b":[2,0,64,31], -"summary_8c.html#aaa4ff1a21cce32e8e59fa19b895472d6":[2,0,64,77], -"summary_8c.html#aaae0564624fb5baf2cc1218575247be0":[2,0,64,105], -"summary_8c.html#aac8feac9a6eb9aae1ce4cf03c0aa3fae":[2,0,64,47], -"summary_8c.html#aadf7be3d57d51f602268076851eee7d9":[2,0,64,136], -"summary_8c.html#aae7b07a620912f0a0bc33705383c85ef":[2,0,64,148], -"summary_8c.html#ab00ad145263477c95172947b29f1c968":[2,0,64,16], -"summary_8c.html#ab094a15c7ca29970bd5abe5794d92532":[2,0,64,140], -"summary_8c.html#ab0b8c97f0ff9cc5995904191c48d3e7f":[2,0,64,84], -"summary_8c.html#ab98d375a77c3980c418cc26cc9baef27":[2,0,64,32], -"summary_8c.html#abac1fae2799629450e7f59c6de8bb1af":[2,0,64,95], -"summary_8c.html#abfa16073834655419a410f518aba2f49":[2,0,64,89], -"summary_8c.html#abfb08950cf0e1a2e18dd0e2f814d2628":[2,0,64,11], -"summary_8c.html#ac30f918e4632256526a027a73c95da78":[2,0,64,0], -"summary_8c.html#ac57d55f49a196adf709b8990b2aa7ae8":[2,0,64,62], -"summary_8c.html#ac6d9a870d61e535eb3a6fa851bdd6b01":[2,0,64,37], -"summary_8c.html#ac6f6c8dc0ea2891f749832ba21d44a2d":[2,0,64,109], -"summary_8c.html#ac7b0b714c8d1b65637246f1041a1dfd3":[2,0,64,70], -"summary_8c.html#ac8c4cb4aff5ebc789ac24463a1f94dc7":[2,0,64,39], -"summary_8c.html#ac93eaa6232d01d87c1157661779b826c":[2,0,64,79], -"summary_8c.html#ac9786807efe83a04234fde1ffb1a866c":[2,0,64,118], -"summary_8c.html#aca6c82c918a287dea09fa62f09704cb2":[2,0,64,54], -"summary_8c.html#ad3cf0f50569c5c2db65c6313c823df89":[2,0,64,34], -"summary_8c.html#ad42b6bd039b57665a8987db1ed619976":[2,0,64,35], -"summary_8c.html#ad622acacb3e78e6f5835627d98a0a62f":[2,0,64,75], -"summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e":[2,0,64,6], -"summary_8c.html#ad8f5d780aba02e250048879053bff1ce":[2,0,64,67], -"summary_8c.html#ad93d61f023cd9a2ef33494420e220571":[2,0,64,116], -"summary_8c.html#ad9fc0acf7146d802d8a9755f57e57ba2":[2,0,64,43], -"summary_8c.html#adae61454a87dda528e91d4d7134dc762":[2,0,64,103], -"summary_8c.html#adbc2b296851c0570648f3fea735c0ff5":[2,0,64,99], -"summary_8c.html#ae0276ef6a367bbc96a3d4e441243f971":[2,0,64,144], -"summary_8c.html#ae11dfdf520e707e22d8bdb2ee1ad8afa":[2,0,64,90], -"summary_8c.html#ae37b64c61bd2e4ef3922f5f7fe18c19d":[2,0,64,129], -"summary_8c.html#ae3c22dce32faa30047ddc9e0e19a8033":[2,0,64,21], -"summary_8c.html#ae3c3d4113fce5c68b5e64ad5940d72b1":[2,0,64,123], -"summary_8c.html#ae4c632bdefe7eca1cb99d80728957551":[2,0,64,48], -"summary_8c.html#ae63a8d07f2d480ae45ce9d0e723fc7ee":[2,0,64,107], -"summary_8c.html#ae6a525ec5e3a9b10083c5f6fa543532e":[2,0,64,131], -"summary_8c.html#ae6d8c5b4eff4b959c8ec57d833f1e75e":[2,0,64,119], -"summary_8c.html#ae75041f363da67739c69c176a00b5e84":[2,0,64,93], -"summary_8c.html#ae7645302ac7ec28341f115080d5f9307":[2,0,64,104], -"summary_8c.html#ae80e64cd7b00ae6444c0b35e94d74e4d":[2,0,64,76], -"summary_8c.html#aec220c18dc943150e7776e8cdcf4910b":[2,0,64,94], -"summary_8c.html#aec8001a11cec57890a1cde3384d58f4f":[2,0,64,50], -"summary_8c.html#aeca74a0a3f19313c8d9d81f55d674dbf":[2,0,64,91], -"summary_8c.html#aed5835480e81f2df4f37804613b1e74b":[2,0,64,88], -"summary_8c.html#aefd87183e71a7d074a6a3e87faa4868f":[2,0,64,143], -"summary_8c.html#af03e5dedf4289fadf0d22132f7008d88":[2,0,64,115], -"summary_8c.html#af9996e5e0f28de18e22169e4653dc35e":[2,0,64,46], -"summary_8c.html#afbbbe5ad84b18c8c4da164591de9f239":[2,0,64,17], -"summary_8c.html#afd5df26a7cddbeda2510eeb1ea2377bb":[2,0,64,66], -"summary_8c.html#aff520cb6940df03a10a8783171ebf6fa":[2,0,64,61], -"summary_8c_source.html":[2,0,64], -"w3ai00_8f.html":[2,0,65], -"w3ai00_8f.html#a076bf45857d517709ef249c89a0791e5":[2,0,65,2], -"w3ai00_8f.html#a080e60503e36be98db3d35c5e508dbde":[2,0,65,0], -"w3ai00_8f.html#aa9b74cf19854cae0066bd5d905a65873":[2,0,65,1], -"w3ai00_8f_source.html":[2,0,65], -"w3ai01_8f.html":[2,0,66], -"w3ai01_8f.html#a222326720cc27c198b6808bd3f601e4a":[2,0,66,0], -"w3ai01_8f_source.html":[2,0,66], -"w3ai08_8f.html":[2,0,67], -"w3ai08_8f.html#a1ac753d2f7d6ce69d4e1412af879b7b9":[2,0,67,4], -"w3ai08_8f.html#a220caa94dfc83c8a73d224245c9469da":[2,0,67,5], -"w3ai08_8f.html#a441b7146a653d41877d19a7cd64efb7c":[2,0,67,0], -"w3ai08_8f.html#a7031bf0f0b33cba1e5c2334224e735a1":[2,0,67,3], -"w3ai08_8f.html#a720103ce8519bc682230c8757c6fb8e9":[2,0,67,2], -"w3ai08_8f.html#a7ecf84941a754cb8d8a328c77f038de0":[2,0,67,6], -"w3ai08_8f.html#a8ca96c27a72b383415773ff07d2027dd":[2,0,67,8], -"w3ai08_8f.html#ac73cef7b08d3fbe6549b6db66ae7b49f":[2,0,67,7], -"w3ai08_8f.html#afa6093fcf5580f32f3ff8be92af6b0e3":[2,0,67,1], -"w3ai08_8f_source.html":[2,0,67], -"w3ai15_8f.html":[2,0,68], -"w3ai15_8f.html#acb162c72ac381b1874762eff242118d5":[2,0,68,0], -"w3ai15_8f_source.html":[2,0,68], -"w3ai18_8f.html":[2,0,69], -"w3ai18_8f.html#ae424dd6b4902f8abc7a21f878eea26f5":[2,0,69,0] +"pdsens_8f.html":[4,0,0,48], +"pdsens_8f.html#ad99e2996ab77fc0da4f298babf729a41":[4,0,0,48,0], +"pdsens_8f_source.html":[4,0,0,48], +"pdseup_8f.html":[4,0,0,49], +"pdseup_8f.html#aaac6faa5251b1c5320b6b055bcede9d2":[4,0,0,49,0], +"pdseup_8f_source.html":[4,0,0,49], +"putgb_8f.html":[4,0,0,50], +"putgb_8f.html#ab6da73b9f8ae839b451816f9916c231a":[4,0,0,50,0], +"putgb_8f_source.html":[4,0,0,50], +"putgbe_8f.html":[4,0,0,51], +"putgbe_8f.html#a08a29a941cd31cd04ee22f5139023e69":[4,0,0,51,0], +"putgbe_8f_source.html":[4,0,0,51], +"putgben_8f.html":[4,0,0,52], +"putgben_8f.html#a74d7f0a61a5f7937731d2b632555c69f":[4,0,0,52,0], +"putgben_8f_source.html":[4,0,0,52], +"putgbens_8f.html":[4,0,0,53], +"putgbens_8f.html#ad7551417c16d5720c2678f42443a045f":[4,0,0,53,0], +"putgbens_8f_source.html":[4,0,0,53], +"putgbex_8f.html":[4,0,0,54], +"putgbex_8f.html#a4d66cc2839c13fd35ae337aa79616ce6":[4,0,0,54,0], +"putgbex_8f_source.html":[4,0,0,54], +"putgbn_8f.html":[4,0,0,55], +"putgbn_8f.html#aec976c38f8bad78272ad997b4313a0cb":[4,0,0,55,0], +"putgbn_8f_source.html":[4,0,0,55], +"q9ie32_8f.html":[4,0,0,56], +"q9ie32_8f.html#aa70d08ca2156165a1d7e6ada7698274f":[4,0,0,56,0], +"q9ie32_8f_source.html":[4,0,0,56], +"r63w72_8f.html":[4,0,0,57], +"r63w72_8f.html#af3dacce6918418d047d622bbe287a228":[4,0,0,57,0], +"r63w72_8f_source.html":[4,0,0,57], +"sbyte_8f.html":[4,0,0,58], +"sbyte_8f.html#a74f0f88a79864061c3a4234075d39e1b":[4,0,0,58,0], +"sbyte_8f_source.html":[4,0,0,58], +"sbytec_8f.html":[4,0,0,59], +"sbytec_8f.html#a8a4f2a2a7a917e47a36f737aa1d75c14":[4,0,0,59,0], +"sbytec_8f_source.html":[4,0,0,59], +"sbytes_8f.html":[4,0,0,60], +"sbytes_8f_source.html":[4,0,0,60], +"sbytesc_8f.html":[4,0,0,61], +"sbytesc_8f.html#ad30c0509f73ae28b2f15fa3c151d491c":[4,0,0,61,0], +"sbytesc_8f_source.html":[4,0,0,61], +"skgb_8f.html":[4,0,0,62], +"skgb_8f.html#a33d9c42574632a3c57ecc85d17c8e62a":[4,0,0,62,0], +"skgb_8f_source.html":[4,0,0,62], +"structmersenne__twister_1_1random__stat.html":[2,0,0,4], +"structmersenne__twister_1_1random__stat.html":[3,0,0,4], +"summary_8c.html":[4,0,0,63], +"summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0":[4,0,0,63,4], +"summary_8c.html#a585b71c74faea63d161810774ef8da9e":[4,0,0,63,5], +"summary_8c.html#a5c5678e05ce08da171d237db078d2c30":[4,0,0,63,2], +"summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110":[4,0,0,63,8], +"summary_8c.html#a85f50c91b93171e345aa393946e62aa9":[4,0,0,63,1], +"summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7":[4,0,0,63,7], +"summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22":[4,0,0,63,3], +"summary_8c.html#ac30f918e4632256526a027a73c95da78":[4,0,0,63,0], +"summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e":[4,0,0,63,6], +"summary_8c_source.html":[4,0,0,63], +"w3ai00_8f.html":[4,0,0,64], +"w3ai00_8f.html#a1fd1329d5e770895def939d0467928ef":[4,0,0,64,1], +"w3ai00_8f.html#a4d10019a7be86cad3b458e0556e0e163":[4,0,0,64,2], +"w3ai00_8f.html#a564f42a42124d4a94e956e051ad59969":[4,0,0,64,0], +"w3ai00_8f_source.html":[4,0,0,64], +"w3ai01_8f.html":[4,0,0,65], +"w3ai01_8f.html#acf00ef759655cd640826064c50ff8150":[4,0,0,65,0], +"w3ai01_8f_source.html":[4,0,0,65], +"w3ai08_8f.html":[4,0,0,66], +"w3ai08_8f.html#a287605e7ec4319ea51164043fa1f9d73":[4,0,0,66,0], +"w3ai08_8f.html#a3df6d0ec86b78aea8c650696d0a0b21f":[4,0,0,66,2], +"w3ai08_8f.html#a45260b5f0f299ccea0ab0ac6f7be1fe5":[4,0,0,66,3], +"w3ai08_8f.html#a50cf1edd8615abf5c6c333c8e790f63b":[4,0,0,66,8], +"w3ai08_8f.html#a6a8d7e193514ad239d73c3bdd30a6576":[4,0,0,66,5], +"w3ai08_8f.html#a7dee92cbb450627df9b2dd8e3272abb8":[4,0,0,66,1], +"w3ai08_8f.html#a9c9abd1f5e91a16eb04e1e83bc436238":[4,0,0,66,7], +"w3ai08_8f.html#acd0cb9edc0509005a5121d3fa2eb2037":[4,0,0,66,6], +"w3ai08_8f.html#af169362b14ce4c1f632823554fdc5495":[4,0,0,66,4], +"w3ai08_8f_source.html":[4,0,0,66], +"w3ai15_8f.html":[4,0,0,67], +"w3ai15_8f.html#a87103805250f46624e11c6ca8c68b288":[4,0,0,67,0], +"w3ai15_8f_source.html":[4,0,0,67], +"w3ai18_8f.html":[4,0,0,68], +"w3ai18_8f.html#ac5f95206395f4fff1f8bd74dbc8a929b":[4,0,0,68,0], +"w3ai18_8f_source.html":[4,0,0,68], +"w3ai19_8f.html":[4,0,0,69], +"w3ai19_8f.html#a94ced6d87294ca6fd467da8e9b42096b":[4,0,0,69,0], +"w3ai19_8f_source.html":[4,0,0,69], +"w3ai24_8f.html":[4,0,0,70], +"w3ai24_8f.html#a2468984a80b3966028f29391a091a5f2":[4,0,0,70,0], +"w3ai24_8f_source.html":[4,0,0,70], +"w3ai38_8f.html":[4,0,0,71], +"w3ai38_8f.html#a8c31fa8b048696a5616b55d753eaa193":[4,0,0,71,0], +"w3ai38_8f_source.html":[4,0,0,71], +"w3ai39_8f.html":[4,0,0,72], +"w3ai39_8f.html#a997a055c96092bc5e8ef74404f34e7d1":[4,0,0,72,0], +"w3ai39_8f_source.html":[4,0,0,72], +"w3ai40_8f.html":[4,0,0,73], +"w3ai40_8f.html#a1675f4f6d98aa6a1cdbd2dfd44975d49":[4,0,0,73,0], +"w3ai40_8f_source.html":[4,0,0,73], +"w3ai41_8f.html":[4,0,0,74], +"w3ai41_8f.html#aec7a595f5288838e71110ac432b1777a":[4,0,0,74,0], +"w3ai41_8f_source.html":[4,0,0,74], +"w3aq15_8f.html":[4,0,0,75], +"w3aq15_8f.html#ab150670d527c962c1deceb71106976d3":[4,0,0,75,0], +"w3aq15_8f_source.html":[4,0,0,75], +"w3as00_8f.html":[4,0,0,76], +"w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529":[4,0,0,76,0], +"w3as00_8f_source.html":[4,0,0,76], +"w3ctzdat_8f.html":[4,0,0,77], +"w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035":[4,0,0,77,0], +"w3ctzdat_8f_source.html":[4,0,0,77], +"w3difdat_8f.html":[4,0,0,78], +"w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1":[4,0,0,78,0], +"w3difdat_8f_source.html":[4,0,0,78], +"w3doxdat_8f.html":[4,0,0,79], +"w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29":[4,0,0,79,0], +"w3doxdat_8f_source.html":[4,0,0,79], +"w3fa01_8f.html":[4,0,0,80], +"w3fa01_8f.html#acfc4149f4d9c51d2b5b9888e932f25ca":[4,0,0,80,0], +"w3fa01_8f_source.html":[4,0,0,80], +"w3fa03_8f.html":[4,0,0,81], +"w3fa03_8f.html#a7805169d794ed38e57ba685e6241100b":[4,0,0,81,0], +"w3fa03_8f_source.html":[4,0,0,81], +"w3fa03v_8f.html":[4,0,0,82], +"w3fa03v_8f.html#a1d2407e31446d6ad82bd4e2cb61fd5d7":[4,0,0,82,0], +"w3fa03v_8f_source.html":[4,0,0,82], +"w3fa04_8f.html":[4,0,0,83], +"w3fa04_8f.html#a4a761802c7bab00ea502026e7863696a":[4,0,0,83,0], +"w3fa04_8f_source.html":[4,0,0,83], +"w3fa06_8f.html":[4,0,0,84], +"w3fa06_8f.html#aa82de1d1f83eb4bb981a5d00b3af13d9":[4,0,0,84,0], +"w3fa06_8f_source.html":[4,0,0,84], +"w3fa09_8f.html":[4,0,0,85], +"w3fa09_8f.html#ad48026b7570d6ac92635a6719c9ef7fc":[4,0,0,85,0], +"w3fa09_8f_source.html":[4,0,0,85], +"w3fa11_8f.html":[4,0,0,86], +"w3fa11_8f.html#ac97049f63913eb3d3af50c42ea29e5c8":[4,0,0,86,0], +"w3fa11_8f_source.html":[4,0,0,86], +"w3fa12_8f.html":[4,0,0,87], +"w3fa12_8f.html#a74541e2949ce81754b1e8a4a3e5d946f":[4,0,0,87,0], +"w3fa12_8f_source.html":[4,0,0,87], +"w3fa13_8f.html":[4,0,0,88], +"w3fa13_8f.html#a79f0efdd8bbc53bd8c9bc9aa7ca41811":[4,0,0,88,0], +"w3fa13_8f_source.html":[4,0,0,88], +"w3fb00_8f.html":[4,0,0,89], +"w3fb00_8f.html#a6581d211e674bcbe0b47b2d65e9aa671":[4,0,0,89,0], +"w3fb00_8f_source.html":[4,0,0,89], +"w3fb01_8f.html":[4,0,0,90], +"w3fb01_8f.html#aa4c5be625575219d8a21032e55ffa8ee":[4,0,0,90,0], +"w3fb01_8f_source.html":[4,0,0,90], +"w3fb02_8f.html":[4,0,0,91], +"w3fb02_8f.html#aac12d4245442631655101f5a4b27aee2":[4,0,0,91,0], +"w3fb02_8f_source.html":[4,0,0,91], +"w3fb03_8f.html":[4,0,0,92], +"w3fb03_8f.html#ac1d9e9f45629c503bd63fc3e79c9892f":[4,0,0,92,0], +"w3fb03_8f_source.html":[4,0,0,92], +"w3fb04_8f.html":[4,0,0,93], +"w3fb04_8f.html#a3b860b612d62a311ec6364ed3ecd1ca4":[4,0,0,93,0], +"w3fb04_8f_source.html":[4,0,0,93], +"w3fb05_8f.html":[4,0,0,94], +"w3fb05_8f.html#af9bdbe0b4b7576494298c0b50c6fc837":[4,0,0,94,0], +"w3fb05_8f_source.html":[4,0,0,94], +"w3fb06_8f.html":[4,0,0,95], +"w3fb06_8f.html#a3b5622b466f3ab1d3c93b8c3606ca27e":[4,0,0,95,0], +"w3fb06_8f_source.html":[4,0,0,95], +"w3fb07_8f.html":[4,0,0,96], +"w3fb07_8f.html#ade62d0dff4cb419a076b295780e1c72d":[4,0,0,96,0], +"w3fb07_8f_source.html":[4,0,0,96], +"w3fb08_8f.html":[4,0,0,97], +"w3fb08_8f.html#a404c4d79a1162f49baeebe63f6a48174":[4,0,0,97,0], +"w3fb08_8f_source.html":[4,0,0,97], +"w3fb09_8f.html":[4,0,0,98], +"w3fb09_8f.html#a97d39b7d805646bba7510a3fb06f44ea":[4,0,0,98,0], +"w3fb09_8f_source.html":[4,0,0,98], +"w3fb10_8f.html":[4,0,0,99], +"w3fb10_8f.html#aa7f39f82090c39b8550d19c26fd6e88c":[4,0,0,99,0], +"w3fb10_8f_source.html":[4,0,0,99], +"w3fb11_8f.html":[4,0,0,100], +"w3fb11_8f.html#a44ef8585ec761cc4360677a4043ae836":[4,0,0,100,0], +"w3fb11_8f_source.html":[4,0,0,100], +"w3fb12_8f.html":[4,0,0,101], +"w3fb12_8f.html#a8bf51dda5c2baf121134274723c79837":[4,0,0,101,0], +"w3fb12_8f_source.html":[4,0,0,101], +"w3fc02_8f.html":[4,0,0,102], +"w3fc02_8f.html#aa7ac60b61ee09def3c2e5e2005575cec":[4,0,0,102,0], +"w3fc02_8f_source.html":[4,0,0,102], +"w3fc05_8f.html":[4,0,0,103], +"w3fc05_8f.html#a2a855302ae772a201af2e93a43fa8fa9":[4,0,0,103,0], +"w3fc05_8f_source.html":[4,0,0,103], +"w3fc06_8f.html":[4,0,0,104], +"w3fc06_8f.html#a4b85830235c80e0c007cba0d9e2ad7e8":[4,0,0,104,0], +"w3fc06_8f_source.html":[4,0,0,104], +"w3fc07_8f.html":[4,0,0,105], +"w3fc07_8f.html#aa2d422861395fb930f4a8a235beb5735":[4,0,0,105,0], +"w3fc07_8f_source.html":[4,0,0,105], +"w3fc08_8f.html":[4,0,0,106], +"w3fc08_8f.html#ab866267da1ef5f8208ffe29f38590b6c":[4,0,0,106,0], +"w3fc08_8f_source.html":[4,0,0,106], +"w3fi01_8f.html":[4,0,0,107], +"w3fi01_8f.html#a45d73d5e35cbbe33e27e9c11684ca491":[4,0,0,107,0], +"w3fi01_8f_source.html":[4,0,0,107], +"w3fi02_8f.html":[4,0,0,108], +"w3fi02_8f.html#a12ce6be899705cebb27f675ef5413353":[4,0,0,108,0], +"w3fi02_8f_source.html":[4,0,0,108], +"w3fi03_8f.html":[4,0,0,109], +"w3fi03_8f.html#a875772e1917cd6bf73eabca330b517de":[4,0,0,109,0], +"w3fi03_8f_source.html":[4,0,0,109], +"w3fi04_8f.html":[4,0,0,110], +"w3fi04_8f.html#a59af48612285f36dae46e14f4b0e8a85":[4,0,0,110,0], +"w3fi04_8f_source.html":[4,0,0,110], +"w3fi18_8f.html":[4,0,0,111], +"w3fi18_8f.html#a3e60fdacb75b639d8e444a507259a1e8":[4,0,0,111,0], +"w3fi18_8f_source.html":[4,0,0,111], +"w3fi19_8f.html":[4,0,0,112], +"w3fi19_8f.html#a4eef5192d8f6d23e77aef025680f7b9f":[4,0,0,112,0], +"w3fi19_8f_source.html":[4,0,0,112], +"w3fi20_8f.html":[4,0,0,113], +"w3fi20_8f.html#a9ef932fe706763c5afc84a7c6797d415":[4,0,0,113,0], +"w3fi20_8f_source.html":[4,0,0,113], +"w3fi32_8f.html":[4,0,0,114], +"w3fi32_8f.html#a873077240f7b409fea74580cbfed49ad":[4,0,0,114,0], +"w3fi32_8f_source.html":[4,0,0,114], +"w3fi47_8f.html":[4,0,0,115], +"w3fi47_8f.html#ad09c2b7b4957ee75a21baf17c5ae091e":[4,0,0,115,0], +"w3fi47_8f_source.html":[4,0,0,115], +"w3fi48_8f.html":[4,0,0,116], +"w3fi48_8f.html#aa7d2d23ac60388b262bab73ae8434fa7":[4,0,0,116,0], +"w3fi48_8f_source.html":[4,0,0,116], +"w3fi58_8f.html":[4,0,0,117], +"w3fi58_8f.html#a06f9456e4b8c768f7853a0ba42a5d229":[4,0,0,117,0], +"w3fi58_8f_source.html":[4,0,0,117], +"w3fi59_8f.html":[4,0,0,118], +"w3fi59_8f.html#a8bba5bf7656b97615cfba69962c91782":[4,0,0,118,0], +"w3fi59_8f_source.html":[4,0,0,118], +"w3fi61_8f.html":[4,0,0,119], +"w3fi61_8f.html#a41ee42bf0040218d3bf0c0c93716d12e":[4,0,0,119,0], +"w3fi61_8f_source.html":[4,0,0,119], +"w3fi62_8f.html":[4,0,0,120], +"w3fi62_8f.html#a462db56d61f6d13371250087a22255ba":[4,0,0,120,0], +"w3fi62_8f_source.html":[4,0,0,120], +"w3fi63_8f.html":[4,0,0,121], +"w3fi63_8f.html#a14d2f9e6b5fb3226561e037897d203c3":[4,0,0,121,0] }; diff --git a/navtreeindex2.js b/navtreeindex2.js index 0c89af9f..e0661fbf 100644 --- a/navtreeindex2.js +++ b/navtreeindex2.js @@ -1,253 +1,253 @@ var NAVTREEINDEX2 = { -"w3ai18_8f_source.html":[2,0,69], -"w3ai19_8f.html":[2,0,70], -"w3ai19_8f.html#ada69d8346ce6a030bc9f722fb842529c":[2,0,70,0], -"w3ai19_8f_source.html":[2,0,70], -"w3ai24_8f.html":[2,0,71], -"w3ai24_8f.html#a425d9890956ae872557a04b715deb3f2":[2,0,71,0], -"w3ai24_8f_source.html":[2,0,71], -"w3ai38_8f.html":[2,0,72], -"w3ai38_8f.html#a65ce63976c2011a17a8f44e0d20e074f":[2,0,72,0], -"w3ai38_8f_source.html":[2,0,72], -"w3ai39_8f.html":[2,0,73], -"w3ai39_8f.html#a28ca73de8fec4c73859576d1d2e0a219":[2,0,73,0], -"w3ai39_8f_source.html":[2,0,73], -"w3ai40_8f.html":[2,0,74], -"w3ai40_8f.html#afecf619ca48a8909617176d5e3b2de84":[2,0,74,0], -"w3ai40_8f_source.html":[2,0,74], -"w3ai41_8f.html":[2,0,75], -"w3ai41_8f.html#a07de865f47db3f841722760476742c04":[2,0,75,0], -"w3ai41_8f_source.html":[2,0,75], -"w3aq15_8f.html":[2,0,76], -"w3aq15_8f.html#aa2f10d43798cbba2f9089d37ab1fcdaa":[2,0,76,0], -"w3aq15_8f_source.html":[2,0,76], -"w3as00_8f.html":[2,0,77], -"w3as00_8f.html#a26ea8486571f9eff4e6e0c10f120518a":[2,0,77,0], -"w3as00_8f.html#abd251a32b0d875bec7b812d2342950a1":[2,0,77,1], -"w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529":[2,0,77,2], -"w3as00_8f_source.html":[2,0,77], -"w3ctzdat_8f.html":[2,0,78], -"w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035":[2,0,78,0], -"w3ctzdat_8f_source.html":[2,0,78], -"w3difdat_8f.html":[2,0,79], -"w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1":[2,0,79,0], -"w3difdat_8f_source.html":[2,0,79], -"w3doxdat_8f.html":[2,0,80], -"w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29":[2,0,80,0], -"w3doxdat_8f_source.html":[2,0,80], -"w3fa01_8f.html":[2,0,81], -"w3fa01_8f.html#ae5c40f5b79f9833cb7012d9401bfa7b8":[2,0,81,0], -"w3fa01_8f_source.html":[2,0,81], -"w3fa03_8f.html":[2,0,82], -"w3fa03_8f.html#a682b3b6383a8cf898b6f57ce304501e3":[2,0,82,0], -"w3fa03_8f_source.html":[2,0,82], -"w3fa03v_8f.html":[2,0,83], -"w3fa03v_8f.html#a0e7dfe3a41d6a2022f45cadb7c78231c":[2,0,83,0], -"w3fa03v_8f_source.html":[2,0,83], -"w3fa04_8f.html":[2,0,84], -"w3fa04_8f.html#a5f4b61c8c65ffd2662ca4918d08c8fc6":[2,0,84,0], -"w3fa04_8f_source.html":[2,0,84], -"w3fa06_8f.html":[2,0,85], -"w3fa06_8f.html#a232d431173943399677b1eb13275bb05":[2,0,85,0], -"w3fa06_8f_source.html":[2,0,85], -"w3fa09_8f.html":[2,0,86], -"w3fa09_8f.html#a97cb87ce42a1cba4c96dd80fefb9eafe":[2,0,86,0], -"w3fa09_8f_source.html":[2,0,86], -"w3fa11_8f.html":[2,0,87], -"w3fa11_8f.html#ad62a05c9654e2a4aa35667a814dee8a2":[2,0,87,0], -"w3fa11_8f_source.html":[2,0,87], -"w3fa12_8f.html":[2,0,88], -"w3fa12_8f.html#af8c0b914691cd0a708ca37b26be47c25":[2,0,88,0], -"w3fa12_8f_source.html":[2,0,88], -"w3fa13_8f.html":[2,0,89], -"w3fa13_8f.html#ae3485639e68c6074ead756064096216a":[2,0,89,0], -"w3fa13_8f_source.html":[2,0,89], -"w3fb00_8f.html":[2,0,90], -"w3fb00_8f.html#a007817ca2f1dd94a58abdb00f54aab28":[2,0,90,0], -"w3fb00_8f_source.html":[2,0,90], -"w3fb01_8f.html":[2,0,91], -"w3fb01_8f.html#a17796145ddabcec090b9d7249091293b":[2,0,91,0], -"w3fb01_8f_source.html":[2,0,91], -"w3fb02_8f.html":[2,0,92], -"w3fb02_8f.html#a86b57ee57a85c801ccca67cc7e6ef2a9":[2,0,92,0], -"w3fb02_8f_source.html":[2,0,92], -"w3fb03_8f.html":[2,0,93], -"w3fb03_8f.html#a0b68e4622016d2c2fe409ac880d66a3f":[2,0,93,0], -"w3fb03_8f_source.html":[2,0,93], -"w3fb04_8f.html":[2,0,94], -"w3fb04_8f.html#a239793420ab239a1a96df658749018ff":[2,0,94,0], -"w3fb04_8f_source.html":[2,0,94], -"w3fb05_8f.html":[2,0,95], -"w3fb05_8f.html#af9a92b376a6fb25c5ac8c778994753bd":[2,0,95,0], -"w3fb05_8f_source.html":[2,0,95], -"w3fb06_8f.html":[2,0,96], -"w3fb06_8f.html#a04de76d1aea61cb48ebcd1470101bca9":[2,0,96,0], -"w3fb06_8f_source.html":[2,0,96], -"w3fb07_8f.html":[2,0,97], -"w3fb07_8f.html#a2c8196faf8798dbc2b7593e0a1ec5b68":[2,0,97,0], -"w3fb07_8f_source.html":[2,0,97], -"w3fb08_8f.html":[2,0,98], -"w3fb08_8f.html#ad3b516b61a4b4b53e680c775f3e92a5b":[2,0,98,0], -"w3fb08_8f_source.html":[2,0,98], -"w3fb09_8f.html":[2,0,99], -"w3fb09_8f.html#a44a5c4c417459876b5cbc4aaab8e4a25":[2,0,99,0], -"w3fb09_8f_source.html":[2,0,99], -"w3fb10_8f.html":[2,0,100], -"w3fb10_8f.html#a5f021ccf55ac42f4034f0fd60e612911":[2,0,100,0], -"w3fb10_8f_source.html":[2,0,100], -"w3fb11_8f.html":[2,0,101], -"w3fb11_8f.html#a28b19a1336d3f885a04a97831726a3c0":[2,0,101,0], -"w3fb11_8f_source.html":[2,0,101], -"w3fb12_8f.html":[2,0,102], -"w3fb12_8f.html#ae5e7ad09f49bf57227336e663c180ee2":[2,0,102,0], -"w3fb12_8f_source.html":[2,0,102], -"w3fc02_8f.html":[2,0,103], -"w3fc02_8f.html#a2572657557b50b4f9580f1cf204d7aaf":[2,0,103,0], -"w3fc02_8f_source.html":[2,0,103], -"w3fc05_8f.html":[2,0,104], -"w3fc05_8f.html#ae77a21f468d05a34fa3a201c89b30530":[2,0,104,0], -"w3fc05_8f_source.html":[2,0,104], -"w3fc06_8f.html":[2,0,105], -"w3fc06_8f.html#a586eff5e859341d86f5ab00dbcca2169":[2,0,105,0], -"w3fc06_8f_source.html":[2,0,105], -"w3fc07_8f.html":[2,0,106], -"w3fc07_8f.html#a84dac72c47bb275c7c251c620052b54d":[2,0,106,0], -"w3fc07_8f_source.html":[2,0,106], -"w3fc08_8f.html":[2,0,107], -"w3fc08_8f.html#ac768b413af58dd51c57c6bf6d2d48a84":[2,0,107,0], -"w3fc08_8f_source.html":[2,0,107], -"w3fi01_8f.html":[2,0,108], -"w3fi01_8f.html#a10ac20498f7eca8e2281cad1218bede4":[2,0,108,0], -"w3fi01_8f_source.html":[2,0,108], -"w3fi02_8f.html":[2,0,109], -"w3fi02_8f.html#a217b3130b7e509776b74fde620e5b715":[2,0,109,0], -"w3fi02_8f_source.html":[2,0,109], -"w3fi03_8f.html":[2,0,110], -"w3fi03_8f.html#a3cfc13ff3a45dea4c4f6f7c1832df3d3":[2,0,110,0], -"w3fi03_8f_source.html":[2,0,110], -"w3fi04_8f.html":[2,0,111], -"w3fi04_8f.html#a43d8dd578a2f24d52b45332ed3ccc6c9":[2,0,111,0], -"w3fi04_8f_source.html":[2,0,111], -"w3fi18_8f.html":[2,0,112], -"w3fi18_8f.html#a684daaf76526713839d9d702a2c8aff7":[2,0,112,0], -"w3fi18_8f_source.html":[2,0,112], -"w3fi19_8f.html":[2,0,113], -"w3fi19_8f.html#afcb6e01340c836fbd0f940b8c0e6814f":[2,0,113,0], -"w3fi19_8f_source.html":[2,0,113], -"w3fi20_8f.html":[2,0,114], -"w3fi20_8f.html#a4d5864f48a1b0a2c1223f3dd4a06059f":[2,0,114,0], -"w3fi20_8f_source.html":[2,0,114], -"w3fi32_8f.html":[2,0,115], -"w3fi32_8f.html#a28af7a8a671a5e22f09ba6f371a348db":[2,0,115,0], -"w3fi32_8f_source.html":[2,0,115], -"w3fi47_8f.html":[2,0,116], -"w3fi47_8f.html#aa65811b21988f0ddf7568b0a88f12282":[2,0,116,0], -"w3fi47_8f_source.html":[2,0,116], -"w3fi48_8f.html":[2,0,117], -"w3fi48_8f.html#af4be979e393742d638626918089c9374":[2,0,117,0], -"w3fi48_8f_source.html":[2,0,117], -"w3fi52_8f.html":[2,0,118], -"w3fi52_8f.html#a8ce70b189d09ff2d3acfb478833c640c":[2,0,118,0], -"w3fi52_8f_source.html":[2,0,118], -"w3fi58_8f.html":[2,0,119], -"w3fi58_8f.html#a9e29ba5f6e80a0133fdf08c4374d6e5e":[2,0,119,0], -"w3fi58_8f_source.html":[2,0,119], -"w3fi59_8f.html":[2,0,120], -"w3fi59_8f.html#ab4f28b2c5e95c681036ef83142a58601":[2,0,120,0], -"w3fi59_8f_source.html":[2,0,120], -"w3fi61_8f.html":[2,0,121], -"w3fi61_8f.html#a1b9630713670570f4aef4d99b284bfec":[2,0,121,0], -"w3fi61_8f_source.html":[2,0,121], -"w3fi62_8f.html":[2,0,122], -"w3fi62_8f.html#a0dd3e7a53e1e42357c2579cbe74a4f77":[2,0,122,0], -"w3fi62_8f_source.html":[2,0,122], -"w3fi63_8f.html":[2,0,123], -"w3fi63_8f.html#a49e798fade46eda6b55035a58e136185":[2,0,123,1], -"w3fi63_8f.html#a573937997ce1f78d799c52ba6812d503":[2,0,123,3], -"w3fi63_8f.html#a5e07fb32acda017ce2b31674761eddb0":[2,0,123,0], -"w3fi63_8f.html#a7c07c9973bb0370c09e56fa6aa00665a":[2,0,123,7], -"w3fi63_8f.html#a88fef913d620c38a8795ad7b93cb73a7":[2,0,123,5], -"w3fi63_8f.html#aa59740e4c6a30f9c5f201204603d302f":[2,0,123,8], -"w3fi63_8f.html#abe401baf1479cb539db68da3358232f1":[2,0,123,4], -"w3fi63_8f.html#acf6e1d529f2d31927f198d24b8ca610b":[2,0,123,6], -"w3fi63_8f.html#ae00e4a53f6509a2e49276ecc592522d1":[2,0,123,2], -"w3fi63_8f_source.html":[2,0,123], -"w3fi64_8f.html":[2,0,124], -"w3fi64_8f.html#abd64595a92fa11f1d11661e1e94b9dcc":[2,0,124,0], -"w3fi64_8f_source.html":[2,0,124], -"w3fi65_8f.html":[2,0,125], -"w3fi65_8f.html#a1651042ec008fbdb77f6b66ee9643d0e":[2,0,125,0], -"w3fi65_8f_source.html":[2,0,125], -"w3fi66_8f.html":[2,0,126], -"w3fi66_8f.html#af8839a41e56c22bda1be01a7f877eb5e":[2,0,126,0], -"w3fi66_8f_source.html":[2,0,126], -"w3fi67_8f.html":[2,0,127], -"w3fi67_8f.html#a0ba8ee313bbaa81c2d31552c8ba447dd":[2,0,127,6], -"w3fi67_8f.html#a2f44d69247df49460acaabe30f7cabb9":[2,0,127,9], -"w3fi67_8f.html#a450eb49ae26957e0bcadb573ffbcbab2":[2,0,127,8], -"w3fi67_8f.html#a85264d1d80f2dcd1c5aef6998179ed21":[2,0,127,2], -"w3fi67_8f.html#aa8975059a9c80ae0909d0942907c5b04":[2,0,127,5], -"w3fi67_8f.html#ab4efc955f13221a830e6c653fbe8326b":[2,0,127,1], -"w3fi67_8f.html#ac00ebd799c167d32ad1e8d2ccf77d8ed":[2,0,127,4], -"w3fi67_8f.html#ad13befc6a11f1be63345c169e4e2c21a":[2,0,127,3], -"w3fi67_8f.html#af1838e0792e8dacd4ba70b0b844065c6":[2,0,127,0], -"w3fi67_8f.html#af1ebc9eb3165bf0f76af6472109fb4db":[2,0,127,10], -"w3fi67_8f.html#afc00645e835f1bb662852727afb41980":[2,0,127,7], -"w3fi67_8f_source.html":[2,0,127], -"w3fi68_8f.html":[2,0,128], -"w3fi68_8f.html#a627b0d3ff494874dd3fb243e39cfa991":[2,0,128,0], -"w3fi68_8f_source.html":[2,0,128], -"w3fi69_8f.html":[2,0,129], -"w3fi69_8f.html#a725f7f35c86515ca113aa3a36ac133e0":[2,0,129,0], -"w3fi69_8f_source.html":[2,0,129], -"w3fi70_8f.html":[2,0,130], -"w3fi70_8f.html#a15c47f82fe6330c213820e90fbe63a92":[2,0,130,0], -"w3fi70_8f_source.html":[2,0,130], -"w3fi71_8f.html":[2,0,131], -"w3fi71_8f.html#add1b6b2b2c9fda60094914f5e676ec42":[2,0,131,0], -"w3fi71_8f_source.html":[2,0,131], -"w3fi72_8f.html":[2,0,132], -"w3fi72_8f.html#aaac6e022f341c919316466672ef3e70c":[2,0,132,0], -"w3fi72_8f_source.html":[2,0,132], -"w3fi73_8f.html":[2,0,133], -"w3fi73_8f.html#a89eedc9b7ba4fd46b1f6ac9eba1f773e":[2,0,133,0], -"w3fi73_8f_source.html":[2,0,133], -"w3fi74_8f.html":[2,0,134], -"w3fi74_8f.html#ab921a7e370356989116ba2ac3e429d61":[2,0,134,0], -"w3fi74_8f_source.html":[2,0,134], -"w3fi75_8f.html":[2,0,135], -"w3fi75_8f.html#a2594a5111d3b15a124e611eee1152fb7":[2,0,135,5], -"w3fi75_8f.html#a36ae6b4d235133cbe224771791cc78a1":[2,0,135,4], -"w3fi75_8f.html#a76d712772f7a7b26ca1bba569d377e14":[2,0,135,0], -"w3fi75_8f.html#a96ec02cf0c85d44fc9f0fffff0ef038c":[2,0,135,2], -"w3fi75_8f.html#aa4b8fc64e075cd7c24ab51663d4d6912":[2,0,135,8], -"w3fi75_8f.html#abdf0aa822fec98a9c20620ea1e170b7a":[2,0,135,7], -"w3fi75_8f.html#acafb610fbee0d6e272301e3277cf4d32":[2,0,135,1], -"w3fi75_8f.html#ad8add9d378e5f476eb9a03253aac0673":[2,0,135,3], -"w3fi75_8f.html#ae605cd757c3b135016711cb96e8ddb12":[2,0,135,6], -"w3fi75_8f_source.html":[2,0,135], -"w3fi76_8f.html":[2,0,136], -"w3fi76_8f.html#a5af5a733105c5ce75ddfe99f7249f999":[2,0,136,0], -"w3fi76_8f_source.html":[2,0,136], -"w3fi78_8f.html":[2,0,137], -"w3fi78_8f.html#a1c0312bb81a0d948725334348ba1cbc0":[2,0,137,9], -"w3fi78_8f.html#a759ea3357b94bf332300d7ae6b6e073e":[2,0,137,5], -"w3fi78_8f.html#a78a1ba5576bfc184dbcde9db7647f2c0":[2,0,137,0], -"w3fi78_8f.html#a9c08a6a24a9527776d2b533108dbf261":[2,0,137,10], -"w3fi78_8f.html#aa30ef437f8f02bfaf3482c3c496d4af5":[2,0,137,8], -"w3fi78_8f.html#aa9b1b7dfb8dd609828a6e0db3271351f":[2,0,137,7], -"w3fi78_8f.html#abd85631fd2ddaae2c69a597dada4bad5":[2,0,137,2], -"w3fi78_8f.html#ac6daf60e47a8949569927e2dbe795dc7":[2,0,137,6], -"w3fi78_8f.html#adde456d0a3cdfb2ada7e27dac62ff5b4":[2,0,137,3], -"w3fi78_8f.html#aef0cfcae2b4b6aecddae061ef55c23f7":[2,0,137,4], -"w3fi78_8f.html#afe2cebe5fb34bedc4e028fcaeec3eb0b":[2,0,137,1], -"w3fi78_8f_source.html":[2,0,137], -"w3fi82_8f.html":[2,0,138], -"w3fi82_8f.html#a9d5c017171cdbf13bde5edff05dcd997":[2,0,138,0], -"w3fi82_8f_source.html":[2,0,138], -"w3fi83_8f.html":[2,0,139], -"w3fi83_8f.html#abaae8db75615b215003d0b2591b4e49d":[2,0,139,0], -"w3fi83_8f_source.html":[2,0,139], -"w3fi85_8f.html":[2,0,140] +"w3fi63_8f.html#a275d433403624224a7d8da4c820b76be":[4,0,0,121,8], +"w3fi63_8f.html#a52ab350d030e063ea1573ed81431d89e":[4,0,0,121,7], +"w3fi63_8f.html#a70c16565c866b4d5147e74b75c2c8ab3":[4,0,0,121,4], +"w3fi63_8f.html#a88dd0a17439f927fd7d2d742c6f7e310":[4,0,0,121,6], +"w3fi63_8f.html#ab0e08b59a11033f2b30c4597a9442fb7":[4,0,0,121,1], +"w3fi63_8f.html#ac10256c2bd0659630e821caf1c7ea44d":[4,0,0,121,5], +"w3fi63_8f.html#af01235610bd0574b0f96269311efa508":[4,0,0,121,3], +"w3fi63_8f.html#af02433c4bfbebcb7e7350ecbe7a61b81":[4,0,0,121,2], +"w3fi63_8f_source.html":[4,0,0,121], +"w3fi64_8f.html":[4,0,0,122], +"w3fi64_8f.html#a450e698ffae06cf8cd67fa9e2ba1170b":[4,0,0,122,0], +"w3fi64_8f_source.html":[4,0,0,122], +"w3fi65_8f.html":[4,0,0,123], +"w3fi65_8f.html#a04761367dc026f8b456d586d186a5dcd":[4,0,0,123,0], +"w3fi65_8f_source.html":[4,0,0,123], +"w3fi66_8f.html":[4,0,0,124], +"w3fi66_8f.html#a70b3cfe6a9e87d8b292ab36cfe2e2811":[4,0,0,124,0], +"w3fi66_8f_source.html":[4,0,0,124], +"w3fi67_8f.html":[4,0,0,125], +"w3fi67_8f.html#a08e6952dbff783ad8064c86284b7338b":[4,0,0,125,8], +"w3fi67_8f.html#a129e4781542ae749c23dc0a8961110ce":[4,0,0,125,0], +"w3fi67_8f.html#a18dfd077ec80be85e96192fb2627ce38":[4,0,0,125,4], +"w3fi67_8f.html#a7657ec760cf65383ff753091f47be6ad":[4,0,0,125,6], +"w3fi67_8f.html#a7d0d66e5c01d134ce7e40a6f33e54479":[4,0,0,125,10], +"w3fi67_8f.html#a7d30a98528a6c8cedc7b76c112862ea7":[4,0,0,125,9], +"w3fi67_8f.html#a8f8a60d99fe5feb50640a40f9e869c08":[4,0,0,125,5], +"w3fi67_8f.html#aa4d148d976e36638d4499d8f1d24bb55":[4,0,0,125,2], +"w3fi67_8f.html#ad5e2e788e8e08893f9e72880bf462d07":[4,0,0,125,7], +"w3fi67_8f.html#adf36991a9797826ba0e6af26bc047a22":[4,0,0,125,3], +"w3fi67_8f.html#ae78fbedd62a4b1dc408e12a56f269d2e":[4,0,0,125,1], +"w3fi67_8f_source.html":[4,0,0,125], +"w3fi68_8f.html":[4,0,0,126], +"w3fi68_8f.html#a2f103e1d1423a0f9585dbf5633758020":[4,0,0,126,0], +"w3fi68_8f_source.html":[4,0,0,126], +"w3fi69_8f.html":[4,0,0,127], +"w3fi69_8f.html#adcd583a43ddb3397dc354375ca5e5029":[4,0,0,127,0], +"w3fi69_8f_source.html":[4,0,0,127], +"w3fi70_8f.html":[4,0,0,128], +"w3fi70_8f.html#a804adf2c4205b93098ecb914e5a138ba":[4,0,0,128,0], +"w3fi70_8f_source.html":[4,0,0,128], +"w3fi71_8f.html":[4,0,0,129], +"w3fi71_8f.html#a8093d4ae34f8b50308c55b03ac0d2fc6":[4,0,0,129,0], +"w3fi71_8f_source.html":[4,0,0,129], +"w3fi72_8f.html":[4,0,0,130], +"w3fi72_8f.html#af30a5edb120c0910beafc6ee46d1f3c5":[4,0,0,130,0], +"w3fi72_8f_source.html":[4,0,0,130], +"w3fi73_8f.html":[4,0,0,131], +"w3fi73_8f.html#a16b6fc47763b666ed5c21c66e65b0e63":[4,0,0,131,0], +"w3fi73_8f_source.html":[4,0,0,131], +"w3fi74_8f.html":[4,0,0,132], +"w3fi74_8f.html#aa3d0542b1282d44be47215d59e6432dc":[4,0,0,132,0], +"w3fi74_8f_source.html":[4,0,0,132], +"w3fi75_8f.html":[4,0,0,133], +"w3fi75_8f.html#a080e563a3a2efeccaad9f91ac50f47e6":[4,0,0,133,4], +"w3fi75_8f.html#a132bfbd67589901d6bb5e9f72158a0c7":[4,0,0,133,8], +"w3fi75_8f.html#a229a0a1cdb13a4ac40e64396a062b0ab":[4,0,0,133,7], +"w3fi75_8f.html#a27b075bf60130cc76e5af83a4631df21":[4,0,0,133,6], +"w3fi75_8f.html#a32a2a7401b114f4fc586df3beba1740f":[4,0,0,133,0], +"w3fi75_8f.html#a3c5445cb4d0324926bf799220832227d":[4,0,0,133,2], +"w3fi75_8f.html#a7f98512b07c6233808c17cc41d39d34c":[4,0,0,133,1], +"w3fi75_8f.html#ab7aeef8ecb7b6e109f40de24ef9c466e":[4,0,0,133,3], +"w3fi75_8f.html#ae8e50fdcf98e231dd87ac0cac3407a23":[4,0,0,133,5], +"w3fi75_8f_source.html":[4,0,0,133], +"w3fi76_8f.html":[4,0,0,134], +"w3fi76_8f.html#a9e0b5a3150bf143ba67534a40ddd2856":[4,0,0,134,0], +"w3fi76_8f_source.html":[4,0,0,134], +"w3fi78_8f.html":[4,0,0,135], +"w3fi78_8f.html#a1ddd77e21e7b12f733c96d0d14092208":[4,0,0,135,5], +"w3fi78_8f.html#a3c7efbd2d1d06f5eadeb47912d1f1b88":[4,0,0,135,8], +"w3fi78_8f.html#a412826ca598b211d75aa9b6be5dded05":[4,0,0,135,10], +"w3fi78_8f.html#a49815e08605c968b2fecd0dcbdabe304":[4,0,0,135,0], +"w3fi78_8f.html#a4fe95ebc53f5ab1c5effb0a2cf9a1824":[4,0,0,135,6], +"w3fi78_8f.html#a7f339d55f5933f4ab915a26098bb0e6e":[4,0,0,135,3], +"w3fi78_8f.html#a9b9826d7fd1020f442d3d2a6c13a8239":[4,0,0,135,2], +"w3fi78_8f.html#aa7e94634a4e5b52d7a1fcc00d163180e":[4,0,0,135,9], +"w3fi78_8f.html#aab7538e5347a195c3eaae1a6bd035a5b":[4,0,0,135,7], +"w3fi78_8f.html#ae8c42f7f8ccfa1726cb092ddd414c87a":[4,0,0,135,4], +"w3fi78_8f.html#af68f1a1dbbc01729e49a3f9b5d8ff62e":[4,0,0,135,1], +"w3fi78_8f_source.html":[4,0,0,135], +"w3fi82_8f.html":[4,0,0,136], +"w3fi82_8f.html#a2888bd47bed9eb1b569ec4da20dcac8f":[4,0,0,136,0], +"w3fi82_8f_source.html":[4,0,0,136], +"w3fi83_8f.html":[4,0,0,137], +"w3fi83_8f.html#ad0372b453a84bbc270281245dbbad82e":[4,0,0,137,0], +"w3fi83_8f_source.html":[4,0,0,137], +"w3fi85_8f.html":[4,0,0,138], +"w3fi85_8f.html#a0ccde573a90a01365eb9e289a1d7cd65":[4,0,0,138,7], +"w3fi85_8f.html#a2288a2988c66dc8a5e48981f36ba4d38":[4,0,0,138,2], +"w3fi85_8f.html#a2d4241923113f9d2570abb615cf6e6f9":[4,0,0,138,6], +"w3fi85_8f.html#a7a5c1f8087abe23f5aa386dcc6578b88":[4,0,0,138,3], +"w3fi85_8f.html#a7b304c2b30215c2ca98f21d240d4335b":[4,0,0,138,10], +"w3fi85_8f.html#aa0c98da314499613dded4ed29bd67007":[4,0,0,138,0], +"w3fi85_8f.html#ab119068cfe66eb960c13bf8fcf3fdd18":[4,0,0,138,4], +"w3fi85_8f.html#ad0e2adc571586558aa11ae9c6220f19b":[4,0,0,138,5], +"w3fi85_8f.html#ae31c2999baedbd4f7d4e8b6ee4bbd319":[4,0,0,138,8], +"w3fi85_8f.html#aeeb668d3a0405f063fc381f2b6fadf1e":[4,0,0,138,1], +"w3fi85_8f.html#aff8d7f9b19c5927af493f76286da2192":[4,0,0,138,9], +"w3fi85_8f_source.html":[4,0,0,138], +"w3fi88_8f.html":[4,0,0,139], +"w3fi88_8f.html#a09e14e694efd5f48b403ec0dfff7f63c":[4,0,0,139,10], +"w3fi88_8f.html#a157d9ffb48327791c26dc6ddac872eda":[4,0,0,139,7], +"w3fi88_8f.html#a17cd06929f54d9886b5d2a4677fcf8e1":[4,0,0,139,3], +"w3fi88_8f.html#a2fed25546da8e6018a9a7ef4f84da0d4":[4,0,0,139,0], +"w3fi88_8f.html#a32eb617143dc3a3b49a1bbfef5960ed5":[4,0,0,139,2], +"w3fi88_8f.html#a597695a8a2eff93db31a2eb8d93ee8c9":[4,0,0,139,11], +"w3fi88_8f.html#a7c494f653f8c6abcffaea6a5918163ab":[4,0,0,139,4], +"w3fi88_8f.html#a8962db3dac489d800d8fc9cc13a0641b":[4,0,0,139,6], +"w3fi88_8f.html#a9a711b7afb78b8e4e813d29a6d00343e":[4,0,0,139,5], +"w3fi88_8f.html#ada2a564df0576afd8796b682c9c50b73":[4,0,0,139,8], +"w3fi88_8f.html#ade4fae47f4dcc026b6ffb64e03f55651":[4,0,0,139,9], +"w3fi88_8f.html#af7dc9d23ed351c8f1e385475ca39c737":[4,0,0,139,1], +"w3fi88_8f_source.html":[4,0,0,139], +"w3fi92_8f.html":[4,0,0,140], +"w3fi92_8f.html#a22888b37a35c7f9abe63dc5cfd743422":[4,0,0,140,0], +"w3fi92_8f_source.html":[4,0,0,140], +"w3fm07_8f.html":[4,0,0,141], +"w3fm07_8f.html#a03b3b4ebb95c829f88ab858b6709cfd7":[4,0,0,141,0], +"w3fm07_8f_source.html":[4,0,0,141], +"w3fm08_8f.html":[4,0,0,142], +"w3fm08_8f.html#ad5d5a454e8cdb3623fbdb0df3f44cbcc":[4,0,0,142,0], +"w3fm08_8f_source.html":[4,0,0,142], +"w3fp04_8f.html":[4,0,0,143], +"w3fp04_8f.html#abc0c89b29a4a74847841e5a1aa35e49a":[4,0,0,143,0], +"w3fp04_8f_source.html":[4,0,0,143], +"w3fp05_8f.html":[4,0,0,144], +"w3fp05_8f.html#a68a1b19e798523cddbf6d2aea4751362":[4,0,0,144,0], +"w3fp05_8f_source.html":[4,0,0,144], +"w3fp06_8f.html":[4,0,0,145], +"w3fp06_8f.html#a1912bdef4280f84618d529e4764ac8fd":[4,0,0,145,6], +"w3fp06_8f.html#a50f973cd14b24a8da68b625d31c18dfa":[4,0,0,145,5], +"w3fp06_8f.html#a85c5aff8a14219277412b5178d23c8eb":[4,0,0,145,4], +"w3fp06_8f.html#a947acf07eeb32317d7ff0c144682c8ad":[4,0,0,145,3], +"w3fp06_8f.html#ad054774044780f0d653a6e9e187b21f9":[4,0,0,145,2], +"w3fp06_8f.html#ae0b22fa11b8fe72122318b34fff3c384":[4,0,0,145,0], +"w3fp06_8f.html#ae1b5ebd2418050ad3b381f3f8d608bc6":[4,0,0,145,1], +"w3fp06_8f_source.html":[4,0,0,145], +"w3fp10_8f.html":[4,0,0,146], +"w3fp10_8f.html#ac8a2ca08aafc6e727d1e230f69c734b3":[4,0,0,146,0], +"w3fp10_8f_source.html":[4,0,0,146], +"w3fp11_8f.html":[4,0,0,147], +"w3fp11_8f.html#a0e68dda36ce06180df15d26525b8ad92":[4,0,0,147,0], +"w3fp11_8f_source.html":[4,0,0,147], +"w3fp12_8f.html":[4,0,0,148], +"w3fp12_8f.html#a90be3644f6c4c935c450a188c5193a3f":[4,0,0,148,0], +"w3fp12_8f_source.html":[4,0,0,148], +"w3fp13_8f.html":[4,0,0,149], +"w3fp13_8f.html#a56fb62646dcbbcea7bc5239ed6f5acd0":[4,0,0,149,0], +"w3fp13_8f_source.html":[4,0,0,149], +"w3fs13_8f.html":[4,0,0,150], +"w3fs13_8f.html#afce9c885afc9ee59a125a8db9ac5eee4":[4,0,0,150,0], +"w3fs13_8f_source.html":[4,0,0,150], +"w3fs15_8f.html":[4,0,0,151], +"w3fs15_8f.html#a6503e7b854ccc60e9a09e85413642c5c":[4,0,0,151,0], +"w3fs15_8f_source.html":[4,0,0,151], +"w3fs21_8f.html":[4,0,0,152], +"w3fs21_8f.html#a9af93d7745b3435c83155476954bbdb8":[4,0,0,152,0], +"w3fs21_8f_source.html":[4,0,0,152], +"w3fs26_8f.html":[4,0,0,153], +"w3fs26_8f.html#a907c7328b67cac5929274519593d6c83":[4,0,0,153,0], +"w3fs26_8f_source.html":[4,0,0,153], +"w3ft00_8f.html":[4,0,0,154], +"w3ft00_8f.html#aef914a82466f1f10f20f61a45cba4676":[4,0,0,154,0], +"w3ft00_8f_source.html":[4,0,0,154], +"w3ft01_8f.html":[4,0,0,155], +"w3ft01_8f.html#a526211242588a42f89dd5f724dd78595":[4,0,0,155,0], +"w3ft01_8f_source.html":[4,0,0,155], +"w3ft02_8f.html":[4,0,0,156], +"w3ft02_8f.html#a2d66a49241741b516a284f7881c67160":[4,0,0,156,0], +"w3ft02_8f_source.html":[4,0,0,156], +"w3ft03_8f.html":[4,0,0,157], +"w3ft03_8f.html#a4989ac1555e50285597693623cc2da77":[4,0,0,157,0], +"w3ft03_8f_source.html":[4,0,0,157], +"w3ft05_8f.html":[4,0,0,158], +"w3ft05_8f.html#affc8959bc48cc6dde6f3d7930a8b407f":[4,0,0,158,0], +"w3ft05_8f_source.html":[4,0,0,158], +"w3ft05v_8f.html":[4,0,0,159], +"w3ft05v_8f.html#a261ecb9571005278007fb4a6fbaf422a":[4,0,0,159,0], +"w3ft05v_8f_source.html":[4,0,0,159], +"w3ft06_8f.html":[4,0,0,160], +"w3ft06_8f.html#a9a0693ca342aef48beac578a24c71e76":[4,0,0,160,0], +"w3ft06_8f_source.html":[4,0,0,160], +"w3ft06v_8f.html":[4,0,0,161], +"w3ft06v_8f.html#aa210c5c31ea35f700b91ed8ce6ed1239":[4,0,0,161,0], +"w3ft06v_8f_source.html":[4,0,0,161], +"w3ft07_8f.html":[4,0,0,162], +"w3ft07_8f.html#aa7bd2293b69b72da36707f39093fb0dd":[4,0,0,162,0], +"w3ft07_8f_source.html":[4,0,0,162], +"w3ft08_8f.html":[4,0,0,163], +"w3ft08_8f.html#ad0708ff0b06b672a0f6cff08ca6edba8":[4,0,0,163,0], +"w3ft08_8f_source.html":[4,0,0,163], +"w3ft09_8f.html":[4,0,0,164], +"w3ft09_8f.html#a43204d3a7e4ec58530223d8561565f49":[4,0,0,164,0], +"w3ft09_8f_source.html":[4,0,0,164], +"w3ft10_8f.html":[4,0,0,165], +"w3ft10_8f.html#a2d7a4e0d67089df728f1011ed937e6b6":[4,0,0,165,0], +"w3ft10_8f_source.html":[4,0,0,165], +"w3ft11_8f.html":[4,0,0,166], +"w3ft11_8f.html#a011258b47ddeb5935f8e1ca9dca6bc28":[4,0,0,166,0], +"w3ft11_8f_source.html":[4,0,0,166], +"w3ft12_8f.html":[4,0,0,167], +"w3ft12_8f.html#a34a66be43ef2429781f8346af0c4fbb1":[4,0,0,167,0], +"w3ft12_8f_source.html":[4,0,0,167], +"w3ft16_8f.html":[4,0,0,168], +"w3ft16_8f.html#a4cfdf338d54decb5ebc703952f1b8258":[4,0,0,168,0], +"w3ft16_8f_source.html":[4,0,0,168], +"w3ft17_8f.html":[4,0,0,169], +"w3ft17_8f.html#ad1ef28f2b547a1d73110bfea51bd92c3":[4,0,0,169,0], +"w3ft17_8f_source.html":[4,0,0,169], +"w3ft201_8f.html":[4,0,0,170], +"w3ft201_8f.html#a4579b97893470f676e00332877d14a8a":[4,0,0,170,0], +"w3ft201_8f_source.html":[4,0,0,170], +"w3ft202_8f.html":[4,0,0,171], +"w3ft202_8f.html#af3cc7cf79e145b0c0b05b77f18a6bc3e":[4,0,0,171,0], +"w3ft202_8f_source.html":[4,0,0,171], +"w3ft203_8f.html":[4,0,0,172], +"w3ft203_8f.html#a33e491f31a1b02e212f2d38e938fff95":[4,0,0,172,0], +"w3ft203_8f_source.html":[4,0,0,172], +"w3ft204_8f.html":[4,0,0,173], +"w3ft204_8f.html#a05244863fcba4deeecafd48af8f97435":[4,0,0,173,0], +"w3ft204_8f_source.html":[4,0,0,173], +"w3ft205_8f.html":[4,0,0,174], +"w3ft205_8f.html#aeecada5cbfb2d7fee1e5a24f2e7b694e":[4,0,0,174,0], +"w3ft205_8f_source.html":[4,0,0,174], +"w3ft206_8f.html":[4,0,0,175], +"w3ft206_8f.html#a11bbf4178c5e3290da90771366c95aaa":[4,0,0,175,0], +"w3ft206_8f_source.html":[4,0,0,175], +"w3ft207_8f.html":[4,0,0,176], +"w3ft207_8f.html#a5be00916db03675c80fb3177a464f262":[4,0,0,176,0], +"w3ft207_8f_source.html":[4,0,0,176], +"w3ft208_8f.html":[4,0,0,177], +"w3ft208_8f.html#a39df24e7c5c06b8b094f9baf7a637068":[4,0,0,177,0], +"w3ft208_8f_source.html":[4,0,0,177], +"w3ft209_8f.html":[4,0,0,178], +"w3ft209_8f.html#a2482ea3acabfb84f5b4277e5d09c2d36":[4,0,0,178,0], +"w3ft209_8f_source.html":[4,0,0,178], +"w3ft210_8f.html":[4,0,0,180], +"w3ft210_8f.html#a262a8baf12c888d64c696bc3ba05be04":[4,0,0,180,0], +"w3ft210_8f_source.html":[4,0,0,180], +"w3ft211_8f.html":[4,0,0,181], +"w3ft211_8f.html#aee78a998ceaf5a96225189c7e3be7262":[4,0,0,181,0], +"w3ft211_8f_source.html":[4,0,0,181], +"w3ft212_8f.html":[4,0,0,182], +"w3ft212_8f.html#af275f1336203bfcbb465545daaa39fe5":[4,0,0,182,0], +"w3ft212_8f_source.html":[4,0,0,182], +"w3ft213_8f.html":[4,0,0,183], +"w3ft213_8f.html#afd9acc707a0050ee144f922d2fd7f561":[4,0,0,183,0], +"w3ft213_8f_source.html":[4,0,0,183], +"w3ft214_8f.html":[4,0,0,184], +"w3ft214_8f.html#a6f956d8742bb119f8ebf3e1eeb95d78b":[4,0,0,184,0], +"w3ft214_8f_source.html":[4,0,0,184] }; diff --git a/navtreeindex3.js b/navtreeindex3.js index 91a7a689..4f72127f 100644 --- a/navtreeindex3.js +++ b/navtreeindex3.js @@ -1,253 +1,96 @@ var NAVTREEINDEX3 = { -"w3fi85_8f.html#a17405ce8ebd7d06c0bedf0bea6ae2105":[2,0,140,9], -"w3fi85_8f.html#a2dfac12c57c3882ab71df73ae85329ef":[2,0,140,0], -"w3fi85_8f.html#a43fe930255ffb0865c2329031d294786":[2,0,140,6], -"w3fi85_8f.html#a52f6aae9ed57d3745d0e142b54366427":[2,0,140,3], -"w3fi85_8f.html#a65ffb3c26f568c33248204db13547c2f":[2,0,140,2], -"w3fi85_8f.html#a909b8c9399363ed4f51c78bedb57f3cd":[2,0,140,4], -"w3fi85_8f.html#a952501a26ebad493c05a3b8028fc6cd7":[2,0,140,10], -"w3fi85_8f.html#a97892186cc13a9f697d5cc447131db26":[2,0,140,5], -"w3fi85_8f.html#aa2db7280cff113d09e4ade7687aaca1a":[2,0,140,1], -"w3fi85_8f.html#ab388b83b7f0918bbae5097408882c6b9":[2,0,140,8], -"w3fi85_8f.html#ae5983e91fa36267f15a462c84a649de3":[2,0,140,7], -"w3fi85_8f_source.html":[2,0,140], -"w3fi88_8f.html":[2,0,141], -"w3fi88_8f.html#a119b554db1325ff6b2d3742797f107dd":[2,0,141,5], -"w3fi88_8f.html#a12b020b46772271cab997bb781bda9c1":[2,0,141,10], -"w3fi88_8f.html#a228b9ca88ab5e42aa00c6df379ecd470":[2,0,141,2], -"w3fi88_8f.html#a2a7856fc62e88d8fa8670e58c4082293":[2,0,141,7], -"w3fi88_8f.html#a334e81d3c01ac71a02ef5425671e7bf0":[2,0,141,8], -"w3fi88_8f.html#a45180c8723bc0f7b3eaff47b7fda7ed8":[2,0,141,4], -"w3fi88_8f.html#a4d95a6e5cfd0779cd61856302084ba4a":[2,0,141,15], -"w3fi88_8f.html#a4f8b235c2c2a9b5bb74da9207021384e":[2,0,141,13], -"w3fi88_8f.html#a5d193ac75cc3a3a167b66c2fe484bcf5":[2,0,141,11], -"w3fi88_8f.html#a7829bc0e44ec367834a1a6d83377d428":[2,0,141,1], -"w3fi88_8f.html#a7bbb69a4b21fc8e813cdf6b0497b3d53":[2,0,141,17], -"w3fi88_8f.html#a94b6d994b2df117c1395048caea2f86b":[2,0,141,3], -"w3fi88_8f.html#aa56d7f5f943a7bf774c2e9ddc144595f":[2,0,141,6], -"w3fi88_8f.html#aaa3b36f853bace0e172b8191ce3a4f17":[2,0,141,18], -"w3fi88_8f.html#ab79c59537e969d0ca237e032cb41261b":[2,0,141,16], -"w3fi88_8f.html#abb7e96e4b35aa7e920bc388cdc5b43f0":[2,0,141,14], -"w3fi88_8f.html#adad8332e2168ab134f2c6f879f133a5f":[2,0,141,9], -"w3fi88_8f.html#adbabb10d7dd7f6a7de08d6d415d1e876":[2,0,141,12], -"w3fi88_8f.html#ae5d0192919fea00763c2ea1490bff16a":[2,0,141,0], -"w3fi88_8f_source.html":[2,0,141], -"w3fi92_8f.html":[2,0,142], -"w3fi92_8f.html#a2e8b8ef3dcf66d40422987430e28545a":[2,0,142,0], -"w3fi92_8f_source.html":[2,0,142], -"w3fm07_8f.html":[2,0,143], -"w3fm07_8f.html#a3fb4f69f29d16715851691eae8cd482b":[2,0,143,0], -"w3fm07_8f_source.html":[2,0,143], -"w3fm08_8f.html":[2,0,144], -"w3fm08_8f.html#ad2e28d805a383d0025c930544cb36155":[2,0,144,0], -"w3fm08_8f_source.html":[2,0,144], -"w3fp04_8f.html":[2,0,145], -"w3fp04_8f.html#af033f564bf5f078cbfc4700e62291470":[2,0,145,0], -"w3fp04_8f_source.html":[2,0,145], -"w3fp05_8f.html":[2,0,146], -"w3fp05_8f.html#a5d4251a5f962d24d56f5ce0b3b4212b8":[2,0,146,0], -"w3fp05_8f_source.html":[2,0,146], -"w3fp06_8f.html":[2,0,147], -"w3fp06_8f.html#a07285bde2b2eda3dea091bbb82ab27ee":[2,0,147,3], -"w3fp06_8f.html#a67cf94ad0864f312b980ca2315e729e2":[2,0,147,4], -"w3fp06_8f.html#a69e9f6991efd633d1734e87d0c0cf6f1":[2,0,147,2], -"w3fp06_8f.html#a771b5aa20028a43dd4e5fed735c85797":[2,0,147,1], -"w3fp06_8f.html#a857d20cd6a97ba1e266d803b2092670c":[2,0,147,5], -"w3fp06_8f.html#aaf8401635d84331960b1c2985cd74a51":[2,0,147,0], -"w3fp06_8f.html#afb6a19727a1186c10ede9bba2d3315c0":[2,0,147,6], -"w3fp06_8f_source.html":[2,0,147], -"w3fp10_8f.html":[2,0,148], -"w3fp10_8f.html#a2d0f404c14f9e2ea8e6a9f0e911a825e":[2,0,148,0], -"w3fp10_8f_source.html":[2,0,148], -"w3fp11_8f.html":[2,0,149], -"w3fp11_8f.html#a60348721f6e1b543427aba610af0a85d":[2,0,149,0], -"w3fp11_8f_source.html":[2,0,149], -"w3fp12_8f.html":[2,0,150], -"w3fp12_8f.html#a43259ead9ef06e1822639a8f2aa106aa":[2,0,150,0], -"w3fp12_8f_source.html":[2,0,150], -"w3fp13_8f.html":[2,0,151], -"w3fp13_8f.html#a4bb36ff2a73a0614b75ec00e2b804740":[2,0,151,0], -"w3fp13_8f_source.html":[2,0,151], -"w3fq07_8f.html":[2,0,152], -"w3fq07_8f.html#a621d5a7f77939450e814033c6f3b1535":[2,0,152,0], -"w3fq07_8f_source.html":[2,0,152], -"w3fs13_8f.html":[2,0,153], -"w3fs13_8f.html#a7ae96960810e2a780cc1dfaa4740e4ec":[2,0,153,0], -"w3fs13_8f_source.html":[2,0,153], -"w3fs15_8f.html":[2,0,154], -"w3fs15_8f.html#ada3b10209aac56c01b05d096d84e6471":[2,0,154,0], -"w3fs15_8f_source.html":[2,0,154], -"w3fs21_8f.html":[2,0,155], -"w3fs21_8f.html#a337c53a535dd6a8066f313eb9889201c":[2,0,155,0], -"w3fs21_8f_source.html":[2,0,155], -"w3fs26_8f.html":[2,0,156], -"w3fs26_8f.html#ab9c55405126eb6b249eb3d6542c0bb30":[2,0,156,0], -"w3fs26_8f_source.html":[2,0,156], -"w3ft00_8f.html":[2,0,157], -"w3ft00_8f.html#a0df888e118ff615726dfe75f1f268c21":[2,0,157,0], -"w3ft00_8f_source.html":[2,0,157], -"w3ft01_8f.html":[2,0,158], -"w3ft01_8f.html#a5712b189cf471fffe9b1529a75949729":[2,0,158,0], -"w3ft01_8f_source.html":[2,0,158], -"w3ft02_8f.html":[2,0,159], -"w3ft02_8f.html#ab2829ffb3ea29d17638612b1e6f4bcdf":[2,0,159,0], -"w3ft02_8f_source.html":[2,0,159], -"w3ft03_8f.html":[2,0,160], -"w3ft03_8f.html#a86672f0df93a525a9c2f295bf3e9de0b":[2,0,160,0], -"w3ft03_8f_source.html":[2,0,160], -"w3ft05_8f.html":[2,0,161], -"w3ft05_8f.html#a752b36aee00d233764c2d4fc9aa83d48":[2,0,161,0], -"w3ft05_8f_source.html":[2,0,161], -"w3ft05v_8f.html":[2,0,162], -"w3ft05v_8f.html#a77ae0ff42d73bc3e901c84d6fae74d60":[2,0,162,0], -"w3ft05v_8f_source.html":[2,0,162], -"w3ft06_8f.html":[2,0,163], -"w3ft06_8f.html#a251b117d0bb18aa51a81c14180fda635":[2,0,163,0], -"w3ft06_8f_source.html":[2,0,163], -"w3ft06v_8f.html":[2,0,164], -"w3ft06v_8f.html#a02340fb38509abdb031c638362609844":[2,0,164,0], -"w3ft06v_8f_source.html":[2,0,164], -"w3ft07_8f.html":[2,0,165], -"w3ft07_8f.html#a226490ee379923e202ba1f7d0d14102a":[2,0,165,0], -"w3ft07_8f_source.html":[2,0,165], -"w3ft08_8f.html":[2,0,166], -"w3ft08_8f.html#ae48a19283d690c37fe8c3dc355e8e609":[2,0,166,0], -"w3ft08_8f_source.html":[2,0,166], -"w3ft09_8f.html":[2,0,167], -"w3ft09_8f.html#ac50128472db184365bc4c2dfb1ea1a47":[2,0,167,0], -"w3ft09_8f_source.html":[2,0,167], -"w3ft10_8f.html":[2,0,168], -"w3ft10_8f.html#a17871a93f588bd482470dd30d88f6b8c":[2,0,168,0], -"w3ft10_8f_source.html":[2,0,168], -"w3ft11_8f.html":[2,0,169], -"w3ft11_8f.html#af60fd501521a85612c264e601718bb68":[2,0,169,0], -"w3ft11_8f_source.html":[2,0,169], -"w3ft12_8f.html":[2,0,170], -"w3ft12_8f.html#afb994008cf891b44e3fe4a25c0b46157":[2,0,170,0], -"w3ft12_8f_source.html":[2,0,170], -"w3ft16_8f.html":[2,0,171], -"w3ft16_8f.html#a3eb1bcdeb5163086f4e319d036fa9b8f":[2,0,171,0], -"w3ft16_8f_source.html":[2,0,171], -"w3ft17_8f.html":[2,0,172], -"w3ft17_8f.html#ac26d2dfc790515275a019ab4588f0751":[2,0,172,0], -"w3ft17_8f_source.html":[2,0,172], -"w3ft201_8f.html":[2,0,173], -"w3ft201_8f.html#adf01350dac0812280321527151e91c76":[2,0,173,0], -"w3ft201_8f_source.html":[2,0,173], -"w3ft202_8f.html":[2,0,174], -"w3ft202_8f.html#a250a1c3e5855f0481b17a3bf264cb2cd":[2,0,174,0], -"w3ft202_8f_source.html":[2,0,174], -"w3ft203_8f.html":[2,0,175], -"w3ft203_8f.html#ac0fba620647d28d2dfd0424c2d3543e8":[2,0,175,0], -"w3ft203_8f_source.html":[2,0,175], -"w3ft204_8f.html":[2,0,176], -"w3ft204_8f.html#abb78410bc09aaf18f345e4a90c7cff9f":[2,0,176,0], -"w3ft204_8f_source.html":[2,0,176], -"w3ft205_8f.html":[2,0,177], -"w3ft205_8f.html#ad9a3463156cbb99e97f7f3c2f9e0bc26":[2,0,177,0], -"w3ft205_8f_source.html":[2,0,177], -"w3ft206_8f.html":[2,0,178], -"w3ft206_8f.html#a8a2d9d2de5ecb622756c8138eab5377c":[2,0,178,0], -"w3ft206_8f_source.html":[2,0,178], -"w3ft207_8f.html":[2,0,179], -"w3ft207_8f.html#aa4de7ddd4f65373756f6cd70b3fd6fec":[2,0,179,0], -"w3ft207_8f_source.html":[2,0,179], -"w3ft208_8f.html":[2,0,180], -"w3ft208_8f.html#ab3380c5bf59fbd57210787bb91f5584f":[2,0,180,0], -"w3ft208_8f_source.html":[2,0,180], -"w3ft209_8f.html":[2,0,181], -"w3ft209_8f.html#a8d2adf2c3f2603ed6555c88d77f0b51b":[2,0,181,0], -"w3ft209_8f_source.html":[2,0,181], -"w3ft210_8f.html":[2,0,183], -"w3ft210_8f.html#a3803de9cbf2932eb2aa3b36ed8fef355":[2,0,183,0], -"w3ft210_8f_source.html":[2,0,183], -"w3ft211_8f.html":[2,0,184], -"w3ft211_8f.html#a353f8903a8cbe06aa931ab815e317708":[2,0,184,0], -"w3ft211_8f_source.html":[2,0,184], -"w3ft212_8f.html":[2,0,185], -"w3ft212_8f.html#a80630575cad8c3e8743fb7b161d2b18e":[2,0,185,0], -"w3ft212_8f_source.html":[2,0,185], -"w3ft213_8f.html":[2,0,186], -"w3ft213_8f.html#a1de78ace88fde1b28429425c20838344":[2,0,186,0], -"w3ft213_8f_source.html":[2,0,186], -"w3ft214_8f.html":[2,0,187], -"w3ft214_8f.html#a87c1f4b3ef6dccfe37b0a288d2143848":[2,0,187,0], -"w3ft214_8f_source.html":[2,0,187], -"w3ft21_8f.html":[2,0,182], -"w3ft21_8f.html#a681f756a8ebbb0bed83c216be180c4ae":[2,0,182,0], -"w3ft21_8f_source.html":[2,0,182], -"w3ft26_8f.html":[2,0,188], -"w3ft26_8f.html#a584757389b1cf4707abb4cadb47850ab":[2,0,188,0], -"w3ft26_8f_source.html":[2,0,188], -"w3ft32_8f.html":[2,0,189], -"w3ft32_8f.html#acfaec65cdd9e813295e8e83626c176cd":[2,0,189,0], -"w3ft32_8f_source.html":[2,0,189], -"w3ft33_8f.html":[2,0,190], -"w3ft33_8f.html#aa788035129e6f04923f7f351fb343ff0":[2,0,190,0], -"w3ft33_8f_source.html":[2,0,190], -"w3ft38_8f.html":[2,0,191], -"w3ft38_8f.html#a1826351145421b3de7f51f5b798ae391":[2,0,191,0], -"w3ft38_8f_source.html":[2,0,191], -"w3ft39_8f.html":[2,0,192], -"w3ft39_8f.html#a858e5d96caaef7d2d5882420f7bc3556":[2,0,192,0], -"w3ft39_8f_source.html":[2,0,192], -"w3ft40_8f.html":[2,0,193], -"w3ft40_8f.html#a3bc42dc396a768eb87167924c73c65d6":[2,0,193,0], -"w3ft40_8f_source.html":[2,0,193], -"w3ft41_8f.html":[2,0,194], -"w3ft41_8f.html#a261b10911c4a789b882deef2c1f312ca":[2,0,194,0], -"w3ft41_8f_source.html":[2,0,194], -"w3ft43v_8f.html":[2,0,195], -"w3ft43v_8f.html#a2296d6ab6d8638d5d0d59468cc6402d5":[2,0,195,0], -"w3ft43v_8f_source.html":[2,0,195], -"w3kind_8f.html":[2,0,196], -"w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a":[2,0,196,0], -"w3kind_8f_source.html":[2,0,196], -"w3locdat_8f.html":[2,0,197], -"w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1":[2,0,197,0], -"w3locdat_8f_source.html":[2,0,197], -"w3log_8f_source.html":[2,0,198], -"w3miscan_8f.html":[2,0,199], -"w3miscan_8f.html#a4b77772e4547b0f74a9b1c669a839be6":[2,0,199,6], -"w3miscan_8f.html#a6edc5e68c541091294d41f99e804a05e":[2,0,199,5], -"w3miscan_8f.html#a7ee0202db29014a39612fd133a9ca421":[2,0,199,2], -"w3miscan_8f.html#ac30ceca6f563c3f755520f227e068930":[2,0,199,7], -"w3miscan_8f.html#acde6036e077def96f8071397d2eec3f5":[2,0,199,1], -"w3miscan_8f.html#adda71e84fc0a136a1b9de35eb6c02d19":[2,0,199,4], -"w3miscan_8f.html#aded626863c4df7539accbced4b6ab799":[2,0,199,3], -"w3miscan_8f.html#af1352ee5db91f6a057c1378cf9b00df1":[2,0,199,8], -"w3miscan_8f.html#afdde0d874410648935ffd0d1c5457321":[2,0,199,0], -"w3miscan_8f_source.html":[2,0,199], -"w3movdat_8f.html":[2,0,200], -"w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339":[2,0,200,0], -"w3movdat_8f_source.html":[2,0,200], -"w3nogds_8f.html":[2,0,201], -"w3nogds_8f.html#a9fee3e95f39d96f49f71d4fe1a681e6a":[2,0,201,0], -"w3nogds_8f_source.html":[2,0,201], -"w3pradat_8f.html":[2,0,202], -"w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6":[2,0,202,0], -"w3pradat_8f_source.html":[2,0,202], -"w3reddat_8f.html":[2,0,203], -"w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb":[2,0,203,0], -"w3reddat_8f_source.html":[2,0,203], -"w3tagb_8f.html":[2,0,204], -"w3tagb_8f.html#ac295260f62d3bdcf6c621177ff7d9275":[2,0,204,0], -"w3tagb_8f_source.html":[2,0,204], -"w3trnarg_8f.html":[2,0,205], -"w3trnarg_8f.html#a469f580bad86541dc4ffe778b0eaf9bf":[2,0,205,0], -"w3trnarg_8f_source.html":[2,0,205], -"w3unpk77_8f.html":[2,0,206], -"w3unpk77_8f.html#a162c40d765efa43eeae668a6af507843":[2,0,206,9], -"w3unpk77_8f.html#a38fd0aaaeb7ad9a2f9f9453afc11cd1e":[2,0,206,8], -"w3unpk77_8f.html#a4196e848ecd6558e30a6c0617a35737c":[2,0,206,5], -"w3unpk77_8f.html#a83668f95551d6806db9d28f6ce577f22":[2,0,206,4], -"w3unpk77_8f.html#a87aaaaef2fb86ea98c45d5c206961033":[2,0,206,6], -"w3unpk77_8f.html#a9589ef1331e503fdbdc2ff306ae60143":[2,0,206,3], -"w3unpk77_8f.html#ab038d6f2a6c28d162b38828264552068":[2,0,206,7], -"w3unpk77_8f.html#ab50a57de79ddc4377c2c17512e58c6ea":[2,0,206,0], -"w3unpk77_8f.html#ab7a2a42f29d7122f4273548568b0168a":[2,0,206,2], -"w3unpk77_8f.html#affac66f51c4a903f7e20d643da19f4df":[2,0,206,1], -"w3unpk77_8f_source.html":[2,0,206], -"w3utcdat_8f.html":[2,0,207] +"w3ft21_8f.html":[4,0,0,179], +"w3ft21_8f.html#a918182b6d42437b6657cf5d23d7d9240":[4,0,0,179,0], +"w3ft21_8f_source.html":[4,0,0,179], +"w3ft26_8f.html":[4,0,0,185], +"w3ft26_8f.html#a225e7f8bb24f8c2878453792a88cee97":[4,0,0,185,0], +"w3ft26_8f_source.html":[4,0,0,185], +"w3ft32_8f.html":[4,0,0,186], +"w3ft32_8f.html#a505bbee044cd5b9c1484ef45ded77d52":[4,0,0,186,0], +"w3ft32_8f_source.html":[4,0,0,186], +"w3ft33_8f.html":[4,0,0,187], +"w3ft33_8f.html#a7c1d44437b786040567e37bcbc44765f":[4,0,0,187,0], +"w3ft33_8f_source.html":[4,0,0,187], +"w3ft38_8f.html":[4,0,0,188], +"w3ft38_8f.html#a650ca7b1763805ead1c270d68d9a12c4":[4,0,0,188,0], +"w3ft38_8f_source.html":[4,0,0,188], +"w3ft39_8f.html":[4,0,0,189], +"w3ft39_8f.html#aacebb1724c4f1396a70221ce78ed2fd5":[4,0,0,189,0], +"w3ft39_8f_source.html":[4,0,0,189], +"w3ft40_8f.html":[4,0,0,190], +"w3ft40_8f.html#ac08e699870c05a14afcf7f90d27d8094":[4,0,0,190,0], +"w3ft40_8f_source.html":[4,0,0,190], +"w3ft41_8f.html":[4,0,0,191], +"w3ft41_8f.html#a6f67ac7895427653fd746467ce92a2ad":[4,0,0,191,0], +"w3ft41_8f_source.html":[4,0,0,191], +"w3ft43v_8f.html":[4,0,0,192], +"w3ft43v_8f.html#a77e63a518c43c75ba9538080631c60fc":[4,0,0,192,0], +"w3ft43v_8f_source.html":[4,0,0,192], +"w3kind_8f.html":[4,0,0,193], +"w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a":[4,0,0,193,0], +"w3kind_8f_source.html":[4,0,0,193], +"w3locdat_8f.html":[4,0,0,194], +"w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1":[4,0,0,194,0], +"w3locdat_8f_source.html":[4,0,0,194], +"w3log_8f_source.html":[4,0,0,195], +"w3miscan_8f.html":[4,0,0,196], +"w3miscan_8f.html#a2fbfd745aaa9ecb372ff2524a682ccae":[4,0,0,196,3], +"w3miscan_8f.html#a6ebad02513c61fc41c51db9cf3bbaf7f":[4,0,0,196,2], +"w3miscan_8f.html#a77f06920ef1ce938ca29cc1ea7a18b56":[4,0,0,196,0], +"w3miscan_8f.html#aa99de7615b5b2a0f60a385c3be1ba9da":[4,0,0,196,6], +"w3miscan_8f.html#aae1710f52170633399d23802b4ad8b51":[4,0,0,196,5], +"w3miscan_8f.html#ab194d2809f49e869082d6ae6b3b977c9":[4,0,0,196,7], +"w3miscan_8f.html#ae39c3c17acb9b8b9e8865dce77e99179":[4,0,0,196,4], +"w3miscan_8f.html#aeeda29d4c214b97b0f8b9eb7f847f0db":[4,0,0,196,8], +"w3miscan_8f.html#af225a39ea11be14a9d8ae53744bd70b1":[4,0,0,196,1], +"w3miscan_8f_source.html":[4,0,0,196], +"w3movdat_8f.html":[4,0,0,197], +"w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339":[4,0,0,197,0], +"w3movdat_8f_source.html":[4,0,0,197], +"w3nogds_8f.html":[4,0,0,198], +"w3nogds_8f.html#a5717adc8ddf26fc6a7fdcd02d60a8c5b":[4,0,0,198,0], +"w3nogds_8f_source.html":[4,0,0,198], +"w3pradat_8f.html":[4,0,0,199], +"w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6":[4,0,0,199,0], +"w3pradat_8f_source.html":[4,0,0,199], +"w3reddat_8f.html":[4,0,0,200], +"w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb":[4,0,0,200,0], +"w3reddat_8f_source.html":[4,0,0,200], +"w3tagb_8f.html":[4,0,0,201], +"w3tagb_8f.html#a7e2cdefc989c6ec94d6366fe46e86b2f":[4,0,0,201,0], +"w3tagb_8f_source.html":[4,0,0,201], +"w3trnarg_8f.html":[4,0,0,202], +"w3trnarg_8f.html#aa93f106864755e8a7347b10d425e1764":[4,0,0,202,0], +"w3trnarg_8f_source.html":[4,0,0,202], +"w3unpk77_8f.html":[4,0,0,203], +"w3unpk77_8f.html#a03a9e7379784e4998d610e00673b05ea":[4,0,0,203,7], +"w3unpk77_8f.html#a35877dbb88d9e6fb89b1807238f95018":[4,0,0,203,1], +"w3unpk77_8f.html#a3b7ce3ad5342da6e89fbbeb173ae47d5":[4,0,0,203,4], +"w3unpk77_8f.html#a515f864a3a6adab3695cef735f610479":[4,0,0,203,8], +"w3unpk77_8f.html#a5f0f3e0fe1648c04ba5a47a13f405c4f":[4,0,0,203,9], +"w3unpk77_8f.html#a6e6b3e1b8bac81ed3db73ab1fca6c40f":[4,0,0,203,0], +"w3unpk77_8f.html#a73cd8561593c0b5c72075104f7200594":[4,0,0,203,6], +"w3unpk77_8f.html#a781d7a1d34ea17a555131bdde0ce1579":[4,0,0,203,5], +"w3unpk77_8f.html#a9dfb4c67d159cc49f2a43151ec25e915":[4,0,0,203,3], +"w3unpk77_8f.html#ac39a6820df8dfea69d930ab738b8b07e":[4,0,0,203,2], +"w3unpk77_8f_source.html":[4,0,0,203], +"w3utcdat_8f.html":[4,0,0,204], +"w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a":[4,0,0,204,0], +"w3utcdat_8f_source.html":[4,0,0,204], +"w3valdat_8f.html":[4,0,0,205], +"w3valdat_8f.html#a8a051a793c804f190e2da69fd1e16ebe":[4,0,0,205,0], +"w3valdat_8f_source.html":[4,0,0,205], +"w3ymdh4_8f.html":[4,0,0,206], +"w3ymdh4_8f.html#a6ec6f6ef8936c7069feafafcb4ca333b":[4,0,0,206,0], +"w3ymdh4_8f_source.html":[4,0,0,206], +"xdopen_8f.html":[4,0,0,207], +"xdopen_8f.html#a941a5a5172e73a4d75553437ad275ece":[4,0,0,207,0], +"xdopen_8f_source.html":[4,0,0,207], +"xmovex_8f.html":[4,0,0,208], +"xmovex_8f.html#a9966425854c3a77f854b1397051af333":[4,0,0,208,0], +"xmovex_8f_source.html":[4,0,0,208], +"xstore_8f.html":[4,0,0,209], +"xstore_8f.html#ad26510a638e68e3e62108516ffc9e5dc":[4,0,0,209,0], +"xstore_8f_source.html":[4,0,0,209] }; diff --git a/orders_8f.html b/orders_8f.html index c8aee5af..635ed8ed 100644 --- a/orders_8f.html +++ b/orders_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: orders.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
orders.f File Reference
+
orders.f File Reference
@@ -94,20 +100,17 @@

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...
 
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.
 

Detailed Description

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

@@ -116,8 +119,206 @@

Definition in file orders.f.

Function/Subroutine Documentation

- -

◆ orders()

+ +

◆ ordec4()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine ordec4 ( in,
dimension(n) isort,
character(4), dimension(m,n) idata,
dimension(n) index,
 n,
 m,
 i1,
 i2 
)
+
+ +

Definition at line 331 of file orders.f.

+ +
+
+ +

◆ ordec8()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine ordec8 ( in,
dimension(n) isort,
character(8), dimension(m,n) idata,
dimension(n) index,
 n,
 m,
 i1,
 i2 
)
+
+ +

Definition at line 275 of file orders.f.

+ +
+
+ +

◆ order4()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine order4 ( in,
dimension(n) isort,
integer(4), dimension(m,n) idata,
dimension(n) index,
 n,
 m,
 i1,
 i2 
)
+
+ +

Definition at line 188 of file orders.f.

+ +
+
+ +

◆ orders()

@@ -126,49 +327,49 @@

subroutine orders (   - IN, + in, dimension(n)  - ISORT, + isort, integer(8), dimension(m,n)  - IDATA, + idata, dimension(n)  - INDEX, + index,   - N, + n,   - M, + m,   - I1, + i1,   - I2  + i2  @@ -240,7 +441,7 @@

diff --git a/orders_8f.js b/orders_8f.js index a3ff35b1..19f3b58d 100644 --- a/orders_8f.js +++ b/orders_8f.js @@ -1,7 +1,4 @@ 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 ] + [ "orders", "orders_8f.html#a606ed1b385c755d9ebbc4de760349893", null ] ]; \ No newline at end of file diff --git a/orders_8f_source.html b/orders_8f_source.html index e37b3bca..58f74d96 100644 --- a/orders_8f_source.html +++ b/orders_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: orders.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,409 +81,417 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
orders.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief A Fast and stable sort routine suitable for efficient,
+
3C> multiple-pass sorting on variable length characters, integers, or
+
4C> real numbers.
+
5C> @author Jack Woollen @date 1999-06-03
+
6
+
7C> Orders is a fast and stable sort routine suitable for efficient,
+
8C> multiple-pass sorting on variable length characters, integers, or
+
9C> real numbers. The algorithm derives from the radix or bucket sort
+
10C> procedure. The form of the orders subroutine is defined by a cray
+
11C> man page. The sort works by computing frequency distribution of the
+
12C> set of sort keys and using that as a map of the reordered data.
+
13C> Orders rearranges indexes instead of the sort keys, which simplifies
+
14C> multi-pass record sorting. The radix of the sort determines how many
+
15C> "buckets" there are in the frequency distribution array. The larger
+
16C> the radix the more buckets. The simplest is a one bit radix, which
+
17C> has two buckets, and requires as many passes through the keys as
+
18C> the keys have bits. A one byte radix requires less passes through
+
19C> the data with more buckets (256 to be exact). The one byte radix
+
20C> is implemented here. An additional complication is the fact that
+
21C> radix sort only works on key sets of positive values, so this
+
22C> implementation includes a biasing of the (numeric) keys before
+
23C> sorting. To save space the keys themselves are adjusted and then
+
24C> readjusted before returning. A simple example of a one bit radix
+
25C> sort on a list of four, four bit, numbers is diagramed below to
+
26C> illustrate the concept.
+
27C>
+
28C> <pre>
+
29C>-----------------------------------------------------------------------
+
30C> PASS1 > PASS2 > PASS3 > PASS4 > FINISHED
+
31C>-----------------------------------------------------------------------
+
32C> | | | |
+
33C> THE LIST 0011 0100 0100 1001 0011
+
34C> 0101 0011 0101 0011 0100
+
35C> 1001 0101 1001 0100 0101
+
36C> 0100 1001 0011 0101 1001
+
37C>-----------------------------------------------------------------------
+
38C> BUCKET 0 0100 0100 1001 0011
+
39C> | 0101 0011 0100
+
40C> | 1001 | 0101
+
41C>-----------------------------------------------------------------------
+
42C> BUCKET 1 0011 0011 0100 1001
+
43C> 0101 | 0101 |
+
44C> 1001 | | |
+
45C>-----------------------------------------------------------------------
+
46C> </pre>
+
47C>
+
48C> PROGRAM HISTORY LOG:
+
49C> - Jack Woollen 1998-02-21 Original version for implementation
+
50C> - Boi Vuong 1998-04-11 Replaced operand .and. with intrinsic iand
+
51C> - D. Keyser 1999-06-03 Modified to port to ibm sp and run in 4 or
+
52C> 8 Byte storage
+
53C> - Jack Woollen 1999-06-09 Added potential for four or eight byte keys
+
54C> in either a four or eight byte environment
+
55C> - Jack Woollen 2012-09-16 Made sorting characters work on little endian
+
56C>
+
57C> INPUT ARGUMENTS:
+
58C> @param[in] IN Indicator of key form and index state.
+
59C> - IN = 0 Initialize indexes and sort characters.
+
60C> - IN = 1 Initialize indexes and sort integers.
+
61C> - IN = 2 Initialize indexes and sort real numbers.
+
62C> - IN = 10 Sort characters with indexes as is.
+
63C> - IN = 11 Sort integers with indexes as is.
+
64C> - IN = 12 Sort real numbers with indexes asis.
+
65C> @param[in] ISORT Work array with the same dimension as idata.
+
66C> @param[in] IDATA Array of sort keys as described by in.
+
67C> @param[out] INDEX Array of indexes representing the sorted idata.
+
68C> @param[in] N Dimension of isort, idata, and index.
+
69C> @param[in] M Offset (in key-words) between successive members of idata.
+
70C> @param[in] I1 Byte length of the key-words.
+
71C> @param[in] I2 Not used; Included for compatability with original cray
+
72C> routine.
+
73C>
+
74C> @note The one byte radix method was selected for orders because it
+
75C> offers a good ratio of memory requirement to operation count
+
76C> for producing a sort. Because of recursive manipulation of indexes
+
77C> in one of the loops, this may actually take slightly longer on some
+
78C> vector machines than a (more work intensive) one bit radix method.
+
79C> In general, though, the one byte method is faster. Any larger radix
+
80C> presents exponentially increasing memory required. Note that the
+
81C> implementation uses very little local data space, and only modest
+
82C> user-supplied memory.
+
83C>
+
84C> @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
+
93C-----------------------------------------------------------------------
+
94C-----------------------------------------------------------------------
+
95
+
96C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
+
97C -------------------------------------------------------------------
+
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
+
106c call different branches for different types of keys
+
107c ---------------------------------------------------
+
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
+
122C COMPUTE A POSITIVE BIAS FOR INTEGER OR REAL NUMBERS
+
123C ---------------------------------------------------
+
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
+
141C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
+
142C -------------------------------------------------------------------
+
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
+
169C UNBIAS THE INPUT ARRAY ON THE WAY OUT
+
170C -------------------------------------
+
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
+
181C FINISHED!
+
182C ---------
+
183
+
184 RETURN
+
+
185 END
+
186C-----------------------------------------------------------------------
+
187C-----------------------------------------------------------------------
+
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
+
196C-----------------------------------------------------------------------
+
197C-----------------------------------------------------------------------
+
198
+
199C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
+
200C -------------------------------------------------------------------
+
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
+
209C COMPUTE A POSITIVE BIAS FOR INTEGER OR REAL NUMBERS
+
210C ---------------------------------------------------
+
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
+
228C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
+
229C -------------------------------------------------------------------
+
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
+
256C UNBIAS THE INPUT ARRAY ON THE WAY OUT
+
257C -------------------------------------
+
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
+
268C FINISHED!
+
269C ---------
+
270
+
271 RETURN
+
272 END
+
273C-----------------------------------------------------------------------
+
274C-----------------------------------------------------------------------
+
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
+
281C-----------------------------------------------------------------------
+
282C-----------------------------------------------------------------------
+
283
+
284C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
+
285C -------------------------------------------------------------------
+
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
+
294C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
+
295C -------------------------------------------------------------------
+
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
+
324C FINISHED!
+
325C ---------
+
326
+
327 RETURN
+
328 END
+
329C-----------------------------------------------------------------------
+
330C-----------------------------------------------------------------------
+
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
+
337C-----------------------------------------------------------------------
+
338C-----------------------------------------------------------------------
+
339
+
340C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
+
341C -------------------------------------------------------------------
+
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
+
350C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
+
351C -------------------------------------------------------------------
+
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
+
380C FINISHED!
+
381C ---------
+
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/pdsens_8f.html b/pdsens_8f.html index 18fd11ff..32e0273b 100644 --- a/pdsens_8f.html +++ b/pdsens_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: pdsens.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
pdsens.f File Reference
+
pdsens.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine pdsens (kens, kprob, xprob, kclust, kmembr, ilast, msga)
 Packs brib pds extension starting on byte 41 for ensemble forecast products.
 

Detailed Description

Packs grib pds extension 41- for ensemble.

@@ -107,8 +113,8 @@

Definition in file pdsens.f.

Function/Subroutine Documentation

- -

◆ pdsens()

+ +

◆ pdsens()

@@ -117,43 +123,43 @@

subroutine pdsens ( integer, dimension(5)  - KENS, + kens, integer, dimension(2)  - KPROB, + kprob, dimension(2)  - XPROB, + xprob, integer, dimension(16)  - KCLUST, + kclust, integer, dimension(80)  - KMEMBR, + kmembr,   - ILAST, + ilast, character*1, dimension(100)  - MSGA  + msga  @@ -183,7 +189,7 @@

Note
Use pdseup() for unpacking pds ensemble extension. subprogram can be called from a multiprocessing environment.
+
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
@@ -197,7 +203,7 @@

diff --git a/pdsens_8f.js b/pdsens_8f.js index ca22b5da..54d8c051 100644 --- a/pdsens_8f.js +++ b/pdsens_8f.js @@ -1,4 +1,4 @@ var pdsens_8f = [ - [ "pdsens", "pdsens_8f.html#ac0ab2fe3df3fc664f2c413214700206e", null ] + [ "pdsens", "pdsens_8f.html#ad99e2996ab77fc0da4f298babf729a41", null ] ]; \ No newline at end of file diff --git a/pdsens_8f_source.html b/pdsens_8f_source.html index a8d7c566..bba4ddd4 100644 --- a/pdsens_8f_source.html +++ b/pdsens_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: pdsens.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,92 +81,100 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
pdsens.f
+
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
-
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
-
sbytec
subroutine sbytec(OUT, IN, ISKIP, NBYTE)
This is a wrapper for sbytesc()
Definition: sbytec.f:14
-
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
-
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Packs grib pds extension 41- for ensemble.
+
3C> @author Zoltan Toth & Mark Iredell @date 1995-03-14
+
4
+
5C> Packs brib pds extension starting on byte 41 for ensemble
+
6c> forecast products. For format of pds extension, see nmc office note 38.
+
7C>
+
8C> Program history log:
+
9C> - Zoltan Toth and Mark Iredell 1995-03-14
+
10C> - Mark Iredell 1995-10-31 Removed saves and prints.
+
11C> - Richard Wobus 1998-09-28 Corrected member entry, blank all unused fields.
+
12C> - Mark Iredell 2001-06-05 Apply linux port by Ebisuzaki.
+
13C>
+
14C> @param[in] KENS (5) Bytes 41-45 (general section, always present.)
+
15C> @param[in] KPROB (2) Bytes 46-47 (probability section, present only if needed).
+
16C> @param[in] XPROB (2) Bytes 48-51&52-55 (probability section, if needed.).
+
17C> @param[in] KCLUST (16) Bytes 61-76 (clustering section, if needed.).
+
18C> @param[in] KMEMBR (80) Bytes 77-86 (cluster membership section, if needed.).
+
19C> @param[in] ILAST Last byte to be packed (if greater or equal to first byte
+
20C> in any of four sections above, whole section is packed).
+
21C> @param[out] MSGA - Full pds section, including new ensemble extension.
+
22C>
+
23C> @note Use pdseup() for unpacking pds ensemble extension.
+
24c> subprogram can be called from a multiprocessing environment.
+
25C>
+
26C> @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
+
34C 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
+
42C CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS)
+
43 CALL sbytec(msga, il, 0,24)
+
44C PACKING FIRST SECTION (GENERAL INTORMATION SECTION)
+
45 IF(il.GE.45) CALL sbytesc(msga,kens,40*8,8,0,5)
+
46C 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
+
57C PACKING 3RD SECTION (CLUSTERING INFORMATION)
+
58 IF(il.GE.76) CALL sbytesc(msga,kclust,60*8,8,0,16)
+
59C PACKING 4TH SECTION (CLUSTER MEMBERSHIP)
+
60 IF(il.GE.86) CALL sbytesc(msga,kmembr,76*8,1,0,80)
+
61C
+
62 333 CONTINUE
+
63 RETURN
+
+
64 END
+
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
+
sbytec
subroutine sbytec(out, in, iskip, nbyte)
This is a wrapper for sbytesc()
Definition sbytec.f:14
+
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
+
w3fi01
subroutine w3fi01(lw)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition w3fi01.f:19
+
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/pdseup_8f.html b/pdseup_8f.html index e22df553..76c51243 100644 --- a/pdseup_8f.html +++ b/pdseup_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: pdseup.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
pdseup.f File Reference
+
pdseup.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine pdseup (kens, kprob, xprob, kclust, kmembr, ilast, msga)
 Unpacks grib pds extension starting on byte 41 for ensemble forecast products.
 

Detailed Description

Unpacks grib pds extension 41- for ensemble.

@@ -107,8 +113,8 @@

Definition in file pdseup.f.

Function/Subroutine Documentation

- -

◆ pdseup()

+ +

◆ pdseup()

@@ -117,43 +123,43 @@

subroutine pdseup ( integer, dimension(5)  - KENS, + kens, integer, dimension(2)  - KPROB, + kprob, dimension(2)  - XPROB, + xprob, integer, dimension(16)  - KCLUST, + kclust, integer, dimension(80)  - KMEMBR, + kmembr,   - ILAST, + ilast, character*1, dimension(100)  - MSGA  + msga  @@ -183,7 +189,7 @@

Note
Use pdsens() for packing pds ensemble extension. Subprogram can be called from a multiprocessing environment.
+
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
@@ -197,7 +203,7 @@

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

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...
 
subroutine putgb (lugb, kf, kpds, kgds, lb, f, iret)
 This subprogram is nearly the inverse of getgb.
 

Detailed Description

Packs and writes a grib message.

@@ -108,8 +114,8 @@

Definition in file putgb.f.

Function/Subroutine Documentation

- -

◆ putgb()

+ +

◆ putgb()

@@ -118,43 +124,43 @@

subroutine putgb (   - LUGB, + lugb,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, logical*1, dimension(kf)  - LB, + lb, real, dimension(kf)  - F, + f,   - IRET  + iret  @@ -320,7 +326,7 @@

diff --git a/putgb_8f.js b/putgb_8f.js index df38426d..b5a3a655 100644 --- a/putgb_8f.js +++ b/putgb_8f.js @@ -1,4 +1,4 @@ var putgb_8f = [ - [ "putgb", "putgb_8f.html#aa61b5b2b00eb09531ef126983ad1d724", null ] + [ "putgb", "putgb_8f.html#ab6da73b9f8ae839b451816f9916c231a", null ] ]; \ No newline at end of file diff --git a/putgb_8f_source.html b/putgb_8f_source.html index 35e089a9..3eac52d3 100644 --- a/putgb_8f_source.html +++ b/putgb_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgb.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,206 +81,215 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
putgb.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Packs and writes a grib message.
+
3C> @author Mark Iredell @author 1994-04-01
+
4
+
5C> This subprogram is nearly the inverse of getgb.
+
6C>
+
7C> Program history log:
+
8C> - Mark Iredell 1994-04-01
+
9C> - Mark Iredell 1995-10-31 Removed saves and prints.
+
10C> - George Gayno 2009-10-15 Increased maxbit from 16 to 32.
+
11C>
+
12C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
13C> @param[in] KF Integer number of data points.
+
14C> @param[in] KPDS Integer (200) pds parameters.
+
15C> - 1: id of center.
+
16C> - 2: generating process id number.
+
17C> - 3: grid definition.
+
18C> - 4: gds/bms flag (right adj copy of octet 8).
+
19C> - 5: indicator of parameter.
+
20C> - 6: type of level.
+
21C> - 7: height/pressure , etc of level.
+
22C> - 8: year including (century-1).
+
23C> - 9: month of year.
+
24C> - 10: day of month.
+
25C> - 11: hour of day.
+
26C> - 12: minute of hour.
+
27C> - 13: indicator of forecast time unit.
+
28C> - 14: time range 1.
+
29C> - 15: time range 2.
+
30C> - 16: time range flag.
+
31C> - 17: number included in average.
+
32C> - 18: version nr of grib specification.
+
33C> - 19: version nr of parameter table.
+
34C> - 20: nr missing from average/accumulation.
+
35C> - 21: century of reference time of data.
+
36C> - 22: units decimal scale factor.
+
37C> - 23: subcenter number.
+
38C> - 24: pds byte 29, for nmc ensemble products.
+
39C> - 128 if forecast field error.
+
40C> - 64 if bias corrected fcst field.
+
41C> - 32 if smoothed field.
+
42C> - warning: can be combination of more than 1.
+
43C> - 25: pds byte 30, not used.
+
44C> @param[in] kgds Integer (200) gds parameters
+
45C> - 1: data representation type.
+
46C> - 19: number of vertical coordinate parameters.
+
47C> - 20: octet number of the list of vertical coordinate parameters or
+
48C> octet number of the list of numbers of points in each row or
+
49C> 255 if neither are present.
+
50C> - 21: for grids with pl, number of points in grid.
+
51C> - 22: number of words in each row.
+
52C>
+
53C> - Latitude/longitude grids.
+
54C> - 2: n(i) nr points on latitude circle.
+
55C> - 3: n(j) nr points on longitude meridian.
+
56C> - 4: la(1) latitude of origin.
+
57C> - 5: lo(1) longitude of origin.
+
58C> - 6: resolution flag (right adj copy of octet 17).
+
59C> - 7: la(2) latitude of extreme point.
+
60C> - 8: lo(2) longitude of extreme point.
+
61C> - 9: di longitudinal direction of increment.
+
62C> - 10: dj latitudinal direction increment.
+
63C> - 11: scanning mode flag (right adj copy of octet 28).
+
64C> - Gaussian grids.
+
65C> - 2: n(i) nr points on latitude circle.
+
66C> - 3: n(j) nr points on longitude meridian.
+
67C> - 4: la(1) latitude of origin.
+
68C> - 5: lo(1) longitude of origin.
+
69C> - 6: resolution flag (right adj copy of octet 17).
+
70C> - 7: la(2) latitude of extreme point.
+
71C> - 8: lo(2) longitude of extreme point.
+
72C> - 9: di longitudinal direction of increment.
+
73C> - 10: n - nr of circles pole to equator.
+
74C> - 11: scanning mode flag (right adj copy of octet 28).
+
75C> - 12: nv - nr of vert coord parameters.
+
76C> - 13: pv - octet nr of list of vert coord parameters or
+
77C> pl - location of the list of numbers of points in each row
+
78C> (if no vert coord parameters are present) or 255 if neither are present.
+
79C> - Polar stereographic grids.
+
80C> - 2: n(i) nr points along lat circle.
+
81C> - 3: n(j) nr points along lon circle.
+
82C> - 4: la(1) latitude of origin.
+
83C> - 5: lo(1) longitude of origin.
+
84C> - 6: resolution flag (right adj copy of octet 17).
+
85C> - 7: lov grid orientation.
+
86C> - 8: dx - x direction increment.
+
87C> - 9: dy - y direction increment.
+
88C> - 10: projection center flag.
+
89C> - 11: scanning mode (right adj copy of octet 28).
+
90C> - Spherical harmonic coefficients.
+
91C> - 2: j pentagonal resolution parameter.
+
92C> - 3: k pentagonal resolution parameter.
+
93C> - 4: m pentagonal resolution parameter.
+
94C> - 5: representation type.
+
95C> - 6: coefficient storage mode.
+
96C> - Mercator grids.
+
97C> - 2: n(i) nr points on latitude circle.
+
98C> - 3: n(j) nr points on longitude meridian.
+
99C> - 4: la(1) latitude of origin.
+
100C> - 5: lo(1) longitude of origin.
+
101C> - 6: resolution flag (right adj copy of octet 17).
+
102C> - 7: la(2) latitude of last grid point.
+
103C> - 8: lo(2) longitude of last grid point.
+
104C> - 9: latit - latitude of projection intersection.
+
105C> - 10: reserved.
+
106C> - 11: scanning mode flag (right adj copy of octet 28).
+
107C> - 12: longitudinal dir grid length.
+
108C> - 13: latitudinal dir grid length.
+
109C> - Lambert conformal grids.
+
110C> - 2: nx nr points along x-axis.
+
111C> - 3: ny nr points along y-axis.
+
112C> - 4: la1 lat of origin (lower left).
+
113C> - 5: lo1 lon of origin (lower left).
+
114C> - 6: resolution (right adj copy of octet 17).
+
115C> - 7: lov - orientation of grid.
+
116C> - 8: dx - x-dir increment.
+
117C> - 9: dy - y-dir increment.
+
118C> - 10: projection center flag.
+
119C> - 11: scanning mode flag (right adj copy of octet 28).
+
120C> - 12: latin 1 - first lat from pole of secant cone inter.
+
121C> - 13: latin 2 - second lat from pole of secant cone inter.
+
122C>
+
123C> @param[in] lb logical*1 (kf) bitmap if present
+
124C> @param[in] f real (kf) data
+
125C> @param[out] iret integer return code.
+
126C> - 0 all ok.
+
127C> - other w3fi72 grib packer return code.
+
128C>
+
129C> @note Subprogram can be called from a multiprocessing environment.
+
130C> Do not engage the same logical unit from more than one processor.
+
131C>
+
132C> @author Mark Iredell @author 1994-04-01
+
133C-----------------------------------------------------------------------
+
+
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)
+
142C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
143C GET W3FI72 PARAMETERS
+
144 CALL r63w72(kpds,kgds,ipds,igds)
+
145 ibds=0
+
146C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
147C 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
+
161C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
162C 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
+
172C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
173C 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)
+
178C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
179 RETURN
+
+
180 END
+
getbit
subroutine getbit(ibm, ibs, ids, len, mg, g, ground, gmin, gmax, nbit)
The number of bits required to pack a given field.
Definition getbit.f:33
+
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/putgbe_8f.html b/putgbe_8f.html index 605b3854..56392a71 100644 --- a/putgbe_8f.html +++ b/putgbe_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgbe.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
putgbe.f File Reference
+
putgbe.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine putgbe (lugb, kf, kpds, kgds, kens, lb, f, iret)
 This subprogram is nearly the inverse of getgbe.
 

Detailed Description

Packs and writes a grib message.

@@ -107,8 +113,8 @@

Definition in file putgbe.f.

Function/Subroutine Documentation

- -

◆ putgbe()

+ +

◆ putgbe()

@@ -117,49 +123,49 @@

subroutine putgbe (   - LUGB, + lugb,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(kf)  - LB, + lb, real, dimension(kf)  - F, + f,   - IRET  + iret  @@ -169,7 +175,7 @@

-

THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.

+

This subprogram is nearly the inverse of getgbe.

Program history log:

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

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...
 
subroutine putgben (lugb, kf, kpds, kgds, kens, ibs, nbits, lb, f, iret)
 This subprogram is nearly the inverse of getgbe.
 

Detailed Description

Packs and writes a grib message.

@@ -107,8 +113,8 @@

Definition in file putgben.f.

Function/Subroutine Documentation

- -

◆ putgben()

+ +

◆ putgben()

@@ -117,61 +123,61 @@

subroutine putgben (   - LUGB, + lugb,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens,   - IBS, + ibs,   - NBITS, + nbits, logical*1, dimension(kf)  - LB, + lb, real, dimension(kf)  - F, + f,   - IRET  + iret  @@ -181,7 +187,7 @@

-

THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.

+

This subprogram is nearly the inverse of getgbe.

Program history log:

diff --git a/putgben_8f.js b/putgben_8f.js index 43a1584d..9a25c457 100644 --- a/putgben_8f.js +++ b/putgben_8f.js @@ -1,4 +1,4 @@ var putgben_8f = [ - [ "putgben", "putgben_8f.html#a094e5a410a4e995f25665a750ac2bc8c", null ] + [ "putgben", "putgben_8f.html#a74d7f0a61a5f7937731d2b632555c69f", null ] ]; \ No newline at end of file diff --git a/putgben_8f_source.html b/putgben_8f_source.html index 4ad930c9..c2a2e988 100644 --- a/putgben_8f_source.html +++ b/putgben_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgben.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,229 +81,238 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
putgben.f
+
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
-
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
-
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
-
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
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Packs and writes a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> This subprogram is nearly the inverse of getgbe.
+
6C>
+
7C> Program history log:
+
8C> - Mark Iredell 1994-04-01
+
9C> - Mark Iredell 1995-10-31 Removed saves and prints.
+
10C> - Mark Iredell 2001-03-16 Corrected argument list to include ibs.
+
11C>
+
12C> @param[in] lugb Integer unit of the unblocked grib data file.
+
13C> @param[in] kf Integer number of data points.
+
14C> @param[in] kpds Integer (200) pds parameters.
+
15C> - 1): id of center.
+
16C> - 2): generating process id number.
+
17C> - 3): grid definition.
+
18C> - 4): gds/bms flag (right adj copy of octet 8).
+
19C> - 5): indicator of parameter.
+
20C> - 6): type of level.
+
21C> - 7): height/pressure , etc of level.
+
22C> - 8): year including (century-1).
+
23C> - 9): month of year.
+
24C> - 10: day of month.
+
25C> - 11: hour of day.
+
26C> - 12: minute of hour.
+
27C> - 13: indicator of forecast time unit.
+
28C> - 14: time range 1.
+
29C> - 15: time range 2.
+
30C> - 16: time range flag.
+
31C> - 17: number included in average.
+
32C> - 18: version nr of grib specification.
+
33C> - 19: version nr of parameter table.
+
34C> - 20: nr missing from average/accumulation.
+
35C> - 21: century of reference time of data.
+
36C> - 22: units decimal scale factor.
+
37C> - 23: subcenter number.
+
38C> - 24: pds byte 29, for nmc ensemble products.
+
39C> - 128 if forecast field error.
+
40C> - 64 if bias corrected fcst field.
+
41C> - 32 if smoothed field.
+
42C> - warning: can be combination of more than 1.
+
43C> - 25: pds byte 30, not used.
+
44C> @param[in] kgds Integer (200) gds parameters.
+
45C> - 1): data representation type.
+
46C> - 19: number of vertical coordinate parameters.
+
47C> - 20: octet number of the list of vertical coordinate parameters or
+
48C> octet number of the list of numbers of points in each row or
+
49C> 255 if neither are present.
+
50C> - 21: for grids with pl, number of points in grid.
+
51C> - 22: number of words in each row.
+
52C> - Latitude/longitude grids.
+
53C> - 2): n(i) nr points on latitude circle.
+
54C> - 3): n(j) nr points on longitude meridian.
+
55C> - 4): la(1) latitude of origin.
+
56C> - 5): lo(1) longitude of origin.
+
57C> - 6): resolution flag (right adj copy of octet 17).
+
58C> - 7): la(2) latitude of extreme point.
+
59C> - 8): lo(2) longitude of extreme point.
+
60C> - 9): di longitudinal direction of increment.
+
61C> - 10: dj latitudinal direction increment.
+
62C> - 11: scanning mode flag (right adj copy of octet 28).
+
63C> - Gaussian grids.
+
64C> - 2): n(i) nr points on latitude circle.
+
65C> - 3): n(j) nr points on longitude meridian.
+
66C> - 4): la(1) latitude of origin.
+
67C> - 5): lo(1) longitude of origin.
+
68C> - 6): resolution flag (right adj copy of octet 17).
+
69C> - 7): la(2) latitude of extreme point.
+
70C> - 8): lo(2) longitude of extreme point.
+
71C> - 9): di longitudinal direction of increment.
+
72C> - 10: n - nr of circles pole to equator.
+
73C> - 11: scanning mode flag (right adj copy of octet 28).
+
74C> - 12: nv - nr of vert coord parameters.
+
75C> - 13: pv - octet nr of list of vert coord parameters or.
+
76C> pl - location of the list of numbers of points in
+
77C> each row (if no vert coord parameters are present) or
+
78C> 255 if neither are present
+
79C> - Polar stereographic grids.
+
80C> - 2): n(i) nr points along lat circle.
+
81C> - 3): n(j) nr points along lon circle.
+
82C> - 4): la(1) latitude of origin.
+
83C> - 5): lo(1) longitude of origin.
+
84C> - 6): resolution flag (right adj copy of octet 17).
+
85C> - 7): lov grid orientation.
+
86C> - 8): dx - x direction increment.
+
87C> - 9): dy - y direction increment.
+
88C> - 10: projection center flag.
+
89C> - 11: scanning mode (right adj copy of octet 28).
+
90C> - Spherical harmonic coefficients.
+
91C> - 2): j pentagonal resolution parameter.
+
92C> - 3): k pentagonal resolution parameter.
+
93C> - 4): m pentagonal resolution parameter.
+
94C> - 5): representation type.
+
95C> - 6): coefficient storage mode.
+
96C> - Mercator grids.
+
97C> - 2): n(i) nr points on latitude circle.
+
98C> - 3): n(j) nr points on longitude meridian.
+
99C> - 4): la(1) latitude of origin.
+
100C> - 5): lo(1) longitude of origin.
+
101C> - 6): resolution flag (right adj copy of octet 17).
+
102C> - 7): la(2) latitude of last grid point.
+
103C> - 8): lo(2) longitude of last grid point.
+
104C> - 9): latit - latitude of projection intersection.
+
105C> - 10: reserved.
+
106C> - 11: scanning mode flag (right adj copy of octet 28).
+
107C> - 12: longitudinal dir grid length.
+
108C> - 13: latitudinal dir grid length.
+
109C> - Lambert conformal grids.
+
110C> - 2): nx nr points along x-axis.
+
111C> - 3): ny nr points along y-axis.
+
112C> - 4): la1 lat of origin (lower left).
+
113C> - 5): lo1 lon of origin (lower left).
+
114C> - 6): resolution (right adj copy of octet 17).
+
115C> - 7): lov - orientation of grid.
+
116C> - 8): dx - x-dir increment.
+
117C> - 9): dy - y-dir increment.
+
118C> - 10: projection center flag.
+
119C> - 11: scanning mode flag (right adj copy of octet 28).
+
120C> - 12: latin 1 - first lat from pole of secant cone inter.
+
121C> - 13: latin 2 - second lat from pole of secant cone inter.
+
122C> @param[in] kens Integer (200) ensemble pds parms.
+
123C> - 1): application identifier.
+
124C> - 2): ensemble type.
+
125C> - 3): ensemble identifier.
+
126C> - 4): product identifier.
+
127C> - 5): smoothing flag.
+
128C> @param[in] ibs integer binary scale factor (0 to ignore).
+
129C> @param[in] nbits integer number of bits in which to pack (0 to ignore).
+
130C> @param[in] lb logical*1 (kf) bitmap if present.
+
131C> @param[in] f real (kf) data.
+
132C> @param[out] iret integer return code.
+
133C> - all ok.
+
134C> - other w3fi72 grib packer return code.
+
135C>
+
136C> @note Subprogram can be called from a multiprocessing environment.
+
137C> Do not engage the same logical unit from more than one processor.
+
138C>
+
139C> @author Mark Iredell @date 1994-04-01
+
140C-----------------------------------------------------------------------
+
+
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)
+
149C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
150C GET W3FI72 PARAMETERS
+
151 CALL r63w72(kpds,kgds,ipds,igds)
+
152 ibds=0
+
153C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
154C 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
+
168C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
169C 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
+
186C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
187C 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
+
193C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
194C 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)
+
199C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
200 RETURN
+
+
201 END
+
getbit
subroutine getbit(ibm, ibs, ids, len, mg, g, ground, gmin, gmax, nbit)
The number of bits required to pack a given field.
Definition getbit.f:33
+
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
+
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
+
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
+
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/putgbens_8f.html b/putgbens_8f.html index 048b6f92..84605193 100644 --- a/putgbens_8f.html +++ b/putgbens_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgbens.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
putgbens.f File Reference
+
putgbens.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine putgbens (lugb, kf, kpds, kgds, kens, lb, f, iret)
 This subprogram is nearly the inverse of getgbens.
 

Detailed Description

Packs and writes a grib message.

@@ -107,8 +113,8 @@

Definition in file putgbens.f.

Function/Subroutine Documentation

- -

◆ putgbens()

+ +

◆ putgbens()

@@ -117,49 +123,49 @@

subroutine putgbens (   - LUGB, + lugb,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, logical*1, dimension(kf)  - LB, + lb, real, dimension(kf)  - F, + f,   - IRET  + iret  @@ -330,7 +336,7 @@

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

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...
 
subroutine putgbex (lugb, kf, kpds, kgds, kens, kprob, xprob, kclust, kmembr, lb, f, iret)
 This subprogram is nearly the inverse of getgbe.
 

Detailed Description

Packs and writes a grib message.

@@ -107,8 +113,8 @@

Definition in file putgbex.f.

Function/Subroutine Documentation

- -

◆ putgbex()

+ +

◆ putgbex()

@@ -117,73 +123,73 @@

subroutine putgbex (   - LUGB, + lugb,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds, integer, dimension(200)  - KENS, + kens, integer, dimension(2)  - KPROB, + kprob, real, dimension(2)  - XPROB, + xprob, integer, dimension(16)  - KCLUST, + kclust, integer, dimension(80)  - KMEMBR, + kmembr, logical*1, dimension(kf)  - LB, + lb, real, dimension(kf)  - F, + f,   - IRET  + iret  @@ -360,7 +366,7 @@

diff --git a/putgbex_8f.js b/putgbex_8f.js index cd6af2c5..d207fbbc 100644 --- a/putgbex_8f.js +++ b/putgbex_8f.js @@ -1,4 +1,4 @@ var putgbex_8f = [ - [ "putgbex", "putgbex_8f.html#a64977c953757490ae3b8b72a5fd7c4cb", null ] + [ "putgbex", "putgbex_8f.html#a4d66cc2839c13fd35ae337aa79616ce6", null ] ]; \ No newline at end of file diff --git a/putgbex_8f_source.html b/putgbex_8f_source.html index c844c40d..eba02c7e 100644 --- a/putgbex_8f_source.html +++ b/putgbex_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgbex.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,227 +81,236 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
putgbex.f
+
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
-
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
-
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
-
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
-
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
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Packs and writes a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> This subprogram is nearly the inverse of getgbe.
+
6C>
+
7C> Program history log:
+
8C> - Mark Iredell 1994-04-01
+
9C> - Mark Iredell 1995-10-31 Removed saves and prints.
+
10C> - Y. Zhu 1997-02-11 Included probability and cluster arguments.
+
11C>
+
12C> @param[in] lugb integer unit of the unblocked grib data file.
+
13C> @param[in] kf integer number of data points.
+
14C> @param[in] kpds integer (200) pds parameters.
+
15C> - 1): id of center.
+
16C> - 2): generating process id number.
+
17C> - 3): grid definition.
+
18C> - 4): gds/bms flag (right adj copy of octet 8).
+
19C> - 5): indicator of parameter.
+
20C> - 6): type of level.
+
21C> - 7): height/pressure , etc of level.
+
22C> - 8): year including (century-1).
+
23C> - 9): month of year.
+
24C> - 10: day of month.
+
25C> - 11: hour of day.
+
26C> - 12: minute of hour.
+
27C> - 13: indicator of forecast time unit.
+
28C> - 14: time range 1.
+
29C> - 15: time range 2.
+
30C> - 16: time range flag.
+
31C> - 17: number included in average.
+
32C> - 18: version nr of grib specification.
+
33C> - 19: version nr of parameter table.
+
34C> - 20: nr missing from average/accumulation.
+
35C> - 21: century of reference time of data.
+
36C> - 22: units decimal scale factor.
+
37C> - 23: subcenter number.
+
38C> - 24: pds byte 29, for nmc ensemble products.
+
39C> - 128 if forecast field error.
+
40C> - 64 if bias corrected fcst field.
+
41C> - 32 if smoothed field.
+
42C> - warning: can be combination of more than 1.
+
43C> - 25: pds byte 30, not used.
+
44C> @param[in] kgds Integer (200) gds parameters.
+
45C> - 1): data representation type.
+
46C> - 19: number of vertical coordinate parameters.
+
47C> - 20: octet number of the list of vertical coordinate parameters or
+
48C> octet number of the list of numbers of points in each row or
+
49C> 255 if neither are present.
+
50C> - 21: for grids with pl, number of points in grid.
+
51C> - 22: number of words in each row.
+
52C> - Latitude/longitude grids.
+
53C> - 2): n(i) nr points on latitude circle.
+
54C> - 3): n(j) nr points on longitude meridian.
+
55C> - 4): la(1) latitude of origin.
+
56C> - 5): lo(1) longitude of origin.
+
57C> - 6): resolution flag (right adj copy of octet 17).
+
58C> - 7): la(2) latitude of extreme point.
+
59C> - 8): lo(2) longitude of extreme point.
+
60C> - 9): di longitudinal direction of increment.
+
61C> - 10: dj latitudinal direction increment.
+
62C> - 11: scanning mode flag (right adj copy of octet 28).
+
63C> - Gaussian grids.
+
64C> - 2): n(i) nr points on latitude circle.
+
65C> - 3): n(j) nr points on longitude meridian.
+
66C> - 4): la(1) latitude of origin.
+
67C> - 5): lo(1) longitude of origin.
+
68C> - 6): resolution flag (right adj copy of octet 17).
+
69C> - 7): la(2) latitude of extreme point.
+
70C> - 8): lo(2) longitude of extreme point.
+
71C> - 9): di longitudinal direction of increment.
+
72C> - 10: n - nr of circles pole to equator.
+
73C> - 11: scanning mode flag (right adj copy of octet 28).
+
74C> - 12: nv - nr of vert coord parameters.
+
75C> - 13: pv - octet nr of list of vert coord parameters or
+
76C> pl - location of the list of numbers of points in
+
77C> each row (if no vert coord parameters are present or
+
78C> 255 if neither are present
+
79C> - Polar stereographic grids.
+
80C> - 2): n(i) nr points along lat circle.
+
81C> - 3): n(j) nr points along lon circle.
+
82C> - 4): la(1) latitude of origin.
+
83C> - 5): lo(1) longitude of origin.
+
84C> - 6): resolution flag (right adj copy of octet 17).
+
85C> - 7): lov grid orientation.
+
86C> - 8): dx - x direction increment.
+
87C> - 9): dy - y direction increment.
+
88C> - 10: projection center flag.
+
89C> - 11: scanning mode (right adj copy of octet 28).
+
90C> - Spherical harmonic coefficients.
+
91C> - 2): j pentagonal resolution parameter.
+
92C> - 3): k pentagonal resolution parameter.
+
93C> - 4): m pentagonal resolution parameter.
+
94C> - 5): representation type.
+
95C> - 6): coefficient storage mode.
+
96C> - Mercator grids.
+
97C> - 2): n(i) nr points on latitude circle.
+
98C> - 3): n(j) nr points on longitude meridian.
+
99C> - 4): la(1) latitude of origin.
+
100C> - 5): lo(1) longitude of origin.
+
101C> - 6): resolution flag (right adj copy of octet 17).
+
102C> - 7): la(2) latitude of last grid point.
+
103C> - 8): lo(2) longitude of last grid point.
+
104C> - 9): latit - latitude of projection intersection.
+
105C> - 10: reserved.
+
106C> - 11: scanning mode flag (right adj copy of octet 28).
+
107C> - 12: longitudinal dir grid length.
+
108C> - 13: latitudinal dir grid length.
+
109C> - Lambert conformal grids.
+
110C> - 2): nx nr points along x-axis.
+
111C> - 3): ny nr points along y-axis.
+
112C> - 4): la1 lat of origin (lower left).
+
113C> - 5): lo1 lon of origin (lower left).
+
114C> - 6): resolution (right adj copy of octet 17).
+
115C> - 7): lov - orientation of grid.
+
116C> - 8): dx - x-dir increment.
+
117C> - 9): dy - y-dir increment.
+
118C> - 10: projection center flag.
+
119C> - 11: scanning mode flag (right adj copy of octet 28).
+
120C> - 12: latin 1 - first lat from pole of secant cone inter.
+
121C> - 13: latin 2 - second lat from pole of secant cone inter.
+
122C> @param[in] kens integer (200) ensemble pds parms.
+
123C> - 1): application identifier.
+
124C> - 2): ensemble type.
+
125C> - 3): ensemble identifier.
+
126C> - 4): product identifier.
+
127C> - 5): smoothing flag.
+
128C> @param[in] kprob integer (2) probability ensemble parms.
+
129C> @param[in] xprob real (2) probability ensemble parms.
+
130C> @param[in] kclust integer (16) cluster ensemble parms.
+
131C> @param[in] kmembr integer (8) cluster ensemble parms.
+
132C> @param[in] lb logical*1 (kf) bitmap if present.
+
133C> @param[in] f real (kf) data.
+
134C> @param[out] iret integer return code.
+
135C> - 0 all ok.
+
136C> - other w3fi72 grib packer return code.
+
137C>
+
138C> @note Subprogram can be called from a multiprocessing environment.
+
139C> Do not engage the same logical unit from more than one processor.
+
140C>
+
141C> @author Mark Iredell @date 1994-04-01
+
142C-----------------------------------------------------------------------
+
+
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)
+
154C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
155C GET W3FI72 PARAMETERS
+
156 CALL r63w72(kpds,kgds,ipds,igds)
+
157 ibds=0
+
158C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
159C 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
+
173C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
174C 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
+
184C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
185C 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
+
191C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
192C 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)
+
197C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
198 RETURN
+
+
199 END
+
getbit
subroutine getbit(ibm, ibs, ids, len, mg, g, ground, gmin, gmax, nbit)
The number of bits required to pack a given field.
Definition getbit.f:33
+
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
+
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
+
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
+
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
+
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/putgbn_8f.html b/putgbn_8f.html index 1cb51425..4d789289 100644 --- a/putgbn_8f.html +++ b/putgbn_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgbn.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
putgbn.f File Reference
+
putgbn.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine putgbn (lugb, kf, kpds, kgds, ibs, nbits, lb, f, iret)
 This subprogram is nearly the inverse of getgb.
 

Detailed Description

Packs and writes a grib message.

@@ -107,8 +113,8 @@

Definition in file putgbn.f.

Function/Subroutine Documentation

- -

◆ putgbn()

+ +

◆ putgbn()

@@ -117,55 +123,55 @@

subroutine putgbn (   - LUGB, + lugb,   - KF, + kf, integer, dimension(200)  - KPDS, + kpds, integer, dimension(200)  - KGDS, + kgds,   - IBS, + ibs,   - NBITS, + nbits, logical*1, dimension(kf)  - LB, + lb, real, dimension(kf)  - F, + f,   - IRET  + iret  @@ -331,7 +337,7 @@

diff --git a/putgbn_8f.js b/putgbn_8f.js index db45184a..fbee9065 100644 --- a/putgbn_8f.js +++ b/putgbn_8f.js @@ -1,4 +1,4 @@ var putgbn_8f = [ - [ "putgbn", "putgbn_8f.html#ad639ec06d322cda9f568c75b98aacc67", null ] + [ "putgbn", "putgbn_8f.html#aec976c38f8bad78272ad997b4313a0cb", null ] ]; \ No newline at end of file diff --git a/putgbn_8f_source.html b/putgbn_8f_source.html index 496a2c65..50f0cdde 100644 --- a/putgbn_8f_source.html +++ b/putgbn_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: putgbn.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,213 +81,222 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
putgbn.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Packs and writes a grib message.
+
3C> @author Mark Iredell @date 1994-04-01
+
4
+
5C> This subprogram is nearly the inverse of getgb.
+
6C>
+
7C> Program history log:
+
8C> - Mark Iredell 1994-04-01
+
9C> - Mark Iredell 1995-10-31 Removed saves and prints.
+
10C>
+
11C> @param[in] lugb integer unit of the unblocked grib data file.
+
12C> @param[in] kf integer number of data points.
+
13C> @param[in] kpds integer (200) pds parameters.
+
14C> - 1): id of center.
+
15C> - 2): generating process id number.
+
16C> - 3): grid definition.
+
17C> - 4): gds/bms flag (right adj copy of octet 8).
+
18C> - 5): indicator of parameter.
+
19C> - 6): type of level.
+
20C> - 7): height/pressure , etc of level.
+
21C> - 8): year including (century-1).
+
22C> - 9): month of year.
+
23C> - 10: day of month.
+
24C> - 11: hour of day.
+
25C> - 12: minute of hour.
+
26C> - 13: indicator of forecast time unit.
+
27C> - 14: time range 1.
+
28C> - 15: time range 2.
+
29C> - 16: time range flag.
+
30C> - 17: number included in average.
+
31C> - 18: version nr of grib specification.
+
32C> - 19: version nr of parameter table.
+
33C> - 20: nr missing from average/accumulation.
+
34C> - 21: century of reference time of data.
+
35C> - 22: units decimal scale factor.
+
36C> - 23: subcenter number.
+
37C> - 24: pds byte 29, for nmc ensemble products.
+
38C> - 128 if forecast field error.
+
39C> - 64 if bias corrected fcst field.
+
40C> - 32 if smoothed field.
+
41C> - warning: can be combination of more than 1.
+
42C> - 25: pds byte 30, not used.
+
43C> @param[in] kgds integer (200) gds parameters.
+
44C> - 1): data representation type.
+
45C> - 19: number of vertical coordinate parameters.
+
46C> - 20: octet number of the list of vertical coordinate parameters or
+
47C> octet number of the list of numbers of points in each row or
+
48C> 255 if neither are present.
+
49C> - 21: for grids with pl, number of points in grid.
+
50C> - 22: number of words in each row.
+
51C> - Latitude/longitude grids.
+
52C> - 2): n(i) nr points on latitude circle.
+
53C> - 3): n(j) nr points on longitude meridian.
+
54C> - 4): la(1) latitude of origin.
+
55C> - 5): lo(1) longitude of origin.
+
56C> - 6): resolution flag (right adj copy of octet 17).
+
57C> - 7): la(2) latitude of extreme point.
+
58C> - 8): lo(2) longitude of extreme point.
+
59C> - 9): di longitudinal direction of increment.
+
60C> - 10: dj latitudinal direction increment.
+
61C> - 11: scanning mode flag (right adj copy of octet 28).
+
62C> - Gaussian grids.
+
63C> - 2): n(i) nr points on latitude circle.
+
64C> - 3): n(j) nr points on longitude meridian.
+
65C> - 4): la(1) latitude of origin.
+
66C> - 5): lo(1) longitude of origin.
+
67C> - 6): resolution flag (right adj copy of octet 17).
+
68C> - 7): la(2) latitude of extreme point.
+
69C> - 8): lo(2) longitude of extreme point.
+
70C> - 9): di longitudinal direction of increment.
+
71C> - 10: n - nr of circles pole to equator.
+
72C> - 11: scanning mode flag (right adj copy of octet 28).
+
73C> - 12: nv - nr of vert coord parameters.
+
74C> - 13: pv - octet nr of list of vert coord parameters or
+
75C> pl - location of the list of numbers of points in
+
76C> each row (if no vert coord parameters are present) or
+
77C> 255 if neither are present.
+
78C> - Polar stereographic grids.
+
79C> - 2): n(i) nr points along lat circle.
+
80C> - 3): n(j) nr points along lon circle.
+
81C> - 4): la(1) latitude of origin.
+
82C> - 5): lo(1) longitude of origin.
+
83C> - 6): resolution flag (right adj copy of octet 17).
+
84C> - 7): lov grid orientation.
+
85C> - 8): dx - x direction increment.
+
86C> - 9): dy - y direction increment.
+
87C> - 10: projection center flag.
+
88C> - 11: scanning mode (right adj copy of octet 28).
+
89C> - Spherical harmonic coefficients.
+
90C> - 2): j pentagonal resolution parameter.
+
91C> - 3): k pentagonal resolution parameter.
+
92C> - 4): m pentagonal resolution parameter.
+
93C> - 5): representation type.
+
94C> - 6): coefficient storage mode.
+
95C> - Mercator grids.
+
96C> - 2): n(i) nr points on latitude circle.
+
97C> - 3): n(j) nr points on longitude meridian.
+
98C> - 4): la(1) latitude of origin.
+
99C> - 5): lo(1) longitude of origin.
+
100C> - 6): resolution flag (right adj copy of octet 17).
+
101C> - 7): la(2) latitude of last grid point.
+
102C> - 8): lo(2) longitude of last grid point.
+
103C> - 9): latit - latitude of projection intersection.
+
104C> - 10: reserved.
+
105C> - 11: scanning mode flag (right adj copy of octet 28).
+
106C> - 12: longitudinal dir grid length.
+
107C> - 13: latitudinal dir grid length.
+
108C> - Lambert conformal grids.
+
109C> - 2): nx nr points along x-axis.
+
110C> - 3): ny nr points along y-axis.
+
111C> - 4): la1 lat of origin (lower left).
+
112C> - 5): lo1 lon of origin (lower left).
+
113C> - 6): resolution (right adj copy of octet 17).
+
114C> - 7): lov - orientation of grid.
+
115C> - 8): dx - x-dir increment.
+
116C> - 9): dy - y-dir increment.
+
117C> - 10: projection center flag.
+
118C> - 11: scanning mode flag (right adj copy of octet 28).
+
119C> - 12: latin 1 - first lat from pole of secant cone inter.
+
120C> - 13: latin 2 - second lat from pole of secant cone inter.
+
121C> @param[in] ibs integer binary scale factor (0 to ignore).
+
122C> @param[in] nbits integer number of bits in which to pack (0 to ignore).
+
123C> @param[in] lb logical*1 (kf) bitmap if present.
+
124C> @param[in] f real (kf) data.
+
125C> @param[out] iret integer return code.
+
126C> - 0 all ok.
+
127C> - other w3fi72 grib packer return code.
+
128C>
+
129C> @note Subprogram can be called from a multiprocessing environment.
+
130C> Do not engage the same logical unit from more than one processor.
+
131C>
+
132C> @author Mark Iredell @date 1994-04-01
+
133C-----------------------------------------------------------------------
+
+
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)
+
142C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
143C GET W3FI72 PARAMETERS
+
144 CALL r63w72(kpds,kgds,ipds,igds)
+
145 ibds=0
+
146C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
147C 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
+
161C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
162C 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
+
179C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
180C 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)
+
185C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
186 RETURN
+
+
187 END
+
getbit
subroutine getbit(ibm, ibs, ids, len, mg, g, ground, gmin, gmax, nbit)
The number of bits required to pack a given field.
Definition getbit.f:33
+
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/q9ie32_8f.html b/q9ie32_8f.html index 984452d5..01108500 100644 --- a/q9ie32_8f.html +++ b/q9ie32_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: q9ie32.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
q9ie32.f File Reference
+
q9ie32.f File Reference
@@ -94,11 +100,11 @@

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...
 
subroutine q9ie32 (a, b, n, istat)
 Convert ibm370 32 bit floating point numbers to ieee 32 bit task 754 floating point numbers.
 

Detailed Description

Convert IBM370 F.P.

@@ -107,8 +113,8 @@

Definition in file q9ie32.f.

Function/Subroutine Documentation

- -

◆ q9ie32()

+ +

◆ q9ie32()

@@ -117,25 +123,25 @@

subroutine q9ie32 ( integer(4), dimension(*)  - A, + a, integer(4), dimension(*)  - B, + b,   - N, + n,   - ISTAT  + istat  @@ -177,7 +183,7 @@

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

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

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...
 
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().
 

Detailed Description

-

Convert w3fi63() parms to w3fi72() parms.

+

Convert w3fi63() parms to w3fi72() parms.

Author
Mark Iredell
Date
1992-10-31

Definition in file r63w72.f.

Function/Subroutine Documentation

- -

◆ r63w72()

+ +

◆ r63w72()

@@ -117,25 +123,25 @@

subroutine r63w72 ( dimension(200)  - KPDS, + kpds, dimension(200)  - KGDS, + kgds, dimension(200)  - IPDS, + ipds, dimension(200)  - IGDS  + igds  @@ -145,7 +151,7 @@

-

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

+

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:

diff --git a/r63w72_8f.js b/r63w72_8f.js index c5c92870..d1ced224 100644 --- a/r63w72_8f.js +++ b/r63w72_8f.js @@ -1,4 +1,4 @@ var r63w72_8f = [ - [ "r63w72", "r63w72_8f.html#a071601493ea893c59ed2b8fac3cf9116", null ] + [ "r63w72", "r63w72_8f.html#af3dacce6918418d047d622bbe287a228", null ] ]; \ No newline at end of file diff --git a/r63w72_8f_source.html b/r63w72_8f_source.html index 4dc3db82..d489eef4 100644 --- a/r63w72_8f_source.html +++ b/r63w72_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: r63w72.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,140 +81,148 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
r63w72.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Convert w3fi63() parms to w3fi72() parms.
+
3C> @author Mark Iredell @date 1992-10-31
+
4
+
5C> Determines the integer PDS and GDS parameters
+
6C> for the GRIB1 packing routine w3fi72() given the parameters
+
7C> returned from the GRIB1 unpacking routine w3fi63().
+
8C>
+
9C> Program history log:
+
10C> - Mark Iredell 1991-10-31
+
11C> - Mark Iredell 1996-05-03 Corrected some level types and
+
12C> some data representation types
+
13C> - Mark Iredell 1997-02-14 Only altered ipds(26:27) for extended pds
+
14C> - Chris Caruso 1998-06-01 Y2K fix for year of century
+
15C> - Diane Stoken 2005-05-06 Recognize level 236
+
16C>
+
17C> @note kgds and igds extend beyond their dimensions here
+
18C> if pl parameters are present.
+
19C>
+
20C> @param[in] kpds integer (200) PDS parameters from w3fi63().
+
21C> @param[in] kgds integer (200) GDS parameters from w3fi63().
+
22C> @param[out] ipds integer (200) PDS parameters for w3fi72().
+
23C> @param[out] igds integer (200) GDS parameters for w3fi72().
+
24C>
+
25C> @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
+
29C 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
+
72C 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)
+
91C 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)
+
95C 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)
+
101C 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
+
108C 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/resize.js b/resize.js index e1ad0fe3..aaeb6fc0 100644 --- a/resize.js +++ b/resize.js @@ -22,38 +22,45 @@ @licend The above is the entire license notice for the JavaScript code in this file */ +var once=1; function initResizable() { var cookie_namespace = 'doxygen'; - var sidenav,navtree,content,header,collapsed,collapsedWidth=0,barWidth=6,desktop_vp=768,titleHeight; + var sidenav,navtree,content,header,barWidth=6,desktop_vp=768,titleHeight; - function readCookie(cookie) + function readSetting(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; + if (window.chrome) { + var val = localStorage.getItem(cookie_namespace+'_width'); + if (val) return val; + } else { + 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; } - var val = document.cookie.substring(valStart, valEnd); - return val; } } - return 0; + return 250; } - function writeCookie(cookie, val, expiration) + function writeSetting(cookie, val) { - if (val==undefined) return; - if (expiration == null) { + if (window.chrome) { + localStorage.setItem(cookie_namespace+"_width",val); + } else { 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 + "; SameSite=Lax; expires=" + expiration+"; path=/"; } - document.cookie = cookie_namespace + "_" + cookie + "=" + val + "; expires=" + expiration+"; path=/"; } function resizeWidth() @@ -61,13 +68,19 @@ function initResizable() var windowWidth = $(window).width() + "px"; var sidenavWidth = $(sidenav).outerWidth(); content.css({marginLeft:parseInt(sidenavWidth)+"px"}); - writeCookie('width',sidenavWidth-barWidth, null); + if (typeof page_layout!=='undefined' && page_layout==1) { + footer.css({marginLeft:parseInt(sidenavWidth)+"px"}); + } + writeSetting('width',sidenavWidth-barWidth); } function restoreWidth(navWidth) { var windowWidth = $(window).width() + "px"; content.css({marginLeft:parseInt(navWidth)+barWidth+"px"}); + if (typeof page_layout!=='undefined' && page_layout==1) { + footer.css({marginLeft:parseInt(navWidth)+barWidth+"px"}); + } sidenav.css({width:navWidth + "px"}); } @@ -75,23 +88,20 @@ function initResizable() { 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; + newWidth=0; } else { - var width = readCookie('width'); - if (width>200 && width<$(window).width()) { restoreWidth(width); } else { restoreWidth(200); } - collapsed=false; + var width = readSetting('width'); + newWidth = (width>250 && width<$(window).width()) ? width : 250; } + restoreWidth(newWidth); + var sidenavWidth = $(sidenav).outerWidth(); + writeSetting('width',sidenavWidth-barWidth); } header = $("#top"); @@ -126,7 +138,7 @@ function initResizable() $('#nav-sync').css({ right:'34px' }); barWidth=20; } - var width = readCookie('width'); + var width = readSetting('width'); if (width) { restoreWidth(width); } else { resizeWidth(); } resizeHeight(); var url = location.href; @@ -134,7 +146,10 @@ function initResizable() 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); + if (once) { + $(".ui-resizable-handle").dblclick(collapseExpand); + once=0 + } $(window).on('load',resizeHeight); } /* @license-end */ diff --git a/sbyte_8f.html b/sbyte_8f.html index eef41cbf..6dcf6feb 100644 --- a/sbyte_8f.html +++ b/sbyte_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: sbyte.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,38 +76,44 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
sbyte.f File Reference
+
sbyte.f File Reference
-

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

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)
 
subroutine sbyte (iout, in, iskip, nbyte)
 

Detailed Description

-

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

+

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

Author
Robert Gammill
Date
1972-07

Definition in file sbyte.f.

Function/Subroutine Documentation

- -

◆ sbyte()

+ +

◆ sbyte()

@@ -116,25 +122,25 @@

subroutine sbyte ( integer, dimension(*)  - IOUT, + iout, integer  - IN, + in,   - ISKIP, + iskip,   - NBYTE  + nbyte  @@ -165,7 +171,7 @@

diff --git a/sbyte_8f.js b/sbyte_8f.js index 3e980f2a..358103fd 100644 --- a/sbyte_8f.js +++ b/sbyte_8f.js @@ -1,4 +1,4 @@ var sbyte_8f = [ - [ "sbyte", "sbyte_8f.html#afbbfa5a4daed1898e1235a221dcf54b2", null ] + [ "sbyte", "sbyte_8f.html#a74f0f88a79864061c3a4234075d39e1b", null ] ]; \ No newline at end of file diff --git a/sbyte_8f_source.html b/sbyte_8f_source.html index 3847a84b..702081cc 100644 --- a/sbyte_8f_source.html +++ b/sbyte_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: sbyte.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,102 +81,110 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
sbyte.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief This is the fortran 32 bit version of sbyte().
+
3C> @author Robert Gammill @date 1972-07
+
4
+
5C> @param[out] IOUT
+
6C> @param[in] IN Unpacked array input
+
7C> @param[in] ISKIP Initial number of bits to skip
+
8C> @param[in] NBYTE Number of bits to pack
+
9C>
+
10C> @author Robert Gammill @date 1972-07
+
+
11 SUBROUTINE sbyte(IOUT,IN,ISKIP,NBYTE)
+
12 INTEGER IN
+
13 INTEGER IOUT(*)
+
14 INTEGER MASKS(32)
+
15C
+
16 SAVE
+
17C
+
18 DATA nbitsw/32/
+
19C
+
20C DATA MASKS /Z'00000001',Z'00000003',Z'00000007',Z'0000000F',
+
21C & Z'0000001F',Z'0000003F',Z'0000007F',Z'000000FF',
+
22C & Z'000001FF',Z'000003FF',Z'000007FF',Z'00000FFF',
+
23C & Z'00001FFF',Z'00003FFF',Z'00007FFF',Z'0000FFFF',
+
24C & Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
+
25C & Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
+
26C & Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
+
27C & Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
+
28C
+
29C MASK TABLE PUT IN DECIMAL SO IT WILL COMPILE ON AN 32 BIT
+
30C COMPUTER
+
31C
+
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/
+
37C
+
38C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW
+
39C
+
40 icon = nbitsw - nbyte
+
41 IF (icon.LT.0) RETURN
+
42 mask = masks(nbyte)
+
43C
+
44C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED.
+
45C
+
46 index = ishft(iskip,-5)
+
47C
+
48C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT.
+
49C
+
50 ii = mod(iskip,nbitsw)
+
51C
+
52 j = iand(mask,in)
+
53 movel = icon - ii
+
54C
+
55C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT.
+
56C
+
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))
+
61C
+
62C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK.
+
63C
+
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))
+
70C
+
71C BYTE IS TO BE STORED RIGHT-ADJUSTED.
+
72C
+
73 ELSE
+
74 iout(index+1) = ior(iand(not(mask),iout(index+1)),j)
+
75 ENDIF
+
76C
+
77 RETURN
+
+
78 END
+
sbyte
subroutine sbyte(iout, in, iskip, nbyte)
Definition sbyte.f:12
diff --git a/sbytec_8f.html b/sbytec_8f.html index e30b5be7..7fc7a297 100644 --- a/sbytec_8f.html +++ b/sbytec_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: sbytec.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,38 +76,44 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
sbytec.f File Reference
+
sbytec.f File Reference
-

Wrapper for sbytesc() +

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...
 
subroutine sbytec (out, in, iskip, nbyte)
 This is a wrapper for sbytesc()
 

Detailed Description

-

Wrapper for sbytesc()

+

Wrapper for sbytesc()

Author
Unknown

Definition in file sbytec.f.

Function/Subroutine Documentation

- -

◆ sbytec()

+ +

◆ sbytec()

@@ -116,25 +122,25 @@

subroutine sbytec ( character*1, dimension(*)  - OUT, + out, integer, dimension(*)  - IN, + in,   - ISKIP, + iskip,   - NBYTE  + nbyte  @@ -144,7 +150,7 @@

-

This is a wrapper for sbytesc()

+

This is a wrapper for sbytesc()

Parameters
@@ -166,7 +172,7 @@

diff --git a/sbytec_8f.js b/sbytec_8f.js index a83e6e83..9cc292d6 100644 --- a/sbytec_8f.js +++ b/sbytec_8f.js @@ -1,4 +1,4 @@ var sbytec_8f = [ - [ "sbytec", "sbytec_8f.html#aa252e1e9e9f8808f95473792d319231b", null ] + [ "sbytec", "sbytec_8f.html#a8a4f2a2a7a917e47a36f737aa1d75c14", null ] ]; \ No newline at end of file diff --git a/sbytec_8f_source.html b/sbytec_8f_source.html index b62d7bf5..2128f15f 100644 --- a/sbytec_8f_source.html +++ b/sbytec_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: sbytec.f Source File @@ -23,10 +23,9 @@

[in]OUT= packed array output
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0

- + +/* @license-end */ + +
@@ -76,43 +81,51 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
sbytec.f
+
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
-
sbytec
subroutine sbytec(OUT, IN, ISKIP, NBYTE)
This is a wrapper for sbytesc()
Definition: sbytec.f:14
-
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Wrapper for sbytesc()
+
3C> @author Unknown
+
4
+
5C> This is a wrapper for sbytesc()
+
6C> @param[in] OUT = packed array output
+
7C> @param[in] IN = unpacked array input
+
8C> @param[in] ISKIP = initial number of bits to skip
+
9C> @param[in] NBYTE = number of bits to pack
+
10C>
+
11C> @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
+
sbytec
subroutine sbytec(out, in, iskip, nbyte)
This is a wrapper for sbytesc()
Definition sbytec.f:14
+
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/sbytes_8f.html b/sbytes_8f.html index 1d072c5d..07d47ee8 100644 --- a/sbytes_8f.html +++ b/sbytes_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: sbytes.f File Reference @@ -23,10 +23,9 @@
- - + @@ -34,21 +33,22 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ +
@@ -62,7 +62,7 @@
@@ -76,16 +76,22 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
Functions/Subroutines
-
-
sbytes.f File Reference
+
sbytes.f File Reference
@@ -94,11 +100,10 @@

Go to the source code of this file.

- - - + +

+

Functions/Subroutines

-subroutine sbytes (IOUT, IN, ISKIP, NBYTE, NSKIP, N)
 
subroutine sbytes (iout, in, iskip, nbyte, nskip, n)
 

Detailed Description

This is the fortran versions of sbytes().

@@ -119,13 +124,68 @@
Date
1972-07

Definition in file sbytes.f.

-
+

Function/Subroutine Documentation

+ +

◆ sbytes()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine sbytes (integer, dimension(*) iout,
integer, dimension(*) in,
 iskip,
 nbyte,
 nskip,
 n 
)
+
+ +

Definition at line 13 of file sbytes.f.

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

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...
 
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.
 

Detailed Description

Put arbitrary size values into a packed bit string.

@@ -106,8 +112,8 @@

Definition in file sbytesc.f.

Function/Subroutine Documentation

- -

◆ sbytesc()

+ +

◆ sbytesc()

@@ -116,37 +122,37 @@

subroutine sbytesc ( character*1, dimension(*)  - OUT, + out, integer, dimension(n)  - IN, + in,   - ISKIP, + iskip,   - NBYTE, + nbyte,   - NSKIP, + nskip,   - N  + n  @@ -180,7 +186,7 @@

diff --git a/sbytesc_8f.js b/sbytesc_8f.js index 30ce0d00..bfb4cfe7 100644 --- a/sbytesc_8f.js +++ b/sbytesc_8f.js @@ -1,4 +1,4 @@ var sbytesc_8f = [ - [ "sbytesc", "sbytesc_8f.html#aa527f56385adc86efba0d8605f251088", null ] + [ "sbytesc", "sbytesc_8f.html#ad30c0509f73ae28b2f15fa3c151d491c", null ] ]; \ No newline at end of file diff --git a/sbytesc_8f_source.html b/sbytesc_8f_source.html index 1ea17f53..a24e0425 100644 --- a/sbytesc_8f_source.html +++ b/sbytesc_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: sbytesc.f Source File @@ -23,10 +23,9 @@
- - + @@ -34,22 +33,28 @@
-
NCEPLIBS-w3emc -  2.11.0 +
+
NCEPLIBS-w3emc 2.11.0
- + +/* @license-end */ + +
@@ -76,90 +81,98 @@
- +
+
+
+
+
Loading...
+
Searching...
+
No Matches
+
+
+
-
-
sbytesc.f
+
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
+Go to the documentation of this file.
1C> @file
+
2C> @brief Put arbitrary size values into a packed bit string.
+
3C> @author Unknown
+
4
+
5C> Store bytes - pack bits: Put arbitrary size values into a
+
6C> packed bit string, taking the low order bits from each value
+
7C> in the unpacked array.
+
8C> @param OUT = packed array output.
+
9C> @param IN = unpacked array input.
+
10C> @param ISKIP = initial number of bits to skip.
+
11C> @param NBYTE = number of bits to pack.
+
12C> @param NSKIP = additional number of bits to skip on each iteration.
+
13C> @param N = number of iterations.
+
14C>
+
15C> @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
+
22c number bits from zero to ...
+
23c 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
+
33c 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
+
45c now byte aligned
+
46
+
47c 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
+
55c 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/search/all_0.html b/search/all_0.html deleted file mode 100644 index 1ec5b2d5..00000000 --- a/search/all_0.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_0.js b/search/all_0.js index e8e20918..eef1f633 100644 --- a/search/all_0.js +++ b/search/all_0.js @@ -1,15 +1,5 @@ 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,'']]] + ['10_20wind_20profiler_20sfc_20data_20each_20level_20see_20word_2035_20above_0',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['11_20wind_20profiler_20upper_20air_20data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_1',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]] ]; diff --git a/search/all_1.html b/search/all_1.html deleted file mode 100644 index 9f80e904..00000000 --- a/search/all_1.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_1.js b/search/all_1.js index 9ed90eef..b990f43b 100644 --- a/search/all_1.js +++ b/search/all_1.js @@ -1,4 +1,5 @@ var searchData= [ - ['bucket_12',['bucket',['../summary_8c.html#ac30f918e4632256526a027a73c95da78',1,'summary.c']]] + ['35_20above_0',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['37_20above_1',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]] ]; diff --git a/search/all_10.html b/search/all_10.html deleted file mode 100644 index 3bf11961..00000000 --- a/search/all_10.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_10.js b/search/all_10.js index 4a8e56ab..36a714a8 100644 --- a/search/all_10.js +++ b/search/all_10.js @@ -1,288 +1,8 @@ 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,'']]] + ['ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_0',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['nceplibs_20w3emc_1',['NCEPLIBS-w3emc',['../index.html',1,'']]], + ['nnalg_20true_20input_20brightness_20temperature_20file_20_3a_2',['For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md87',1,'']]], + ['note_2085_20subroutines_3',['Office-Note 85 Subroutines',['../index.html#autotoc_md18',1,'']]], + ['note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_4',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] ]; diff --git a/search/all_11.html b/search/all_11.html deleted file mode 100644 index c9f79d28..00000000 --- a/search/all_11.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_11.js b/search/all_11.js index 9cb736ec..f2d62382 100644 --- a/search/all_11.js +++ b/search/all_11.js @@ -1,9 +1,13 @@ 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,'']]] + ['ocean_20only_20_3a_0',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['of_20descriptor_1',['of descriptor',['../w3fi88_8f.html#autotoc_md29',1,'- IWIDE1 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md30',1,'- IWIDE2 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md31',1,'- IWIDE3 - Bit width for value of descriptor']]], + ['of_20retrieval_20flags_3a_2',['Description of retrieval flags:',['../w3miscan_8f.html#autotoc_md92',1,'']]], + ['of_20training_20and_20test_20data_20set_3a_3',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['office_20note_2085_20subroutines_4',['Office-Note 85 Subroutines',['../index.html#autotoc_md18',1,'']]], + ['only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_5',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_6',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['orders_7',['orders',['../orders_8f.html#a606ed1b385c755d9ebbc4de760349893',1,'orders.f']]], + ['orders_2ef_8',['orders.f',['../orders_8f.html',1,'']]], + ['over_20ocean_20only_20_3a_9',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] ]; diff --git a/search/all_12.js b/search/all_12.js new file mode 100644 index 00000000..20fc0fdb --- /dev/null +++ b/search/all_12.js @@ -0,0 +1,33 @@ +var searchData= +[ + ['packing_20and_20writing_20grib1_20files_0',['Packing and Writing GRIB1 Files',['../index.html#autotoc_md3',1,'']]], + ['parameters_1',['GRIB1 Parameters',['../index.html#autotoc_md1',1,'']]], + ['pdsens_2',['pdsens',['../pdsens_8f.html#ad99e2996ab77fc0da4f298babf729a41',1,'pdsens.f']]], + ['pdsens_2ef_3',['pdsens.f',['../pdsens_8f.html',1,'']]], + ['pdseup_4',['pdseup',['../pdseup_8f.html#aaac6faa5251b1c5320b6b055bcede9d2',1,'pdseup.f']]], + ['pdseup_2ef_5',['pdseup.f',['../pdseup_8f.html',1,'']]], + ['point_20smoother_6',['9-Point Smoother',['../index.html#autotoc_md19',1,'']]], + ['precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_7',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['previous_20versions_8',['Documentation for Previous Versions',['../index.html#autotoc_md22',1,'']]], + ['print_5ftiming_9',['print_timing',['../summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0',1,'summary.c']]], + ['printing_10',['Printing',['../index.html#autotoc_md20',1,'']]], + ['product_20definition_20section_11',['Product Definition Section',['../index.html#autotoc_md4',1,'']]], + ['products_20file_3a_20note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_12',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['profiler_20reports_13',['FORMAT FOR WIND PROFILER REPORTS',['../w3unpk77_8f.html#autotoc_md106',1,'']]], + ['profiler_20sfc_20data_20each_20level_20see_20word_2035_20above_14',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['profiler_20upper_20air_20data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_15',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['program_20history_20log_16',['Program History Log',['../w3fp10_8f.html#autotoc_md34',1,'']]], + ['program_20history_20log_3a_17',['program history log:',['../w3miscan_8f.html#autotoc_md83',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md97',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md96',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md95',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md94',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md93',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md90',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md89',1,'Program History Log:'],['../xstore_8f.html#autotoc_md124',1,'Program History Log:'],['../w3ft39_8f.html#autotoc_md77',1,'Program History Log:'],['../w3locdat_8f.html#autotoc_md82',1,'Program History Log:'],['../w3ft214_8f.html#autotoc_md72',1,'Program History Log:'],['../w3ft26_8f.html#autotoc_md73',1,'Program History Log:'],['../w3ft32_8f.html#autotoc_md74',1,'Program History Log:'],['../w3ft213_8f.html#autotoc_md71',1,'Program History Log:'],['../w3ft33_8f.html#autotoc_md75',1,'Program History Log:'],['../w3ft38_8f.html#autotoc_md76',1,'Program History Log:'],['../w3kind_8f.html#autotoc_md81',1,'Program History Log:'],['../w3ft43v_8f.html#autotoc_md80',1,'Program History Log:'],['../w3ft41_8f.html#autotoc_md79',1,'Program History Log:'],['../w3ft40_8f.html#autotoc_md78',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md113',1,'Program History Log:'],['../xmovex_8f.html#autotoc_md123',1,'Program History Log:'],['../xdopen_8f.html#autotoc_md122',1,'Program History Log:'],['../w3ymdh4_8f.html#autotoc_md121',1,'Program History Log:'],['../w3valdat_8f.html#autotoc_md120',1,'Program History Log:'],['../w3utcdat_8f.html#autotoc_md119',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md118',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md117',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md116',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md115',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md114',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md98',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md112',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md111',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md110',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md105',1,'Program History Log:'],['../w3trnarg_8f.html#autotoc_md104',1,'Program History Log:'],['../w3tagb_8f.html#autotoc_md103',1,'Program History Log:'],['../w3reddat_8f.html#autotoc_md102',1,'Program History Log:'],['../w3pradat_8f.html#autotoc_md101',1,'Program History Log:'],['../w3nogds_8f.html#autotoc_md100',1,'Program History Log:'],['../w3movdat_8f.html#autotoc_md99',1,'Program History Log:'],['../w3ft01_8f.html#autotoc_md43',1,'Program History Log:'],['../w3ft08_8f.html#autotoc_md51',1,'Program History Log:'],['../w3ft07_8f.html#autotoc_md50',1,'Program History Log:'],['../w3ft06v_8f.html#autotoc_md49',1,'Program History Log:'],['../w3ft06_8f.html#autotoc_md48',1,'Program History Log:'],['../w3ft05v_8f.html#autotoc_md47',1,'Program History Log:'],['../w3ft05_8f.html#autotoc_md46',1,'Program History Log:'],['../w3ft03_8f.html#autotoc_md45',1,'Program History Log:'],['../w3ft02_8f.html#autotoc_md44',1,'Program History Log:'],['../w3ft211_8f.html#autotoc_md69',1,'Program History Log:'],['../w3ft00_8f.html#autotoc_md42',1,'Program History Log:'],['../w3fs26_8f.html#autotoc_md41',1,'Program History Log:'],['../w3fs21_8f.html#autotoc_md40',1,'Program History Log:'],['../w3fs15_8f.html#autotoc_md39',1,'Program History Log:'],['../w3fs13_8f.html#autotoc_md38',1,'Program History Log:'],['../w3fp13_8f.html#autotoc_md37',1,'Program History Log:'],['../w3fp12_8f.html#autotoc_md36',1,'Program History Log:'],['../w3fp11_8f.html#autotoc_md35',1,'Program History Log:'],['../w3ft10_8f.html#autotoc_md53',1,'Program History Log:'],['../w3ft212_8f.html#autotoc_md70',1,'Program History Log:'],['../w3ft210_8f.html#autotoc_md68',1,'Program History Log:'],['../w3ft21_8f.html#autotoc_md67',1,'Program History Log:'],['../w3ft209_8f.html#autotoc_md66',1,'Program History Log:'],['../w3ft208_8f.html#autotoc_md65',1,'Program History Log:'],['../w3ft207_8f.html#autotoc_md64',1,'Program History Log:'],['../w3ft206_8f.html#autotoc_md63',1,'Program History Log:'],['../w3ft205_8f.html#autotoc_md62',1,'Program History Log:'],['../w3ft203_8f.html#autotoc_md60',1,'Program History Log:'],['../w3ft202_8f.html#autotoc_md59',1,'Program History Log:'],['../w3ft201_8f.html#autotoc_md58',1,'Program History Log:'],['../w3ft17_8f.html#autotoc_md57',1,'Program History Log:'],['../w3ft16_8f.html#autotoc_md56',1,'Program History Log:'],['../w3ft12_8f.html#autotoc_md55',1,'Program History Log:'],['../w3ft11_8f.html#autotoc_md54',1,'Program History Log:'],['../w3ft09_8f.html#autotoc_md52',1,'Program History Log:'],['../w3ft204_8f.html#autotoc_md61',1,'Program History Log:']]], + ['putgb_18',['putgb',['../putgb_8f.html#ab6da73b9f8ae839b451816f9916c231a',1,'putgb.f']]], + ['putgb_2ef_19',['putgb.f',['../putgb_8f.html',1,'']]], + ['putgbe_20',['putgbe',['../putgbe_8f.html#a08a29a941cd31cd04ee22f5139023e69',1,'putgbe.f']]], + ['putgbe_2ef_21',['putgbe.f',['../putgbe_8f.html',1,'']]], + ['putgben_22',['putgben',['../putgben_8f.html#a74d7f0a61a5f7937731d2b632555c69f',1,'putgben.f']]], + ['putgben_2ef_23',['putgben.f',['../putgben_8f.html',1,'']]], + ['putgbens_24',['putgbens',['../putgbens_8f.html#ad7551417c16d5720c2678f42443a045f',1,'putgbens.f']]], + ['putgbens_2ef_25',['putgbens.f',['../putgbens_8f.html',1,'']]], + ['putgbex_26',['putgbex',['../putgbex_8f.html#a4d66cc2839c13fd35ae337aa79616ce6',1,'putgbex.f']]], + ['putgbex_2ef_27',['putgbex.f',['../putgbex_8f.html',1,'']]], + ['putgbn_28',['putgbn',['../putgbn_8f.html#aec976c38f8bad78272ad997b4313a0cb',1,'putgbn.f']]], + ['putgbn_2ef_29',['putgbn.f',['../putgbn_8f.html',1,'']]] +]; diff --git a/search/all_13.js b/search/all_13.js new file mode 100644 index 00000000..f746993d --- /dev/null +++ b/search/all_13.js @@ -0,0 +1,7 @@ +var searchData= +[ + ['q9e3i6_0',['q9e3i6',['../w3ai00_8f.html#a564f42a42124d4a94e956e051ad59969',1,'w3ai00.f']]], + ['q9ei32_1',['q9ei32',['../w3ai00_8f.html#a1fd1329d5e770895def939d0467928ef',1,'w3ai00.f']]], + ['q9ie32_2',['q9ie32',['../q9ie32_8f.html#aa70d08ca2156165a1d7e6ada7698274f',1,'q9ie32.f']]], + ['q9ie32_2ef_3',['q9ie32.f',['../q9ie32_8f.html',1,'']]] +]; diff --git a/search/all_14.js b/search/all_14.js new file mode 100644 index 00000000..bbd7a65c --- /dev/null +++ b/search/all_14.js @@ -0,0 +1,36 @@ +var searchData= +[ + ['r01o29_0',['r01o29',['../iw3unp29_8f.html#af86e22354050944e4507e85c314114a0',1,'iw3unp29.f']]], + ['r63w72_1',['r63w72',['../r63w72_8f.html#af3dacce6918418d047d622bbe287a228',1,'r63w72.f']]], + ['r63w72_2ef_2',['r63w72.f',['../r63w72_8f.html',1,'']]], + ['random_5fgauss_3',['random_gauss',['../interfacemersenne__twister_1_1random__gauss.html',1,'mersenne_twister']]], + ['random_5fgauss_5ff_4',['random_gauss_f',['../namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437',1,'mersenne_twister']]], + ['random_5fgauss_5fi_5',['random_gauss_i',['../interfacemersenne__twister_1_1random__gauss.html#a2ab29e2f6e4efe8ffd858ff257747173',1,'mersenne_twister::random_gauss']]], + ['random_5fgauss_5fs_6',['random_gauss_s',['../interfacemersenne__twister_1_1random__gauss.html#a50af58f1f0525f0d68b14e6362305b1c',1,'mersenne_twister::random_gauss']]], + ['random_5fgauss_5ft_7',['random_gauss_t',['../interfacemersenne__twister_1_1random__gauss.html#afea5a15176c49f9829db24f555692278',1,'mersenne_twister::random_gauss']]], + ['random_5findex_8',['random_index',['../interfacemersenne__twister_1_1random__index.html',1,'mersenne_twister']]], + ['random_5findex_5ff_9',['random_index_f',['../namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e',1,'mersenne_twister']]], + ['random_5findex_5fi_10',['random_index_i',['../interfacemersenne__twister_1_1random__index.html#adb086879ee9eabb64d4026daacf40567',1,'mersenne_twister::random_index']]], + ['random_5findex_5fs_11',['random_index_s',['../interfacemersenne__twister_1_1random__index.html#ab4356f122440e3e8eb2eccfd16968c84',1,'mersenne_twister::random_index']]], + ['random_5findex_5ft_12',['random_index_t',['../interfacemersenne__twister_1_1random__index.html#af137b7c612966c256b47c9949f8095ba',1,'mersenne_twister::random_index']]], + ['random_5fnumber_13',['random_number',['../interfacemersenne__twister_1_1random__number.html',1,'mersenne_twister']]], + ['random_5fnumber_5ff_14',['random_number_f',['../namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a',1,'mersenne_twister']]], + ['random_5fnumber_5fi_15',['random_number_i',['../interfacemersenne__twister_1_1random__number.html#a4df934289beedb0e333c1260489949e6',1,'mersenne_twister::random_number']]], + ['random_5fnumber_5fs_16',['random_number_s',['../interfacemersenne__twister_1_1random__number.html#a94e918a10214cfe0c24c303d220452e7',1,'mersenne_twister::random_number']]], + ['random_5fnumber_5ft_17',['random_number_t',['../interfacemersenne__twister_1_1random__number.html#a0f53661cf413d88e71aef77a9a9468ae',1,'mersenne_twister::random_number']]], + ['random_5fseed_18',['random_seed',['../namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad',1,'mersenne_twister']]], + ['random_5fsetseed_19',['random_setseed',['../interfacemersenne__twister_1_1random__setseed.html',1,'mersenne_twister']]], + ['random_5fsetseed_5fs_20',['random_setseed_s',['../interfacemersenne__twister_1_1random__setseed.html#af25a7d71ddbad282dd5eb407c0bd907d',1,'mersenne_twister::random_setseed']]], + ['random_5fsetseed_5ft_21',['random_setseed_t',['../interfacemersenne__twister_1_1random__setseed.html#a21dac133ee7db7e53a1161f36efe9d11',1,'mersenne_twister::random_setseed']]], + ['random_5fstat_22',['random_stat',['../structmersenne__twister_1_1random__stat.html',1,'mersenne_twister']]], + ['reading_20formats_23',['Reading Formats',['../index.html#autotoc_md7',1,'']]], + ['reading_20grib1_20files_24',['Reading GRIB1 Files',['../index.html#autotoc_md2',1,'']]], + ['reports_25',['FORMAT FOR WIND PROFILER REPORTS',['../w3unpk77_8f.html#autotoc_md106',1,'']]], + ['resource_26',['resource',['../summary_8c.html#a585b71c74faea63d161810774ef8da9e',1,'summary.c']]], + ['retrieval_20flags_3a_27',['Description of retrieval flags:',['../w3miscan_8f.html#autotoc_md92',1,'']]], + ['returned_3a_28',['Always returned:',['../w3miscan_8f.html#autotoc_md84',1,'']]], + ['risc02_29',['risc02',['../w3miscan_8f.html#aae1710f52170633399d23802b4ad8b51',1,'w3miscan.f']]], + ['risc02xx_30',['risc02xx',['../w3miscan_8f.html#aa99de7615b5b2a0f60a385c3be1ba9da',1,'w3miscan.f']]], + ['risc03_31',['risc03',['../w3miscan_8f.html#ab194d2809f49e869082d6ae6b3b977c9',1,'w3miscan.f']]], + ['routine_32',['routine',['../w3fi67_8f.html#autotoc_md24',1,'TO USE THIS ROUTINE'],['../w3fi78_8f.html#autotoc_md27',1,'TO USE THIS ROUTINE'],['../w3fi88_8f.html#autotoc_md33',1,'To use this routine']]] +]; diff --git a/search/all_15.js b/search/all_15.js new file mode 100644 index 00000000..d1d6b067 --- /dev/null +++ b/search/all_15.js @@ -0,0 +1,30 @@ +var searchData= +[ + ['s06o29_0',['s06o29',['../iw3unp29_8f.html#aaa7ab7bf0bec88768b0fcb9921f07ff1',1,'iw3unp29.f']]], + ['sbyte_1',['sbyte',['../sbyte_8f.html#a74f0f88a79864061c3a4234075d39e1b',1,'sbyte.f']]], + ['sbyte_2ef_2',['sbyte.f',['../sbyte_8f.html',1,'']]], + ['sbytec_3',['sbytec',['../sbytec_8f.html#a8a4f2a2a7a917e47a36f737aa1d75c14',1,'sbytec.f']]], + ['sbytec_2ef_4',['sbytec.f',['../sbytec_8f.html',1,'']]], + ['sbytes_2ef_5',['sbytes.f',['../sbytes_8f.html',1,'']]], + ['sbytesc_6',['sbytesc',['../sbytesc_8f.html#ad30c0509f73ae28b2f15fa3c151d491c',1,'sbytesc.f']]], + ['sbytesc_2ef_7',['sbytesc.f',['../sbytesc_8f.html',1,'']]], + ['sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_8',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['section_9',['section',['../index.html#autotoc_md5',1,'Grid Description Section'],['../index.html#autotoc_md4',1,'Product Definition Section']]], + ['see_20word_2035_20above_10',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['see_20word_2037_20above_11',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['set_3a_12',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['setcl_13',['setcl',['../w3fp06_8f.html#a85c5aff8a14219277412b5178d23c8eb',1,'w3fp06.f']]], + ['sfc_20data_20each_20level_20see_20word_2035_20above_14',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['skgb_15',['skgb',['../skgb_8f.html#a33d9c42574632a3c57ecc85d17c8e62a',1,'skgb.f']]], + ['skgb_2ef_16',['skgb.f',['../skgb_8f.html',1,'']]], + ['smoother_17',['9-Point Smoother',['../index.html#autotoc_md19',1,'']]], + ['sorting_18',['Sorting',['../index.html#autotoc_md11',1,'']]], + ['speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_19',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['start_5f_20',['start_',['../summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e',1,'summary.c']]], + ['start_5ftimer_21',['start_timer',['../summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7',1,'summary.c']]], + ['subroutines_22',['subroutines',['../index.html#autotoc_md15',1,'Dummy Subroutines'],['../index.html#autotoc_md18',1,'Office-Note 85 Subroutines']]], + ['summary_2ec_23',['summary.c',['../summary_8c.html',1,'']]], + ['summary_5f_24',['summary_',['../summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110',1,'summary.c']]], + ['surface_20each_20level_20see_20word_2037_20above_25',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_26',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] +]; diff --git a/search/all_16.js b/search/all_16.js new file mode 100644 index 00000000..82e5b044 --- /dev/null +++ b/search/all_16.js @@ -0,0 +1,17 @@ +var searchData= +[ + ['temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_0',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['temperature_20file_20_3a_1',['temperature file :',['../w3miscan_8f.html#autotoc_md86',1,'For LBRIT = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md88',1,'For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md87',1,'For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):']]], + ['test_20data_20set_3a_2',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_3',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['this_20routine_4',['this routine',['../w3fi88_8f.html#autotoc_md33',1,'To use this routine'],['../w3fi78_8f.html#autotoc_md27',1,'TO USE THIS ROUTINE'],['../w3fi67_8f.html#autotoc_md24',1,'TO USE THIS ROUTINE']]], + ['time_5',['Date/Time',['../index.html#autotoc_md10',1,'']]], + ['to_20use_20this_20routine_6',['to use this routine',['../w3fi88_8f.html#autotoc_md33',1,'To use this routine'],['../w3fi78_8f.html#autotoc_md27',1,'TO USE THIS ROUTINE'],['../w3fi67_8f.html#autotoc_md24',1,'TO USE THIS ROUTINE']]], + ['total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_7',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['training_20and_20test_20data_20set_3a_8',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['transformation_9',['Transformation',['../index.html#autotoc_md21',1,'']]], + ['true_20and_20gbalg_20true_20input_20brightness_20temperature_20file_20_3a_10',['For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md88',1,'']]], + ['true_20and_20nnalg_20true_20input_20brightness_20temperature_20file_20_3a_11',['For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md87',1,'']]], + ['true_20input_20brightness_20temperature_20file_20_3a_12',['For LBRIT = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md86',1,'']]], + ['true_20input_20products_20file_3a_20note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_13',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] +]; diff --git a/search/all_17.js b/search/all_17.js new file mode 100644 index 00000000..916b2bf9 --- /dev/null +++ b/search/all_17.js @@ -0,0 +1,14 @@ +var searchData= +[ + ['unpk7701_0',['unpk7701',['../w3unpk77_8f.html#a6e6b3e1b8bac81ed3db73ab1fca6c40f',1,'w3unpk77.f']]], + ['unpk7702_1',['unpk7702',['../w3unpk77_8f.html#a35877dbb88d9e6fb89b1807238f95018',1,'w3unpk77.f']]], + ['unpk7703_2',['unpk7703',['../w3unpk77_8f.html#ac39a6820df8dfea69d930ab738b8b07e',1,'w3unpk77.f']]], + ['unpk7704_3',['unpk7704',['../w3unpk77_8f.html#a9dfb4c67d159cc49f2a43151ec25e915',1,'w3unpk77.f']]], + ['unpk7705_4',['unpk7705',['../w3unpk77_8f.html#a3b7ce3ad5342da6e89fbbeb173ae47d5',1,'w3unpk77.f']]], + ['unpk7706_5',['unpk7706',['../w3unpk77_8f.html#a781d7a1d34ea17a555131bdde0ce1579',1,'w3unpk77.f']]], + ['unpk7707_6',['unpk7707',['../w3unpk77_8f.html#a73cd8561593c0b5c72075104f7200594',1,'w3unpk77.f']]], + ['unpk7708_7',['unpk7708',['../w3unpk77_8f.html#a03a9e7379784e4998d610e00673b05ea',1,'w3unpk77.f']]], + ['unpk7709_8',['unpk7709',['../w3unpk77_8f.html#a515f864a3a6adab3695cef735f610479',1,'w3unpk77.f']]], + ['upper_20air_20data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_9',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['use_20this_20routine_10',['use this routine',['../w3fi67_8f.html#autotoc_md24',1,'TO USE THIS ROUTINE'],['../w3fi78_8f.html#autotoc_md27',1,'TO USE THIS ROUTINE'],['../w3fi88_8f.html#autotoc_md33',1,'To use this routine']]] +]; diff --git a/search/all_18.js b/search/all_18.js new file mode 100644 index 00000000..3b5560f2 --- /dev/null +++ b/search/all_18.js @@ -0,0 +1,6 @@ +var searchData= +[ + ['value_20of_20descriptor_0',['value of descriptor',['../w3fi88_8f.html#autotoc_md29',1,'- IWIDE1 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md30',1,'- IWIDE2 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md31',1,'- IWIDE3 - Bit width for value of descriptor']]], + ['value1_1',['value1',['../w3fp06_8f.html#a50f973cd14b24a8da68b625d31c18dfa',1,'w3fp06.f']]], + ['versions_2',['Documentation for Previous Versions',['../index.html#autotoc_md22',1,'']]] +]; diff --git a/search/all_19.js b/search/all_19.js new file mode 100644 index 00000000..962078b9 --- /dev/null +++ b/search/all_19.js @@ -0,0 +1,298 @@ +var searchData= +[ + ['w3ai00_0',['w3ai00',['../w3ai00_8f.html#a4d10019a7be86cad3b458e0556e0e163',1,'w3ai00.f']]], + ['w3ai00_2ef_1',['w3ai00.f',['../w3ai00_8f.html',1,'']]], + ['w3ai01_2',['w3ai01',['../w3ai01_8f.html#acf00ef759655cd640826064c50ff8150',1,'w3ai01.f']]], + ['w3ai01_2ef_3',['w3ai01.f',['../w3ai01_8f.html',1,'']]], + ['w3ai08_4',['w3ai08',['../w3ai08_8f.html#a50cf1edd8615abf5c6c333c8e790f63b',1,'w3ai08.f']]], + ['w3ai08_2ef_5',['w3ai08.f',['../w3ai08_8f.html',1,'']]], + ['w3ai15_6',['w3ai15',['../w3ai15_8f.html#a87103805250f46624e11c6ca8c68b288',1,'w3ai15.f']]], + ['w3ai15_2ef_7',['w3ai15.f',['../w3ai15_8f.html',1,'']]], + ['w3ai18_8',['w3ai18',['../w3ai18_8f.html#ac5f95206395f4fff1f8bd74dbc8a929b',1,'w3ai18.f']]], + ['w3ai18_2ef_9',['w3ai18.f',['../w3ai18_8f.html',1,'']]], + ['w3ai19_10',['w3ai19',['../w3ai19_8f.html#a94ced6d87294ca6fd467da8e9b42096b',1,'w3ai19.f']]], + ['w3ai19_2ef_11',['w3ai19.f',['../w3ai19_8f.html',1,'']]], + ['w3ai24_12',['w3ai24',['../w3ai24_8f.html#a2468984a80b3966028f29391a091a5f2',1,'w3ai24.f']]], + ['w3ai24_2ef_13',['w3ai24.f',['../w3ai24_8f.html',1,'']]], + ['w3ai38_14',['w3ai38',['../w3ai38_8f.html#a8c31fa8b048696a5616b55d753eaa193',1,'w3ai38.f']]], + ['w3ai38_2ef_15',['w3ai38.f',['../w3ai38_8f.html',1,'']]], + ['w3ai39_16',['w3ai39',['../w3ai39_8f.html#a997a055c96092bc5e8ef74404f34e7d1',1,'w3ai39.f']]], + ['w3ai39_2ef_17',['w3ai39.f',['../w3ai39_8f.html',1,'']]], + ['w3ai40_18',['w3ai40',['../w3ai40_8f.html#a1675f4f6d98aa6a1cdbd2dfd44975d49',1,'w3ai40.f']]], + ['w3ai40_2ef_19',['w3ai40.f',['../w3ai40_8f.html',1,'']]], + ['w3ai41_20',['w3ai41',['../w3ai41_8f.html#aec7a595f5288838e71110ac432b1777a',1,'w3ai41.f']]], + ['w3ai41_2ef_21',['w3ai41.f',['../w3ai41_8f.html',1,'']]], + ['w3aq15_22',['w3aq15',['../w3aq15_8f.html#ab150670d527c962c1deceb71106976d3',1,'w3aq15.f']]], + ['w3aq15_2ef_23',['w3aq15.f',['../w3aq15_8f.html',1,'']]], + ['w3as00_24',['w3as00',['../w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529',1,'w3as00.f']]], + ['w3as00_2ef_25',['w3as00.f',['../w3as00_8f.html',1,'']]], + ['w3ctzdat_26',['w3ctzdat',['../w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035',1,'w3ctzdat.f']]], + ['w3ctzdat_2ef_27',['w3ctzdat.f',['../w3ctzdat_8f.html',1,'']]], + ['w3difdat_28',['w3difdat',['../w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1',1,'w3difdat.f']]], + ['w3difdat_2ef_29',['w3difdat.f',['../w3difdat_8f.html',1,'']]], + ['w3doxdat_30',['w3doxdat',['../w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29',1,'w3doxdat.f']]], + ['w3doxdat_2ef_31',['w3doxdat.f',['../w3doxdat_8f.html',1,'']]], + ['w3emc_32',['NCEPLIBS-w3emc',['../index.html',1,'']]], + ['w3fa01_33',['w3fa01',['../w3fa01_8f.html#acfc4149f4d9c51d2b5b9888e932f25ca',1,'w3fa01.f']]], + ['w3fa01_2ef_34',['w3fa01.f',['../w3fa01_8f.html',1,'']]], + ['w3fa03_35',['w3fa03',['../w3fa03_8f.html#a7805169d794ed38e57ba685e6241100b',1,'w3fa03.f']]], + ['w3fa03_2ef_36',['w3fa03.f',['../w3fa03_8f.html',1,'']]], + ['w3fa03v_37',['w3fa03v',['../w3fa03v_8f.html#a1d2407e31446d6ad82bd4e2cb61fd5d7',1,'w3fa03v.f']]], + ['w3fa03v_2ef_38',['w3fa03v.f',['../w3fa03v_8f.html',1,'']]], + ['w3fa04_39',['w3fa04',['../w3fa04_8f.html#a4a761802c7bab00ea502026e7863696a',1,'w3fa04.f']]], + ['w3fa04_2ef_40',['w3fa04.f',['../w3fa04_8f.html',1,'']]], + ['w3fa06_41',['w3fa06',['../w3fa06_8f.html#aa82de1d1f83eb4bb981a5d00b3af13d9',1,'w3fa06.f']]], + ['w3fa06_2ef_42',['w3fa06.f',['../w3fa06_8f.html',1,'']]], + ['w3fa09_43',['w3fa09',['../w3fa09_8f.html#ad48026b7570d6ac92635a6719c9ef7fc',1,'w3fa09.f']]], + ['w3fa09_2ef_44',['w3fa09.f',['../w3fa09_8f.html',1,'']]], + ['w3fa11_45',['w3fa11',['../w3fa11_8f.html#ac97049f63913eb3d3af50c42ea29e5c8',1,'w3fa11.f']]], + ['w3fa11_2ef_46',['w3fa11.f',['../w3fa11_8f.html',1,'']]], + ['w3fa12_47',['w3fa12',['../w3fa12_8f.html#a74541e2949ce81754b1e8a4a3e5d946f',1,'w3fa12.f']]], + ['w3fa12_2ef_48',['w3fa12.f',['../w3fa12_8f.html',1,'']]], + ['w3fa13_49',['w3fa13',['../w3fa13_8f.html#a79f0efdd8bbc53bd8c9bc9aa7ca41811',1,'w3fa13.f']]], + ['w3fa13_2ef_50',['w3fa13.f',['../w3fa13_8f.html',1,'']]], + ['w3fb00_51',['w3fb00',['../w3fb00_8f.html#a6581d211e674bcbe0b47b2d65e9aa671',1,'w3fb00.f']]], + ['w3fb00_2ef_52',['w3fb00.f',['../w3fb00_8f.html',1,'']]], + ['w3fb01_53',['w3fb01',['../w3fb01_8f.html#aa4c5be625575219d8a21032e55ffa8ee',1,'w3fb01.f']]], + ['w3fb01_2ef_54',['w3fb01.f',['../w3fb01_8f.html',1,'']]], + ['w3fb02_55',['w3fb02',['../w3fb02_8f.html#aac12d4245442631655101f5a4b27aee2',1,'w3fb02.f']]], + ['w3fb02_2ef_56',['w3fb02.f',['../w3fb02_8f.html',1,'']]], + ['w3fb03_57',['w3fb03',['../w3fb03_8f.html#ac1d9e9f45629c503bd63fc3e79c9892f',1,'w3fb03.f']]], + ['w3fb03_2ef_58',['w3fb03.f',['../w3fb03_8f.html',1,'']]], + ['w3fb04_59',['w3fb04',['../w3fb04_8f.html#a3b860b612d62a311ec6364ed3ecd1ca4',1,'w3fb04.f']]], + ['w3fb04_2ef_60',['w3fb04.f',['../w3fb04_8f.html',1,'']]], + ['w3fb05_61',['w3fb05',['../w3fb05_8f.html#af9bdbe0b4b7576494298c0b50c6fc837',1,'w3fb05.f']]], + ['w3fb05_2ef_62',['w3fb05.f',['../w3fb05_8f.html',1,'']]], + ['w3fb06_63',['w3fb06',['../w3fb06_8f.html#a3b5622b466f3ab1d3c93b8c3606ca27e',1,'w3fb06.f']]], + ['w3fb06_2ef_64',['w3fb06.f',['../w3fb06_8f.html',1,'']]], + ['w3fb07_65',['w3fb07',['../w3fb07_8f.html#ade62d0dff4cb419a076b295780e1c72d',1,'w3fb07.f']]], + ['w3fb07_2ef_66',['w3fb07.f',['../w3fb07_8f.html',1,'']]], + ['w3fb08_67',['w3fb08',['../w3fb08_8f.html#a404c4d79a1162f49baeebe63f6a48174',1,'w3fb08.f']]], + ['w3fb08_2ef_68',['w3fb08.f',['../w3fb08_8f.html',1,'']]], + ['w3fb09_69',['w3fb09',['../w3fb09_8f.html#a97d39b7d805646bba7510a3fb06f44ea',1,'w3fb09.f']]], + ['w3fb09_2ef_70',['w3fb09.f',['../w3fb09_8f.html',1,'']]], + ['w3fb10_71',['w3fb10',['../w3fb10_8f.html#aa7f39f82090c39b8550d19c26fd6e88c',1,'w3fb10.f']]], + ['w3fb10_2ef_72',['w3fb10.f',['../w3fb10_8f.html',1,'']]], + ['w3fb11_73',['w3fb11',['../w3fb11_8f.html#a44ef8585ec761cc4360677a4043ae836',1,'w3fb11.f']]], + ['w3fb11_2ef_74',['w3fb11.f',['../w3fb11_8f.html',1,'']]], + ['w3fb12_75',['w3fb12',['../w3fb12_8f.html#a8bf51dda5c2baf121134274723c79837',1,'w3fb12.f']]], + ['w3fb12_2ef_76',['w3fb12.f',['../w3fb12_8f.html',1,'']]], + ['w3fc02_77',['w3fc02',['../w3fc02_8f.html#aa7ac60b61ee09def3c2e5e2005575cec',1,'w3fc02.f']]], + ['w3fc02_2ef_78',['w3fc02.f',['../w3fc02_8f.html',1,'']]], + ['w3fc05_79',['w3fc05',['../w3fc05_8f.html#a2a855302ae772a201af2e93a43fa8fa9',1,'w3fc05.f']]], + ['w3fc05_2ef_80',['w3fc05.f',['../w3fc05_8f.html',1,'']]], + ['w3fc06_81',['w3fc06',['../w3fc06_8f.html#a4b85830235c80e0c007cba0d9e2ad7e8',1,'w3fc06.f']]], + ['w3fc06_2ef_82',['w3fc06.f',['../w3fc06_8f.html',1,'']]], + ['w3fc07_83',['w3fc07',['../w3fc07_8f.html#aa2d422861395fb930f4a8a235beb5735',1,'w3fc07.f']]], + ['w3fc07_2ef_84',['w3fc07.f',['../w3fc07_8f.html',1,'']]], + ['w3fc08_85',['w3fc08',['../w3fc08_8f.html#ab866267da1ef5f8208ffe29f38590b6c',1,'w3fc08.f']]], + ['w3fc08_2ef_86',['w3fc08.f',['../w3fc08_8f.html',1,'']]], + ['w3fi01_87',['w3fi01',['../w3fi01_8f.html#a45d73d5e35cbbe33e27e9c11684ca491',1,'w3fi01.f']]], + ['w3fi01_2ef_88',['w3fi01.f',['../w3fi01_8f.html',1,'']]], + ['w3fi02_89',['w3fi02',['../w3fi02_8f.html#a12ce6be899705cebb27f675ef5413353',1,'w3fi02.f']]], + ['w3fi02_2ef_90',['w3fi02.f',['../w3fi02_8f.html',1,'']]], + ['w3fi03_91',['w3fi03',['../w3fi03_8f.html#a875772e1917cd6bf73eabca330b517de',1,'w3fi03.f']]], + ['w3fi03_2ef_92',['w3fi03.f',['../w3fi03_8f.html',1,'']]], + ['w3fi04_93',['w3fi04',['../w3fi04_8f.html#a59af48612285f36dae46e14f4b0e8a85',1,'w3fi04.f']]], + ['w3fi04_2ef_94',['w3fi04.f',['../w3fi04_8f.html',1,'']]], + ['w3fi18_95',['w3fi18',['../w3fi18_8f.html#a3e60fdacb75b639d8e444a507259a1e8',1,'w3fi18.f']]], + ['w3fi18_2ef_96',['w3fi18.f',['../w3fi18_8f.html',1,'']]], + ['w3fi19_97',['w3fi19',['../w3fi19_8f.html#a4eef5192d8f6d23e77aef025680f7b9f',1,'w3fi19.f']]], + ['w3fi19_2ef_98',['w3fi19.f',['../w3fi19_8f.html',1,'']]], + ['w3fi20_99',['w3fi20',['../w3fi20_8f.html#a9ef932fe706763c5afc84a7c6797d415',1,'w3fi20.f']]], + ['w3fi20_2ef_100',['w3fi20.f',['../w3fi20_8f.html',1,'']]], + ['w3fi32_101',['w3fi32',['../w3fi32_8f.html#a873077240f7b409fea74580cbfed49ad',1,'w3fi32.f']]], + ['w3fi32_2ef_102',['w3fi32.f',['../w3fi32_8f.html',1,'']]], + ['w3fi47_103',['w3fi47',['../w3fi47_8f.html#ad09c2b7b4957ee75a21baf17c5ae091e',1,'w3fi47.f']]], + ['w3fi47_2ef_104',['w3fi47.f',['../w3fi47_8f.html',1,'']]], + ['w3fi48_105',['w3fi48',['../w3fi48_8f.html#aa7d2d23ac60388b262bab73ae8434fa7',1,'w3fi48.f']]], + ['w3fi48_2ef_106',['w3fi48.f',['../w3fi48_8f.html',1,'']]], + ['w3fi58_107',['w3fi58',['../w3fi58_8f.html#a06f9456e4b8c768f7853a0ba42a5d229',1,'w3fi58.f']]], + ['w3fi58_2ef_108',['w3fi58.f',['../w3fi58_8f.html',1,'']]], + ['w3fi59_109',['w3fi59',['../w3fi59_8f.html#a8bba5bf7656b97615cfba69962c91782',1,'w3fi59.f']]], + ['w3fi59_2ef_110',['w3fi59.f',['../w3fi59_8f.html',1,'']]], + ['w3fi61_111',['w3fi61',['../w3fi61_8f.html#a41ee42bf0040218d3bf0c0c93716d12e',1,'w3fi61.f']]], + ['w3fi61_2ef_112',['w3fi61.f',['../w3fi61_8f.html',1,'']]], + ['w3fi62_113',['w3fi62',['../w3fi62_8f.html#a462db56d61f6d13371250087a22255ba',1,'w3fi62.f']]], + ['w3fi62_2ef_114',['w3fi62.f',['../w3fi62_8f.html',1,'']]], + ['w3fi63_115',['w3fi63',['../w3fi63_8f.html#a275d433403624224a7d8da4c820b76be',1,'w3fi63.f']]], + ['w3fi63_2ef_116',['w3fi63.f',['../w3fi63_8f.html',1,'']]], + ['w3fi64_117',['w3fi64',['../w3fi64_8f.html#a450e698ffae06cf8cd67fa9e2ba1170b',1,'w3fi64.f']]], + ['w3fi64_2ef_118',['w3fi64.f',['../w3fi64_8f.html',1,'']]], + ['w3fi65_119',['w3fi65',['../w3fi65_8f.html#a04761367dc026f8b456d586d186a5dcd',1,'w3fi65.f']]], + ['w3fi65_2ef_120',['w3fi65.f',['../w3fi65_8f.html',1,'']]], + ['w3fi66_121',['w3fi66',['../w3fi66_8f.html#a70b3cfe6a9e87d8b292ab36cfe2e2811',1,'w3fi66.f']]], + ['w3fi66_2ef_122',['w3fi66.f',['../w3fi66_8f.html',1,'']]], + ['w3fi67_123',['w3fi67',['../w3fi67_8f.html#a7d0d66e5c01d134ce7e40a6f33e54479',1,'w3fi67.f']]], + ['w3fi67_2ef_124',['w3fi67.f',['../w3fi67_8f.html',1,'']]], + ['w3fi68_125',['w3fi68',['../w3fi68_8f.html#a2f103e1d1423a0f9585dbf5633758020',1,'w3fi68.f']]], + ['w3fi68_2ef_126',['w3fi68.f',['../w3fi68_8f.html',1,'']]], + ['w3fi69_127',['w3fi69',['../w3fi69_8f.html#adcd583a43ddb3397dc354375ca5e5029',1,'w3fi69.f']]], + ['w3fi69_2ef_128',['w3fi69.f',['../w3fi69_8f.html',1,'']]], + ['w3fi70_129',['w3fi70',['../w3fi70_8f.html#a804adf2c4205b93098ecb914e5a138ba',1,'w3fi70.f']]], + ['w3fi70_2ef_130',['w3fi70.f',['../w3fi70_8f.html',1,'']]], + ['w3fi71_131',['w3fi71',['../w3fi71_8f.html#a8093d4ae34f8b50308c55b03ac0d2fc6',1,'w3fi71.f']]], + ['w3fi71_2ef_132',['w3fi71.f',['../w3fi71_8f.html',1,'']]], + ['w3fi72_133',['w3fi72',['../w3fi72_8f.html#af30a5edb120c0910beafc6ee46d1f3c5',1,'w3fi72.f']]], + ['w3fi72_2ef_134',['w3fi72.f',['../w3fi72_8f.html',1,'']]], + ['w3fi73_135',['w3fi73',['../w3fi73_8f.html#a16b6fc47763b666ed5c21c66e65b0e63',1,'w3fi73.f']]], + ['w3fi73_2ef_136',['w3fi73.f',['../w3fi73_8f.html',1,'']]], + ['w3fi74_137',['w3fi74',['../w3fi74_8f.html#aa3d0542b1282d44be47215d59e6432dc',1,'w3fi74.f']]], + ['w3fi74_2ef_138',['w3fi74.f',['../w3fi74_8f.html',1,'']]], + ['w3fi75_139',['w3fi75',['../w3fi75_8f.html#a132bfbd67589901d6bb5e9f72158a0c7',1,'w3fi75.f']]], + ['w3fi75_2ef_140',['w3fi75.f',['../w3fi75_8f.html',1,'']]], + ['w3fi76_141',['w3fi76',['../w3fi76_8f.html#a9e0b5a3150bf143ba67534a40ddd2856',1,'w3fi76.f']]], + ['w3fi76_2ef_142',['w3fi76.f',['../w3fi76_8f.html',1,'']]], + ['w3fi78_143',['w3fi78',['../w3fi78_8f.html#a412826ca598b211d75aa9b6be5dded05',1,'w3fi78.f']]], + ['w3fi78_2ef_144',['w3fi78.f',['../w3fi78_8f.html',1,'']]], + ['w3fi82_145',['w3fi82',['../w3fi82_8f.html#a2888bd47bed9eb1b569ec4da20dcac8f',1,'w3fi82.f']]], + ['w3fi82_2ef_146',['w3fi82.f',['../w3fi82_8f.html',1,'']]], + ['w3fi83_147',['w3fi83',['../w3fi83_8f.html#ad0372b453a84bbc270281245dbbad82e',1,'w3fi83.f']]], + ['w3fi83_2ef_148',['w3fi83.f',['../w3fi83_8f.html',1,'']]], + ['w3fi85_149',['w3fi85',['../w3fi85_8f.html#a7b304c2b30215c2ca98f21d240d4335b',1,'w3fi85.f']]], + ['w3fi85_2ef_150',['w3fi85.f',['../w3fi85_8f.html',1,'']]], + ['w3fi88_151',['w3fi88',['../w3fi88_8f.html#a597695a8a2eff93db31a2eb8d93ee8c9',1,'w3fi88.f']]], + ['w3fi88_2ef_152',['w3fi88.f',['../w3fi88_8f.html',1,'']]], + ['w3fi92_153',['w3fi92',['../w3fi92_8f.html#a22888b37a35c7f9abe63dc5cfd743422',1,'w3fi92.f']]], + ['w3fi92_2ef_154',['w3fi92.f',['../w3fi92_8f.html',1,'']]], + ['w3fm07_155',['w3fm07',['../w3fm07_8f.html#a03b3b4ebb95c829f88ab858b6709cfd7',1,'w3fm07.f']]], + ['w3fm07_2ef_156',['w3fm07.f',['../w3fm07_8f.html',1,'']]], + ['w3fm08_157',['w3fm08',['../w3fm08_8f.html#ad5d5a454e8cdb3623fbdb0df3f44cbcc',1,'w3fm08.f']]], + ['w3fm08_2ef_158',['w3fm08.f',['../w3fm08_8f.html',1,'']]], + ['w3fp04_159',['w3fp04',['../w3fp04_8f.html#abc0c89b29a4a74847841e5a1aa35e49a',1,'w3fp04.f']]], + ['w3fp04_2ef_160',['w3fp04.f',['../w3fp04_8f.html',1,'']]], + ['w3fp05_161',['w3fp05',['../w3fp05_8f.html#a68a1b19e798523cddbf6d2aea4751362',1,'w3fp05.f']]], + ['w3fp05_2ef_162',['w3fp05.f',['../w3fp05_8f.html',1,'']]], + ['w3fp06_163',['w3fp06',['../w3fp06_8f.html#a1912bdef4280f84618d529e4764ac8fd',1,'w3fp06.f']]], + ['w3fp06_2ef_164',['w3fp06.f',['../w3fp06_8f.html',1,'']]], + ['w3fp10_165',['w3fp10',['../w3fp10_8f.html#ac8a2ca08aafc6e727d1e230f69c734b3',1,'w3fp10.f']]], + ['w3fp10_2ef_166',['w3fp10.f',['../w3fp10_8f.html',1,'']]], + ['w3fp11_167',['w3fp11',['../w3fp11_8f.html#a0e68dda36ce06180df15d26525b8ad92',1,'w3fp11.f']]], + ['w3fp11_2ef_168',['w3fp11.f',['../w3fp11_8f.html',1,'']]], + ['w3fp12_169',['w3fp12',['../w3fp12_8f.html#a90be3644f6c4c935c450a188c5193a3f',1,'w3fp12.f']]], + ['w3fp12_2ef_170',['w3fp12.f',['../w3fp12_8f.html',1,'']]], + ['w3fp13_171',['w3fp13',['../w3fp13_8f.html#a56fb62646dcbbcea7bc5239ed6f5acd0',1,'w3fp13.f']]], + ['w3fp13_2ef_172',['w3fp13.f',['../w3fp13_8f.html',1,'']]], + ['w3fs13_173',['w3fs13',['../w3fs13_8f.html#afce9c885afc9ee59a125a8db9ac5eee4',1,'w3fs13.f']]], + ['w3fs13_2ef_174',['w3fs13.f',['../w3fs13_8f.html',1,'']]], + ['w3fs15_175',['w3fs15',['../w3fs15_8f.html#a6503e7b854ccc60e9a09e85413642c5c',1,'w3fs15.f']]], + ['w3fs15_2ef_176',['w3fs15.f',['../w3fs15_8f.html',1,'']]], + ['w3fs21_177',['w3fs21',['../w3fs21_8f.html#a9af93d7745b3435c83155476954bbdb8',1,'w3fs21.f']]], + ['w3fs21_2ef_178',['w3fs21.f',['../w3fs21_8f.html',1,'']]], + ['w3fs26_179',['w3fs26',['../w3fs26_8f.html#a907c7328b67cac5929274519593d6c83',1,'w3fs26.f']]], + ['w3fs26_2ef_180',['w3fs26.f',['../w3fs26_8f.html',1,'']]], + ['w3ft00_181',['w3ft00',['../w3ft00_8f.html#aef914a82466f1f10f20f61a45cba4676',1,'w3ft00.f']]], + ['w3ft00_2ef_182',['w3ft00.f',['../w3ft00_8f.html',1,'']]], + ['w3ft01_183',['w3ft01',['../w3ft01_8f.html#a526211242588a42f89dd5f724dd78595',1,'w3ft01.f']]], + ['w3ft01_2ef_184',['w3ft01.f',['../w3ft01_8f.html',1,'']]], + ['w3ft02_185',['w3ft02',['../w3ft02_8f.html#a2d66a49241741b516a284f7881c67160',1,'w3ft02.f']]], + ['w3ft02_2ef_186',['w3ft02.f',['../w3ft02_8f.html',1,'']]], + ['w3ft03_187',['w3ft03',['../w3ft03_8f.html#a4989ac1555e50285597693623cc2da77',1,'w3ft03.f']]], + ['w3ft03_2ef_188',['w3ft03.f',['../w3ft03_8f.html',1,'']]], + ['w3ft05_189',['w3ft05',['../w3ft05_8f.html#affc8959bc48cc6dde6f3d7930a8b407f',1,'w3ft05.f']]], + ['w3ft05_2ef_190',['w3ft05.f',['../w3ft05_8f.html',1,'']]], + ['w3ft05v_191',['w3ft05v',['../w3ft05v_8f.html#a261ecb9571005278007fb4a6fbaf422a',1,'w3ft05v.f']]], + ['w3ft05v_2ef_192',['w3ft05v.f',['../w3ft05v_8f.html',1,'']]], + ['w3ft06_193',['w3ft06',['../w3ft06_8f.html#a9a0693ca342aef48beac578a24c71e76',1,'w3ft06.f']]], + ['w3ft06_2ef_194',['w3ft06.f',['../w3ft06_8f.html',1,'']]], + ['w3ft06v_195',['w3ft06v',['../w3ft06v_8f.html#aa210c5c31ea35f700b91ed8ce6ed1239',1,'w3ft06v.f']]], + ['w3ft06v_2ef_196',['w3ft06v.f',['../w3ft06v_8f.html',1,'']]], + ['w3ft07_197',['w3ft07',['../w3ft07_8f.html#aa7bd2293b69b72da36707f39093fb0dd',1,'w3ft07.f']]], + ['w3ft07_2ef_198',['w3ft07.f',['../w3ft07_8f.html',1,'']]], + ['w3ft08_199',['w3ft08',['../w3ft08_8f.html#ad0708ff0b06b672a0f6cff08ca6edba8',1,'w3ft08.f']]], + ['w3ft08_2ef_200',['w3ft08.f',['../w3ft08_8f.html',1,'']]], + ['w3ft09_201',['w3ft09',['../w3ft09_8f.html#a43204d3a7e4ec58530223d8561565f49',1,'w3ft09.f']]], + ['w3ft09_2ef_202',['w3ft09.f',['../w3ft09_8f.html',1,'']]], + ['w3ft10_203',['w3ft10',['../w3ft10_8f.html#a2d7a4e0d67089df728f1011ed937e6b6',1,'w3ft10.f']]], + ['w3ft10_2ef_204',['w3ft10.f',['../w3ft10_8f.html',1,'']]], + ['w3ft11_205',['w3ft11',['../w3ft11_8f.html#a011258b47ddeb5935f8e1ca9dca6bc28',1,'w3ft11.f']]], + ['w3ft11_2ef_206',['w3ft11.f',['../w3ft11_8f.html',1,'']]], + ['w3ft12_207',['w3ft12',['../w3ft12_8f.html#a34a66be43ef2429781f8346af0c4fbb1',1,'w3ft12.f']]], + ['w3ft12_2ef_208',['w3ft12.f',['../w3ft12_8f.html',1,'']]], + ['w3ft16_209',['w3ft16',['../w3ft16_8f.html#a4cfdf338d54decb5ebc703952f1b8258',1,'w3ft16.f']]], + ['w3ft16_2ef_210',['w3ft16.f',['../w3ft16_8f.html',1,'']]], + ['w3ft17_211',['w3ft17',['../w3ft17_8f.html#ad1ef28f2b547a1d73110bfea51bd92c3',1,'w3ft17.f']]], + ['w3ft17_2ef_212',['w3ft17.f',['../w3ft17_8f.html',1,'']]], + ['w3ft201_213',['w3ft201',['../w3ft201_8f.html#a4579b97893470f676e00332877d14a8a',1,'w3ft201.f']]], + ['w3ft201_2ef_214',['w3ft201.f',['../w3ft201_8f.html',1,'']]], + ['w3ft202_215',['w3ft202',['../w3ft202_8f.html#af3cc7cf79e145b0c0b05b77f18a6bc3e',1,'w3ft202.f']]], + ['w3ft202_2ef_216',['w3ft202.f',['../w3ft202_8f.html',1,'']]], + ['w3ft203_217',['w3ft203',['../w3ft203_8f.html#a33e491f31a1b02e212f2d38e938fff95',1,'w3ft203.f']]], + ['w3ft203_2ef_218',['w3ft203.f',['../w3ft203_8f.html',1,'']]], + ['w3ft204_219',['w3ft204',['../w3ft204_8f.html#a05244863fcba4deeecafd48af8f97435',1,'w3ft204.f']]], + ['w3ft204_2ef_220',['w3ft204.f',['../w3ft204_8f.html',1,'']]], + ['w3ft205_221',['w3ft205',['../w3ft205_8f.html#aeecada5cbfb2d7fee1e5a24f2e7b694e',1,'w3ft205.f']]], + ['w3ft205_2ef_222',['w3ft205.f',['../w3ft205_8f.html',1,'']]], + ['w3ft206_223',['w3ft206',['../w3ft206_8f.html#a11bbf4178c5e3290da90771366c95aaa',1,'w3ft206.f']]], + ['w3ft206_2ef_224',['w3ft206.f',['../w3ft206_8f.html',1,'']]], + ['w3ft207_225',['w3ft207',['../w3ft207_8f.html#a5be00916db03675c80fb3177a464f262',1,'w3ft207.f']]], + ['w3ft207_2ef_226',['w3ft207.f',['../w3ft207_8f.html',1,'']]], + ['w3ft208_227',['w3ft208',['../w3ft208_8f.html#a39df24e7c5c06b8b094f9baf7a637068',1,'w3ft208.f']]], + ['w3ft208_2ef_228',['w3ft208.f',['../w3ft208_8f.html',1,'']]], + ['w3ft209_229',['w3ft209',['../w3ft209_8f.html#a2482ea3acabfb84f5b4277e5d09c2d36',1,'w3ft209.f']]], + ['w3ft209_2ef_230',['w3ft209.f',['../w3ft209_8f.html',1,'']]], + ['w3ft21_231',['w3ft21',['../w3ft21_8f.html#a918182b6d42437b6657cf5d23d7d9240',1,'w3ft21.f']]], + ['w3ft21_2ef_232',['w3ft21.f',['../w3ft21_8f.html',1,'']]], + ['w3ft210_233',['w3ft210',['../w3ft210_8f.html#a262a8baf12c888d64c696bc3ba05be04',1,'w3ft210.f']]], + ['w3ft210_2ef_234',['w3ft210.f',['../w3ft210_8f.html',1,'']]], + ['w3ft211_235',['w3ft211',['../w3ft211_8f.html#aee78a998ceaf5a96225189c7e3be7262',1,'w3ft211.f']]], + ['w3ft211_2ef_236',['w3ft211.f',['../w3ft211_8f.html',1,'']]], + ['w3ft212_237',['w3ft212',['../w3ft212_8f.html#af275f1336203bfcbb465545daaa39fe5',1,'w3ft212.f']]], + ['w3ft212_2ef_238',['w3ft212.f',['../w3ft212_8f.html',1,'']]], + ['w3ft213_239',['w3ft213',['../w3ft213_8f.html#afd9acc707a0050ee144f922d2fd7f561',1,'w3ft213.f']]], + ['w3ft213_2ef_240',['w3ft213.f',['../w3ft213_8f.html',1,'']]], + ['w3ft214_241',['w3ft214',['../w3ft214_8f.html#a6f956d8742bb119f8ebf3e1eeb95d78b',1,'w3ft214.f']]], + ['w3ft214_2ef_242',['w3ft214.f',['../w3ft214_8f.html',1,'']]], + ['w3ft26_243',['w3ft26',['../w3ft26_8f.html#a225e7f8bb24f8c2878453792a88cee97',1,'w3ft26.f']]], + ['w3ft26_2ef_244',['w3ft26.f',['../w3ft26_8f.html',1,'']]], + ['w3ft32_245',['w3ft32',['../w3ft32_8f.html#a505bbee044cd5b9c1484ef45ded77d52',1,'w3ft32.f']]], + ['w3ft32_2ef_246',['w3ft32.f',['../w3ft32_8f.html',1,'']]], + ['w3ft33_247',['w3ft33',['../w3ft33_8f.html#a7c1d44437b786040567e37bcbc44765f',1,'w3ft33.f']]], + ['w3ft33_2ef_248',['w3ft33.f',['../w3ft33_8f.html',1,'']]], + ['w3ft38_249',['w3ft38',['../w3ft38_8f.html#a650ca7b1763805ead1c270d68d9a12c4',1,'w3ft38.f']]], + ['w3ft38_2ef_250',['w3ft38.f',['../w3ft38_8f.html',1,'']]], + ['w3ft39_251',['w3ft39',['../w3ft39_8f.html#aacebb1724c4f1396a70221ce78ed2fd5',1,'w3ft39.f']]], + ['w3ft39_2ef_252',['w3ft39.f',['../w3ft39_8f.html',1,'']]], + ['w3ft40_253',['w3ft40',['../w3ft40_8f.html#ac08e699870c05a14afcf7f90d27d8094',1,'w3ft40.f']]], + ['w3ft40_2ef_254',['w3ft40.f',['../w3ft40_8f.html',1,'']]], + ['w3ft41_255',['w3ft41',['../w3ft41_8f.html#a6f67ac7895427653fd746467ce92a2ad',1,'w3ft41.f']]], + ['w3ft41_2ef_256',['w3ft41.f',['../w3ft41_8f.html',1,'']]], + ['w3ft43v_257',['w3ft43v',['../w3ft43v_8f.html#a77e63a518c43c75ba9538080631c60fc',1,'w3ft43v.f']]], + ['w3ft43v_2ef_258',['w3ft43v.f',['../w3ft43v_8f.html',1,'']]], + ['w3kind_259',['w3kind',['../w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a',1,'w3kind.f']]], + ['w3kind_2ef_260',['w3kind.f',['../w3kind_8f.html',1,'']]], + ['w3locdat_261',['w3locdat',['../w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1',1,'w3locdat.f']]], + ['w3locdat_2ef_262',['w3locdat.f',['../w3locdat_8f.html',1,'']]], + ['w3miscan_263',['w3miscan',['../w3miscan_8f.html#aeeda29d4c214b97b0f8b9eb7f847f0db',1,'w3miscan.f']]], + ['w3miscan_2ef_264',['w3miscan.f',['../w3miscan_8f.html',1,'']]], + ['w3movdat_265',['w3movdat',['../w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339',1,'w3movdat.f']]], + ['w3movdat_2ef_266',['w3movdat.f',['../w3movdat_8f.html',1,'']]], + ['w3nogds_267',['w3nogds',['../w3nogds_8f.html#a5717adc8ddf26fc6a7fdcd02d60a8c5b',1,'w3nogds.f']]], + ['w3nogds_2ef_268',['w3nogds.f',['../w3nogds_8f.html',1,'']]], + ['w3pradat_269',['w3pradat',['../w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6',1,'w3pradat.f']]], + ['w3pradat_2ef_270',['w3pradat.f',['../w3pradat_8f.html',1,'']]], + ['w3reddat_271',['w3reddat',['../w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb',1,'w3reddat.f']]], + ['w3reddat_2ef_272',['w3reddat.f',['../w3reddat_8f.html',1,'']]], + ['w3tagb_273',['w3tagb',['../w3tagb_8f.html#a7e2cdefc989c6ec94d6366fe46e86b2f',1,'w3tagb.f']]], + ['w3tagb_2ef_274',['w3tagb.f',['../w3tagb_8f.html',1,'']]], + ['w3trnarg_275',['w3trnarg',['../w3trnarg_8f.html#aa93f106864755e8a7347b10d425e1764',1,'w3trnarg.f']]], + ['w3trnarg_2ef_276',['w3trnarg.f',['../w3trnarg_8f.html',1,'']]], + ['w3unpk77_277',['w3unpk77',['../w3unpk77_8f.html#a5f0f3e0fe1648c04ba5a47a13f405c4f',1,'w3unpk77.f']]], + ['w3unpk77_2ef_278',['w3unpk77.f',['../w3unpk77_8f.html',1,'']]], + ['w3utcdat_279',['w3utcdat',['../w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a',1,'w3utcdat.f']]], + ['w3utcdat_2ef_280',['w3utcdat.f',['../w3utcdat_8f.html',1,'']]], + ['w3valdat_281',['w3valdat',['../w3valdat_8f.html#a8a051a793c804f190e2da69fd1e16ebe',1,'w3valdat.f']]], + ['w3valdat_2ef_282',['w3valdat.f',['../w3valdat_8f.html',1,'']]], + ['w3ymdh4_283',['w3ymdh4',['../w3ymdh4_8f.html#a6ec6f6ef8936c7069feafafcb4ca333b',1,'w3ymdh4.f']]], + ['w3ymdh4_2ef_284',['w3ymdh4.f',['../w3ymdh4_8f.html',1,'']]], + ['water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_285',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['width_20for_20value_20of_20descriptor_286',['width for value of descriptor',['../w3fi88_8f.html#autotoc_md29',1,'- IWIDE1 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md30',1,'- IWIDE2 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md31',1,'- IWIDE3 - Bit width for value of descriptor']]], + ['wind_20profiler_20reports_287',['FORMAT FOR WIND PROFILER REPORTS',['../w3unpk77_8f.html#autotoc_md106',1,'']]], + ['wind_20profiler_20sfc_20data_20each_20level_20see_20word_2035_20above_288',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['wind_20profiler_20upper_20air_20data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_289',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_290',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['wmo_20headers_291',['WMO Headers',['../index.html#autotoc_md6',1,'']]], + ['word_2035_20above_292',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['word_2037_20above_293',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['writing_20grib1_20files_294',['Packing and Writing GRIB1 Files',['../index.html#autotoc_md3',1,'']]] +]; diff --git a/search/all_1a.js b/search/all_1a.js new file mode 100644 index 00000000..d979a386 --- /dev/null +++ b/search/all_1a.js @@ -0,0 +1,9 @@ +var searchData= +[ + ['xdopen_0',['xdopen',['../xdopen_8f.html#a941a5a5172e73a4d75553437ad275ece',1,'xdopen.f']]], + ['xdopen_2ef_1',['xdopen.f',['../xdopen_8f.html',1,'']]], + ['xmovex_2',['xmovex',['../xmovex_8f.html#a9966425854c3a77f854b1397051af333',1,'xmovex.f']]], + ['xmovex_2ef_3',['xmovex.f',['../xmovex_8f.html',1,'']]], + ['xstore_4',['xstore',['../xstore_8f.html#ad26510a638e68e3e62108516ffc9e5dc',1,'xstore.f']]], + ['xstore_2ef_5',['xstore.f',['../xstore_8f.html',1,'']]] +]; diff --git a/search/all_2.html b/search/all_2.html deleted file mode 100644 index 02cfffc2..00000000 --- a/search/all_2.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_2.js b/search/all_2.js index ada9618c..57297a6a 100644 --- a/search/all_2.js +++ b/search/all_2.js @@ -1,6 +1,4 @@ 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']]] + ['85_20subroutines_0',['Office-Note 85 Subroutines',['../index.html#autotoc_md18',1,'']]] ]; diff --git a/search/all_3.html b/search/all_3.html deleted file mode 100644 index 39767b85..00000000 --- a/search/all_3.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_3.js b/search/all_3.js index b1695262..94da44dc 100644 --- a/search/all_3.js +++ b/search/all_3.js @@ -1,9 +1,4 @@ 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,'']]] + ['9_20point_20smoother_0',['9-Point Smoother',['../index.html#autotoc_md19',1,'']]] ]; diff --git a/search/all_4.html b/search/all_4.html deleted file mode 100644 index fc40463c..00000000 --- a/search/all_4.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_4.js b/search/all_4.js index 17b16808..e2755b1a 100644 --- a/search/all_4.js +++ b/search/all_4.js @@ -1,64 +1,4 @@ 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,'']]] + ['_3a_0',[':',['../w3miscan_8f.html#autotoc_md86',1,'For LBRIT = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md88',1,'For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md87',1,'For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md85',1,'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)}:']]] ]; diff --git a/search/all_5.html b/search/all_5.html deleted file mode 100644 index 9dd9344b..00000000 --- a/search/all_5.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_5.js b/search/all_5.js index c52ef60c..885085dc 100644 --- a/search/all_5.js +++ b/search/all_5.js @@ -1,59 +1,26 @@ 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,'']]] + ['above_0',['above',['../w3unpk77_8f.html#autotoc_md107',1,'CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)'],['../w3unpk77_8f.html#autotoc_md108',1,'CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)']]], + ['aea_1',['aea',['../aea_8f.html#a7658132d90c68ca690e04be7d7ef6681',1,'aea.f']]], + ['aea_2ef_2',['aea.f',['../aea_8f.html',1,'']]], + ['ai081_3',['ai081',['../w3ai08_8f.html#a287605e7ec4319ea51164043fa1f9d73',1,'w3ai08.f']]], + ['ai082_4',['ai082',['../w3ai08_8f.html#a7dee92cbb450627df9b2dd8e3272abb8',1,'w3ai08.f']]], + ['ai082a_5',['ai082a',['../w3ai08_8f.html#a3df6d0ec86b78aea8c650696d0a0b21f',1,'w3ai08.f']]], + ['ai083_6',['ai083',['../w3ai08_8f.html#a45260b5f0f299ccea0ab0ac6f7be1fe5',1,'w3ai08.f']]], + ['ai084_7',['ai084',['../w3ai08_8f.html#af169362b14ce4c1f632823554fdc5495',1,'w3ai08.f']]], + ['ai085_8',['ai085',['../w3ai08_8f.html#a6a8d7e193514ad239d73c3bdd30a6576',1,'w3ai08.f']]], + ['ai085a_9',['ai085a',['../w3ai08_8f.html#acd0cb9edc0509005a5121d3fa2eb2037',1,'w3ai08.f']]], + ['ai087_10',['ai087',['../w3ai08_8f.html#a9c9abd1f5e91a16eb04e1e83bc436238',1,'w3ai08.f']]], + ['air_20data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_11',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_12',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['always_20returned_3a_13',['Always returned:',['../w3miscan_8f.html#autotoc_md84',1,'']]], + ['and_20byte_20manipulation_14',['Bit and Byte Manipulation',['../index.html#autotoc_md9',1,'']]], + ['and_20gbalg_20true_20input_20brightness_20temperature_20file_20_3a_15',['For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md88',1,'']]], + ['and_20nnalg_20true_20input_20brightness_20temperature_20file_20_3a_16',['For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md87',1,'']]], + ['and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_17',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['and_20test_20data_20set_3a_18',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['and_20writing_20grib1_20files_19',['Packing and Writing GRIB1 Files',['../index.html#autotoc_md3',1,'']]], + ['are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_20',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['arguments_21',['Command Line Arguments',['../index.html#autotoc_md13',1,'']]], + ['available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_22',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] ]; diff --git a/search/all_6.html b/search/all_6.html deleted file mode 100644 index f1e516d7..00000000 --- a/search/all_6.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_6.js b/search/all_6.js index c48be789..c3760aa5 100644 --- a/search/all_6.js +++ b/search/all_6.js @@ -1,23 +1,9 @@ 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,'']]] + ['below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_0',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['bit_20and_20byte_20manipulation_1',['Bit and Byte Manipulation',['../index.html#autotoc_md9',1,'']]], + ['bit_20width_20for_20value_20of_20descriptor_2',['bit width for value of descriptor',['../w3fi88_8f.html#autotoc_md29',1,'- IWIDE1 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md30',1,'- IWIDE2 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md31',1,'- IWIDE3 - Bit width for value of descriptor']]], + ['brightness_20temperature_20file_20_3a_3',['brightness temperature file :',['../w3miscan_8f.html#autotoc_md86',1,'For LBRIT = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md88',1,'For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md87',1,'For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):']]], + ['bucket_4',['bucket',['../summary_8c.html#ac30f918e4632256526a027a73c95da78',1,'summary.c']]], + ['byte_20manipulation_5',['Bit and Byte Manipulation',['../index.html#autotoc_md9',1,'']]] ]; diff --git a/search/all_7.html b/search/all_7.html deleted file mode 100644 index 8ddbf6c8..00000000 --- a/search/all_7.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_7.js b/search/all_7.js index 42ad4e67..b9c61b80 100644 --- a/search/all_7.js +++ b/search/all_7.js @@ -1,8 +1,14 @@ 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']]] + ['c01o29_0',['c01o29',['../iw3unp29_8f.html#a8f442c71c59f776fbf89cfed665f90a4',1,'iw3unp29.f']]], + ['category_2010_20wind_20profiler_20sfc_20data_20each_20level_20see_20word_2035_20above_1',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['category_2011_20wind_20profiler_20upper_20air_20data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_2',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['climo_3',['climo',['../w3fp06_8f.html#ae0b22fa11b8fe72122318b34fff3c384',1,'w3fp06.f']]], + ['cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_4',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['code_20instrumentation_5',['Code Instrumentation',['../index.html#autotoc_md14',1,'']]], + ['command_20line_20arguments_6',['Command Line Arguments',['../index.html#autotoc_md13',1,'']]], + ['contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_7',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['conversions_8',['Conversions',['../index.html#autotoc_md16',1,'']]], + ['coordinates_9',['Coordinates',['../index.html#autotoc_md17',1,'']]], + ['cputim_10',['cputim',['../summary_8c.html#a85f50c91b93171e345aa393946e62aa9',1,'summary.c']]] ]; diff --git a/search/all_8.html b/search/all_8.html deleted file mode 100644 index 83c55ae2..00000000 --- a/search/all_8.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_8.js b/search/all_8.js index e3773657..22d88a24 100644 --- a/search/all_8.js +++ b/search/all_8.js @@ -1,16 +1,17 @@ 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,'']]] + ['data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_0',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['data_20each_20level_20see_20word_2035_20above_1',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['data_20first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_2',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['data_20set_3a_3',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['date_20time_4',['Date/Time',['../index.html#autotoc_md10',1,'']]], + ['definition_20section_5',['Product Definition Section',['../index.html#autotoc_md4',1,'']]], + ['description_20of_20retrieval_20flags_3a_6',['Description of retrieval flags:',['../w3miscan_8f.html#autotoc_md92',1,'']]], + ['description_20of_20training_20and_20test_20data_20set_3a_7',['Description of training and test data set:',['../w3miscan_8f.html#autotoc_md91',1,'']]], + ['description_20section_8',['Grid Description Section',['../index.html#autotoc_md5',1,'']]], + ['descriptor_9',['descriptor',['../w3fi88_8f.html#autotoc_md29',1,'- IWIDE1 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md30',1,'- IWIDE2 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md31',1,'- IWIDE3 - Bit width for value of descriptor']]], + ['documentation_20for_20previous_20versions_10',['Documentation for Previous Versions',['../index.html#autotoc_md22',1,'']]], + ['dummy_20subroutines_11',['Dummy Subroutines',['../index.html#autotoc_md15',1,'']]], + ['dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_12',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_13',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] ]; diff --git a/search/all_9.html b/search/all_9.html deleted file mode 100644 index 1e263c13..00000000 --- a/search/all_9.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_9.js b/search/all_9.js index 6f34b09d..1b59c1a8 100644 --- a/search/all_9.js +++ b/search/all_9.js @@ -1,5 +1,13 @@ var searchData= [ - ['orders_177',['orders',['../orders_8f.html#a311c2453b613d259dc8e998f6d6aa944',1,'orders.f']]], - ['orders_2ef_178',['orders.f',['../orders_8f.html',1,'']]] + ['each_20level_20see_20word_2035_20above_0',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['each_20level_20see_20word_2037_20above_1',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['elapse_2',['elapse',['../summary_8c.html#a5c5678e05ce08da171d237db078d2c30',1,'summary.c']]], + ['end_5ftimer_3',['end_timer',['../summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22',1,'summary.c']]], + ['errexit_4',['errexit',['../errexit_8f.html#acdfe2a7413809994b26b8cbc335326d8',1,'errexit.f']]], + ['errexit_2ef_5',['errexit.f',['../errexit_8f.html',1,'']]], + ['errmsg_6',['errmsg',['../errmsg_8f.html#aa029ec617c24e6ff25756009764a254a',1,'errmsg.f']]], + ['errmsg_2ef_7',['errmsg.f',['../errmsg_8f.html',1,'']]], + ['error_20handling_8',['Error Handling',['../index.html#autotoc_md12',1,'']]], + ['except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_9',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] ]; diff --git a/search/all_a.html b/search/all_a.html deleted file mode 100644 index 3a6cac10..00000000 --- a/search/all_a.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_a.js b/search/all_a.js index 22dd8010..9c6bf1b9 100644 --- a/search/all_a.js +++ b/search/all_a.js @@ -1,20 +1,81 @@ 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,'']]] + ['fi631_0',['fi631',['../w3fi63_8f.html#a14d2f9e6b5fb3226561e037897d203c3',1,'w3fi63.f']]], + ['fi632_1',['fi632',['../w3fi63_8f.html#ab0e08b59a11033f2b30c4597a9442fb7',1,'w3fi63.f']]], + ['fi633_2',['fi633',['../w3fi63_8f.html#af02433c4bfbebcb7e7350ecbe7a61b81',1,'w3fi63.f']]], + ['fi634_3',['fi634',['../w3fi63_8f.html#af01235610bd0574b0f96269311efa508',1,'w3fi63.f']]], + ['fi634x_4',['fi634x',['../w3fi63_8f.html#a70c16565c866b4d5147e74b75c2c8ab3',1,'w3fi63.f']]], + ['fi635_5',['fi635',['../w3fi63_8f.html#ac10256c2bd0659630e821caf1c7ea44d',1,'w3fi63.f']]], + ['fi636_6',['fi636',['../w3fi63_8f.html#a88dd0a17439f927fd7d2d742c6f7e310',1,'w3fi63.f']]], + ['fi637_7',['fi637',['../w3fi63_8f.html#a52ab350d030e063ea1573ed81431d89e',1,'w3fi63.f']]], + ['fi6701_8',['fi6701',['../w3fi67_8f.html#a129e4781542ae749c23dc0a8961110ce',1,'w3fi67.f']]], + ['fi6702_9',['fi6702',['../w3fi67_8f.html#ae78fbedd62a4b1dc408e12a56f269d2e',1,'w3fi67.f']]], + ['fi6703_10',['fi6703',['../w3fi67_8f.html#aa4d148d976e36638d4499d8f1d24bb55',1,'w3fi67.f']]], + ['fi6704_11',['fi6704',['../w3fi67_8f.html#adf36991a9797826ba0e6af26bc047a22',1,'w3fi67.f']]], + ['fi6705_12',['fi6705',['../w3fi67_8f.html#a18dfd077ec80be85e96192fb2627ce38',1,'w3fi67.f']]], + ['fi6706_13',['fi6706',['../w3fi67_8f.html#a8f8a60d99fe5feb50640a40f9e869c08',1,'w3fi67.f']]], + ['fi6707_14',['fi6707',['../w3fi67_8f.html#a7657ec760cf65383ff753091f47be6ad',1,'w3fi67.f']]], + ['fi6708_15',['fi6708',['../w3fi67_8f.html#ad5e2e788e8e08893f9e72880bf462d07',1,'w3fi67.f']]], + ['fi6709_16',['fi6709',['../w3fi67_8f.html#a08e6952dbff783ad8064c86284b7338b',1,'w3fi67.f']]], + ['fi6710_17',['fi6710',['../w3fi67_8f.html#a7d30a98528a6c8cedc7b76c112862ea7',1,'w3fi67.f']]], + ['fi7501_18',['fi7501',['../w3fi75_8f.html#a32a2a7401b114f4fc586df3beba1740f',1,'w3fi75.f']]], + ['fi7502_19',['fi7502',['../w3fi75_8f.html#a7f98512b07c6233808c17cc41d39d34c',1,'w3fi75.f']]], + ['fi7503_20',['fi7503',['../w3fi75_8f.html#a3c5445cb4d0324926bf799220832227d',1,'w3fi75.f']]], + ['fi7505_21',['fi7505',['../w3fi75_8f.html#ab7aeef8ecb7b6e109f40de24ef9c466e',1,'w3fi75.f']]], + ['fi7513_22',['fi7513',['../w3fi75_8f.html#a080e563a3a2efeccaad9f91ac50f47e6',1,'w3fi75.f']]], + ['fi7516_23',['fi7516',['../w3fi75_8f.html#ae8e50fdcf98e231dd87ac0cac3407a23',1,'w3fi75.f']]], + ['fi7517_24',['fi7517',['../w3fi75_8f.html#a27b075bf60130cc76e5af83a4631df21',1,'w3fi75.f']]], + ['fi7518_25',['fi7518',['../w3fi75_8f.html#a229a0a1cdb13a4ac40e64396a062b0ab',1,'w3fi75.f']]], + ['fi7801_26',['fi7801',['../w3fi78_8f.html#a49815e08605c968b2fecd0dcbdabe304',1,'w3fi78.f']]], + ['fi7802_27',['fi7802',['../w3fi78_8f.html#af68f1a1dbbc01729e49a3f9b5d8ff62e',1,'w3fi78.f']]], + ['fi7803_28',['fi7803',['../w3fi78_8f.html#a9b9826d7fd1020f442d3d2a6c13a8239',1,'w3fi78.f']]], + ['fi7804_29',['fi7804',['../w3fi78_8f.html#a7f339d55f5933f4ab915a26098bb0e6e',1,'w3fi78.f']]], + ['fi7805_30',['fi7805',['../w3fi78_8f.html#ae8c42f7f8ccfa1726cb092ddd414c87a',1,'w3fi78.f']]], + ['fi7806_31',['fi7806',['../w3fi78_8f.html#a1ddd77e21e7b12f733c96d0d14092208',1,'w3fi78.f']]], + ['fi7807_32',['fi7807',['../w3fi78_8f.html#a4fe95ebc53f5ab1c5effb0a2cf9a1824',1,'w3fi78.f']]], + ['fi7808_33',['fi7808',['../w3fi78_8f.html#aab7538e5347a195c3eaae1a6bd035a5b',1,'w3fi78.f']]], + ['fi7809_34',['fi7809',['../w3fi78_8f.html#a3c7efbd2d1d06f5eadeb47912d1f1b88',1,'w3fi78.f']]], + ['fi7810_35',['fi7810',['../w3fi78_8f.html#aa7e94634a4e5b52d7a1fcc00d163180e',1,'w3fi78.f']]], + ['fi8501_36',['fi8501',['../w3fi85_8f.html#aa0c98da314499613dded4ed29bd67007',1,'w3fi85.f']]], + ['fi8502_37',['fi8502',['../w3fi85_8f.html#aeeb668d3a0405f063fc381f2b6fadf1e',1,'w3fi85.f']]], + ['fi8503_38',['fi8503',['../w3fi85_8f.html#a2288a2988c66dc8a5e48981f36ba4d38',1,'w3fi85.f']]], + ['fi8505_39',['fi8505',['../w3fi85_8f.html#a7a5c1f8087abe23f5aa386dcc6578b88',1,'w3fi85.f']]], + ['fi8506_40',['fi8506',['../w3fi85_8f.html#ab119068cfe66eb960c13bf8fcf3fdd18',1,'w3fi85.f']]], + ['fi8508_41',['fi8508',['../w3fi85_8f.html#ad0e2adc571586558aa11ae9c6220f19b',1,'w3fi85.f']]], + ['fi8509_42',['fi8509',['../w3fi85_8f.html#a2d4241923113f9d2570abb615cf6e6f9',1,'w3fi85.f']]], + ['fi8511_43',['fi8511',['../w3fi85_8f.html#a0ccde573a90a01365eb9e289a1d7cd65',1,'w3fi85.f']]], + ['fi8512_44',['fi8512',['../w3fi85_8f.html#ae31c2999baedbd4f7d4e8b6ee4bbd319',1,'w3fi85.f']]], + ['fi8513_45',['fi8513',['../w3fi85_8f.html#aff8d7f9b19c5927af493f76286da2192',1,'w3fi85.f']]], + ['fi8801_46',['fi8801',['../w3fi88_8f.html#a2fed25546da8e6018a9a7ef4f84da0d4',1,'w3fi88.f']]], + ['fi8802_47',['fi8802',['../w3fi88_8f.html#af7dc9d23ed351c8f1e385475ca39c737',1,'w3fi88.f']]], + ['fi8803_48',['fi8803',['../w3fi88_8f.html#a32eb617143dc3a3b49a1bbfef5960ed5',1,'w3fi88.f']]], + ['fi8804_49',['fi8804',['../w3fi88_8f.html#a17cd06929f54d9886b5d2a4677fcf8e1',1,'w3fi88.f']]], + ['fi8805_50',['fi8805',['../w3fi88_8f.html#a7c494f653f8c6abcffaea6a5918163ab',1,'w3fi88.f']]], + ['fi8806_51',['fi8806',['../w3fi88_8f.html#a9a711b7afb78b8e4e813d29a6d00343e',1,'w3fi88.f']]], + ['fi8807_52',['fi8807',['../w3fi88_8f.html#a8962db3dac489d800d8fc9cc13a0641b',1,'w3fi88.f']]], + ['fi8808_53',['fi8808',['../w3fi88_8f.html#a157d9ffb48327791c26dc6ddac872eda',1,'w3fi88.f']]], + ['fi8809_54',['fi8809',['../w3fi88_8f.html#ada2a564df0576afd8796b682c9c50b73',1,'w3fi88.f']]], + ['fi8810_55',['fi8810',['../w3fi88_8f.html#ade4fae47f4dcc026b6ffb64e03f55651',1,'w3fi88.f']]], + ['fi8811_56',['fi8811',['../w3fi88_8f.html#a09e14e694efd5f48b403ec0dfff7f63c',1,'w3fi88.f']]], + ['file_20_3a_57',['file :',['../w3miscan_8f.html#autotoc_md86',1,'For LBRIT = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md88',1,'For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md87',1,'For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):']]], + ['file_3a_20note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_58',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['files_59',['files',['../index.html#autotoc_md3',1,'Packing and Writing GRIB1 Files'],['../index.html#autotoc_md2',1,'Reading GRIB1 Files']]], + ['files_20for_20grib1_20files_60',['Index Files for GRIB1 Files',['../index.html#autotoc_md8',1,'']]], + ['first_20level_20is_20surface_20each_20level_20see_20word_2037_20above_61',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['flags_3a_62',['Description of retrieval flags:',['../w3miscan_8f.html#autotoc_md92',1,'']]], + ['fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_63',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['for_20grib1_20files_64',['Index Files for GRIB1 Files',['../index.html#autotoc_md8',1,'']]], + ['for_20lbrit_20true_20and_20gbalg_20true_20input_20brightness_20temperature_20file_20_3a_65',['For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md88',1,'']]], + ['for_20lbrit_20true_20and_20nnalg_20true_20input_20brightness_20temperature_20file_20_3a_66',['For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md87',1,'']]], + ['for_20lbrit_20true_20input_20brightness_20temperature_20file_20_3a_67',['For LBRIT = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md86',1,'']]], + ['for_20lprod_20true_20input_20products_20file_3a_20note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_68',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['for_20previous_20versions_69',['Documentation for Previous Versions',['../index.html#autotoc_md22',1,'']]], + ['for_20value_20of_20descriptor_70',['for value of descriptor',['../w3fi88_8f.html#autotoc_md29',1,'- IWIDE1 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md30',1,'- IWIDE2 - Bit width for value of descriptor'],['../w3fi88_8f.html#autotoc_md31',1,'- IWIDE3 - Bit width for value of descriptor']]], + ['for_20wind_20profiler_20reports_71',['FORMAT FOR WIND PROFILER REPORTS',['../w3unpk77_8f.html#autotoc_md106',1,'']]], + ['format_20for_20wind_20profiler_20reports_72',['FORMAT FOR WIND PROFILER REPORTS',['../w3unpk77_8f.html#autotoc_md106',1,'']]], + ['formats_73',['Reading Formats',['../index.html#autotoc_md7',1,'']]], + ['fparsei_74',['fparsei',['../fparsei_8f.html#a3f5e219fe4f03b8ccb20e4a7e5cbe832',1,'fparsei.f']]], + ['fparsei_2ef_75',['fparsei.f',['../fparsei_8f.html',1,'']]], + ['fparser_76',['fparser',['../fparser_8f.html#a614ee9606f217b051a2643684051df50',1,'fparser.f']]], + ['fparser_2ef_77',['fparser.f',['../fparser_8f.html',1,'']]] ]; diff --git a/search/all_b.html b/search/all_b.html deleted file mode 100644 index 130deb4e..00000000 --- a/search/all_b.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_b.js b/search/all_b.js index 76fcc223..1a8f1701 100644 --- a/search/all_b.js +++ b/search/all_b.js @@ -1,7 +1,63 @@ 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,'']]] + ['gbalg_20true_20input_20brightness_20temperature_20file_20_3a_0',['For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md88',1,'']]], + ['gbyte_1',['gbyte',['../gbyte_8f.html#ad8ac424552647ef42f4b054733f7b7b1',1,'gbyte.f']]], + ['gbyte_2ef_2',['gbyte.f',['../gbyte_8f.html',1,'']]], + ['gbytec_3',['gbytec',['../gbytec_8f.html#a43bd8d585799cf64eb09804156200064',1,'gbytec.f']]], + ['gbytec_2ef_4',['gbytec.f',['../gbytec_8f.html',1,'']]], + ['gbytes_5',['gbytes',['../gbytes_8f.html#a69f5a171f262da1e5a75f8a3810f4a82',1,'gbytes.f']]], + ['gbytes_2ef_6',['gbytes.f',['../gbytes_8f.html',1,'']]], + ['gbytesc_7',['gbytesc',['../gbytesc_8f.html#ad46c14caec87fa3f7d379d52fd8173bc',1,'gbytesc.f']]], + ['gbytesc_2ef_8',['gbytesc.f',['../gbytesc_8f.html',1,'']]], + ['getbit_9',['getbit',['../getbit_8f.html#a4d5fdf661844c7978d879e815608d8f0',1,'getbit.f']]], + ['getbit_2ef_10',['getbit.f',['../getbit_8f.html',1,'']]], + ['getgb_11',['getgb',['../getgb_8f.html#a98040aebeda65b55ed5c61d891e49ccf',1,'getgb.f']]], + ['getgb_2ef_12',['getgb.f',['../getgb_8f.html',1,'']]], + ['getgb1_13',['getgb1',['../getgb1_8f.html#a75aa7f2cd8878c41dc74056854b7bade',1,'getgb1.f']]], + ['getgb1_2ef_14',['getgb1.f',['../getgb1_8f.html',1,'']]], + ['getgb1r_15',['getgb1r',['../getgb1r_8f.html#a982dff5bb7d495326427c13fc654d7bb',1,'getgb1r.f']]], + ['getgb1r_2ef_16',['getgb1r.f',['../getgb1r_8f.html',1,'']]], + ['getgb1re_17',['getgb1re',['../getgb1re_8f.html#a58c5662f20d4a9ed1881394b25818565',1,'getgb1re.f']]], + ['getgb1re_2ef_18',['getgb1re.f',['../getgb1re_8f.html',1,'']]], + ['getgb1s_19',['getgb1s',['../getgb1s_8f.html#a5005a2bc8cb1f85d4ab9d897c73e8344',1,'getgb1s.f']]], + ['getgb1s_2ef_20',['getgb1s.f',['../getgb1s_8f.html',1,'']]], + ['getgbe_21',['getgbe',['../getgbe_8f.html#a131d2957b2e9ec6248fde892f7c82a01',1,'getgbe.f']]], + ['getgbe_2ef_22',['getgbe.f',['../getgbe_8f.html',1,'']]], + ['getgbeh_23',['getgbeh',['../getgbeh_8f.html#a880ba6974d201e5b100eda8d57251dbe',1,'getgbeh.f']]], + ['getgbeh_2ef_24',['getgbeh.f',['../getgbeh_8f.html',1,'']]], + ['getgbem_25',['getgbem',['../getgbem_8f.html#a52148a120ff1d3de25afdc5e7843c3e9',1,'getgbem.f']]], + ['getgbem_2ef_26',['getgbem.f',['../getgbem_8f.html',1,'']]], + ['getgbemh_27',['getgbemh',['../getgbemh_8f.html#a0cfcd2b0adf1907f29efd836cee13554',1,'getgbemh.f']]], + ['getgbemh_2ef_28',['getgbemh.f',['../getgbemh_8f.html',1,'']]], + ['getgbemn_29',['getgbemn',['../getgbemn_8f.html#aac1e0617524cfcef1651f92133f0c959',1,'getgbemn.f']]], + ['getgbemn_2ef_30',['getgbemn.f',['../getgbemn_8f.html',1,'']]], + ['getgbemp_31',['getgbemp',['../getgbemp_8f.html#a6f58776aeb1ed2f7e367bf4a01a1ad35',1,'getgbemp.f']]], + ['getgbemp_2ef_32',['getgbemp.f',['../getgbemp_8f.html',1,'']]], + ['getgbens_33',['getgbens',['../getgbens_8f.html#ac722b1ceb7e6a1af1c810c6c84434dcf',1,'getgbens.f']]], + ['getgbens_2ef_34',['getgbens.f',['../getgbens_8f.html',1,'']]], + ['getgbep_35',['getgbep',['../getgbep_8f.html#a9cbd8064fd141a45c07846c00931eab0',1,'getgbep.f']]], + ['getgbep_2ef_36',['getgbep.f',['../getgbep_8f.html',1,'']]], + ['getgbex_37',['getgbex',['../getgbex_8f.html#a6767d5f6b448d03e5f0a154bf7ed4090',1,'getgbex.f']]], + ['getgbex_2ef_38',['getgbex.f',['../getgbex_8f.html',1,'']]], + ['getgbexm_39',['getgbexm',['../getgbexm_8f.html#a660f20529705ee3731e6544771eedf4d',1,'getgbexm.f']]], + ['getgbexm_2ef_40',['getgbexm.f',['../getgbexm_8f.html',1,'']]], + ['getgbh_41',['getgbh',['../getgbh_8f.html#afe4595036ec84fc5868e9a0cdaa75a4c',1,'getgbh.f']]], + ['getgbh_2ef_42',['getgbh.f',['../getgbh_8f.html',1,'']]], + ['getgbm_43',['getgbm',['../getgbm_8f.html#a13e5b7b94989de452f47d062a917e8f9',1,'getgbm.f']]], + ['getgbm_2ef_44',['getgbm.f',['../getgbm_8f.html',1,'']]], + ['getgbmh_45',['getgbmh',['../getgbmh_8f.html#a0fe386a75ceff44f8914bc6d883c28f4',1,'getgbmh.f']]], + ['getgbmh_2ef_46',['getgbmh.f',['../getgbmh_8f.html',1,'']]], + ['getgbmp_47',['getgbmp',['../getgbmp_8f.html#a87989f48a32883137be354ba99db080b',1,'getgbmp.f']]], + ['getgbmp_2ef_48',['getgbmp.f',['../getgbmp_8f.html',1,'']]], + ['getgbp_49',['getgbp',['../getgbp_8f.html#ab997b10791523905a4bbd1c6d3d4d258',1,'getgbp.f']]], + ['getgbp_2ef_50',['getgbp.f',['../getgbp_8f.html',1,'']]], + ['getgi_51',['getgi',['../getgi_8f.html#acdad122216fa099a6a3a45cbf85ec1c2',1,'getgi.f']]], + ['getgi_2ef_52',['getgi.f',['../getgi_8f.html',1,'']]], + ['getgir_53',['getgir',['../getgir_8f.html#a1d594876e11881c99690d52b4091849f',1,'getgir.f']]], + ['getgir_2ef_54',['getgir.f',['../getgir_8f.html',1,'']]], + ['grib1_20files_55',['grib1 files',['../index.html#autotoc_md8',1,'Index Files for GRIB1 Files'],['../index.html#autotoc_md3',1,'Packing and Writing GRIB1 Files'],['../index.html#autotoc_md2',1,'Reading GRIB1 Files']]], + ['grib1_20parameters_56',['GRIB1 Parameters',['../index.html#autotoc_md1',1,'']]], + ['grid_20description_20section_57',['Grid Description Section',['../index.html#autotoc_md5',1,'']]], + ['gtbits_58',['gtbits',['../gtbits_8f.html#a0f90e24d4c196fe0bdf31f938110c704',1,'gtbits.f']]], + ['gtbits_2ef_59',['gtbits.f',['../gtbits_8f.html',1,'']]] ]; diff --git a/search/all_c.html b/search/all_c.html deleted file mode 100644 index 3dd5af06..00000000 --- a/search/all_c.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_c.js b/search/all_c.js index 61c8ef0f..719aea27 100644 --- a/search/all_c.js +++ b/search/all_c.js @@ -1,14 +1,7 @@ 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']]] + ['handling_0',['Error Handling',['../index.html#autotoc_md12',1,'']]], + ['headers_1',['WMO Headers',['../index.html#autotoc_md6',1,'']]], + ['history_20log_2',['Program History Log',['../w3fp10_8f.html#autotoc_md34',1,'']]], + ['history_20log_3a_3',['history log:',['../w3nogds_8f.html#autotoc_md100',1,'Program History Log:'],['../w3ft33_8f.html#autotoc_md75',1,'Program History Log:'],['../w3movdat_8f.html#autotoc_md99',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md98',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md97',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md96',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md95',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md94',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md93',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md90',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md89',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md83',1,'Program History Log:'],['../w3locdat_8f.html#autotoc_md82',1,'Program History Log:'],['../w3kind_8f.html#autotoc_md81',1,'Program History Log:'],['../w3ft43v_8f.html#autotoc_md80',1,'Program History Log:'],['../w3ft41_8f.html#autotoc_md79',1,'Program History Log:'],['../w3ft40_8f.html#autotoc_md78',1,'Program History Log:'],['../w3ft39_8f.html#autotoc_md77',1,'Program History Log:'],['../w3ft38_8f.html#autotoc_md76',1,'Program History Log:'],['../xstore_8f.html#autotoc_md124',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md114',1,'Program History Log:'],['../xmovex_8f.html#autotoc_md123',1,'Program History Log:'],['../xdopen_8f.html#autotoc_md122',1,'Program History Log:'],['../w3ymdh4_8f.html#autotoc_md121',1,'Program History Log:'],['../w3valdat_8f.html#autotoc_md120',1,'Program History Log:'],['../w3utcdat_8f.html#autotoc_md119',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md118',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md117',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md116',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md115',1,'Program History Log:'],['../w3pradat_8f.html#autotoc_md101',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md113',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md112',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md111',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md110',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md105',1,'Program History Log:'],['../w3trnarg_8f.html#autotoc_md104',1,'Program History Log:'],['../w3tagb_8f.html#autotoc_md103',1,'Program History Log:'],['../w3reddat_8f.html#autotoc_md102',1,'Program History Log:'],['../w3ft02_8f.html#autotoc_md44',1,'Program History Log:'],['../w3ft10_8f.html#autotoc_md53',1,'Program History Log:'],['../w3ft09_8f.html#autotoc_md52',1,'Program History Log:'],['../w3ft08_8f.html#autotoc_md51',1,'Program History Log:'],['../w3ft07_8f.html#autotoc_md50',1,'Program History Log:'],['../w3ft06v_8f.html#autotoc_md49',1,'Program History Log:'],['../w3ft06_8f.html#autotoc_md48',1,'Program History Log:'],['../w3ft05v_8f.html#autotoc_md47',1,'Program History Log:'],['../w3ft05_8f.html#autotoc_md46',1,'Program History Log:'],['../w3ft03_8f.html#autotoc_md45',1,'Program History Log:'],['../w3ft11_8f.html#autotoc_md54',1,'Program History Log:'],['../w3ft01_8f.html#autotoc_md43',1,'Program History Log:'],['../w3ft00_8f.html#autotoc_md42',1,'Program History Log:'],['../w3fs26_8f.html#autotoc_md41',1,'Program History Log:'],['../w3fs21_8f.html#autotoc_md40',1,'Program History Log:'],['../w3fs15_8f.html#autotoc_md39',1,'Program History Log:'],['../w3fs13_8f.html#autotoc_md38',1,'Program History Log:'],['../w3fp13_8f.html#autotoc_md37',1,'Program History Log:'],['../w3fp12_8f.html#autotoc_md36',1,'Program History Log:'],['../w3fp11_8f.html#autotoc_md35',1,'Program History Log:'],['../w3ft207_8f.html#autotoc_md64',1,'Program History Log:'],['../w3ft26_8f.html#autotoc_md73',1,'Program History Log:'],['../w3ft214_8f.html#autotoc_md72',1,'Program History Log:'],['../w3ft213_8f.html#autotoc_md71',1,'Program History Log:'],['../w3ft212_8f.html#autotoc_md70',1,'Program History Log:'],['../w3ft211_8f.html#autotoc_md69',1,'Program History Log:'],['../w3ft210_8f.html#autotoc_md68',1,'Program History Log:'],['../w3ft21_8f.html#autotoc_md67',1,'Program History Log:'],['../w3ft209_8f.html#autotoc_md66',1,'Program History Log:'],['../w3ft208_8f.html#autotoc_md65',1,'Program History Log:'],['../w3ft32_8f.html#autotoc_md74',1,'Program History Log:'],['../w3ft206_8f.html#autotoc_md63',1,'Program History Log:'],['../w3ft205_8f.html#autotoc_md62',1,'Program History Log:'],['../w3ft204_8f.html#autotoc_md61',1,'Program History Log:'],['../w3ft203_8f.html#autotoc_md60',1,'Program History Log:'],['../w3ft202_8f.html#autotoc_md59',1,'Program History Log:'],['../w3ft201_8f.html#autotoc_md58',1,'Program History Log:'],['../w3ft17_8f.html#autotoc_md57',1,'Program History Log:'],['../w3ft16_8f.html#autotoc_md56',1,'Program History Log:'],['../w3ft12_8f.html#autotoc_md55',1,'Program History Log:']]] ]; diff --git a/search/all_d.html b/search/all_d.html deleted file mode 100644 index af7f2f0f..00000000 --- a/search/all_d.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_d.js b/search/all_d.js index e18b4255..bb67a5ab 100644 --- a/search/all_d.js +++ b/search/all_d.js @@ -1,18 +1,33 @@ 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']]] + ['i01o29_0',['i01o29',['../iw3unp29_8f.html#a687b1ecdce871d1cf438f4fb2be95425',1,'iw3unp29.f']]], + ['i02o29_1',['i02o29',['../iw3unp29_8f.html#a83aa538c2e5a51c40a981974247d82c7',1,'iw3unp29.f']]], + ['i03o29_2',['i03o29',['../iw3unp29_8f.html#a291446927c470179df611e56fbc0ff6f',1,'iw3unp29.f']]], + ['i05o29_3',['i05o29',['../iw3unp29_8f.html#a5cb8ae5d00bc1141f789b08555083739',1,'iw3unp29.f']]], + ['idsdef_4',['idsdef',['../idsdef_8f.html#af116d5532c9d7b1e288ff59b1e75800c',1,'idsdef.f']]], + ['idsdef_2ef_5',['idsdef.f',['../idsdef_8f.html',1,'']]], + ['in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_6',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['index_20files_20for_20grib1_20files_7',['Index Files for GRIB1 Files',['../index.html#autotoc_md8',1,'']]], + ['input_20brightness_20temperature_20file_20_3a_8',['input brightness temperature file :',['../w3miscan_8f.html#autotoc_md86',1,'For LBRIT = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md88',1,'For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):'],['../w3miscan_8f.html#autotoc_md87',1,'For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):']]], + ['input_20products_20file_3a_20note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_9',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['instrument_10',['instrument',['../instrument_8f.html#a9e01b91f60a070be2a253f818d3d9732',1,'instrument.f']]], + ['instrument_2ef_11',['instrument.f',['../instrument_8f.html',1,'']]], + ['instrumentation_12',['Code Instrumentation',['../index.html#autotoc_md14',1,'']]], + ['introduction_13',['Introduction',['../index.html#autotoc_md0',1,'']]], + ['is_20surface_20each_20level_20see_20word_2037_20above_14',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['isrchne_15',['isrchne',['../isrchne_8f.html#a53cf06203460280eb4f894b66282b5fd',1,'isrchne.f']]], + ['isrchne_2ef_16',['isrchne.f',['../isrchne_8f.html',1,'']]], + ['iw3jdn_17',['iw3jdn',['../iw3jdn_8f.html#a2bb3a8c7551117779d303813bf2d7a2c',1,'iw3jdn.f']]], + ['iw3jdn_2ef_18',['iw3jdn.f',['../iw3jdn_8f.html',1,'']]], + ['iw3mat_19',['iw3mat',['../iw3mat_8f.html#aa53ca2552f7a06ad9141f16197b82fda',1,'iw3mat.f']]], + ['iw3mat_2ef_20',['iw3mat.f',['../iw3mat_8f.html',1,'']]], + ['iw3pds_21',['iw3pds',['../iw3pds_8f.html#ab3b0c789b44fe2ae4b1422c6beb6a4f1',1,'iw3pds.f']]], + ['iw3pds_2ef_22',['iw3pds.f',['../iw3pds_8f.html',1,'']]], + ['iw3unp29_23',['iw3unp29',['../iw3unp29_8f.html#a79f04733a38667022a957e6c1b9093b6',1,'iw3unp29.f']]], + ['iw3unp29_2ef_24',['iw3unp29.f',['../iw3unp29_8f.html',1,'']]], + ['iwide1_20bit_20width_20for_20value_20of_20descriptor_25',['- IWIDE1 - Bit width for value of descriptor',['../w3fi88_8f.html#autotoc_md29',1,'']]], + ['iwide2_20bit_20width_20for_20value_20of_20descriptor_26',['- IWIDE2 - Bit width for value of descriptor',['../w3fi88_8f.html#autotoc_md30',1,'']]], + ['iwide3_20bit_20width_20for_20value_20of_20descriptor_27',['- IWIDE3 - Bit width for value of descriptor',['../w3fi88_8f.html#autotoc_md31',1,'']]], + ['ixgb_28',['ixgb',['../ixgb_8f.html#ab80631a0d3fc8e1450bee116bc16e205',1,'ixgb.f']]], + ['ixgb_2ef_29',['ixgb.f',['../ixgb_8f.html',1,'']]] ]; diff --git a/search/all_e.html b/search/all_e.html deleted file mode 100644 index e25df423..00000000 --- a/search/all_e.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_e.js b/search/all_e.js index f7c357e4..66f43885 100644 --- a/search/all_e.js +++ b/search/all_e.js @@ -1,12 +1,17 @@ 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']]] + ['lbrit_20true_20and_20gbalg_20true_20input_20brightness_20temperature_20file_20_3a_0',['For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md88',1,'']]], + ['lbrit_20true_20and_20nnalg_20true_20input_20brightness_20temperature_20file_20_3a_1',['For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md87',1,'']]], + ['lbrit_20true_20input_20brightness_20temperature_20file_20_3a_2',['For LBRIT = TRUE (Input brightness temperature file):',['../w3miscan_8f.html#autotoc_md86',1,'']]], + ['lengds_3',['lengds',['../lengds_8f.html#af9d4e4b97b2d11e238290791aad2b989',1,'lengds.f']]], + ['lengds_2ef_4',['lengds.f',['../lengds_8f.html',1,'']]], + ['level_20is_20surface_20each_20level_20see_20word_2037_20above_5',['CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)',['../w3unpk77_8f.html#autotoc_md108',1,'']]], + ['level_20see_20word_2035_20above_6',['CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)',['../w3unpk77_8f.html#autotoc_md107',1,'']]], + ['line_20arguments_7',['Command Line Arguments',['../index.html#autotoc_md13',1,'']]], + ['line01_8',['line01',['../w3fp06_8f.html#ae1b5ebd2418050ad3b381f3f8d608bc6',1,'w3fp06.f']]], + ['line02_9',['line02',['../w3fp06_8f.html#ad054774044780f0d653a6e9e187b21f9',1,'w3fp06.f']]], + ['line03_10',['line03',['../w3fp06_8f.html#a947acf07eeb32317d7ff0c144682c8ad',1,'w3fp06.f']]], + ['log_11',['Program History Log',['../w3fp10_8f.html#autotoc_md34',1,'']]], + ['log_3a_12',['log:',['../w3miscan_8f.html#autotoc_md93',1,'Program History Log:'],['../w3movdat_8f.html#autotoc_md99',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md94',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md95',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md96',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md97',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md98',1,'Program History Log:'],['../w3ft39_8f.html#autotoc_md77',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md90',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md89',1,'Program History Log:'],['../w3miscan_8f.html#autotoc_md83',1,'Program History Log:'],['../w3locdat_8f.html#autotoc_md82',1,'Program History Log:'],['../w3kind_8f.html#autotoc_md81',1,'Program History Log:'],['../w3ft43v_8f.html#autotoc_md80',1,'Program History Log:'],['../w3ft41_8f.html#autotoc_md79',1,'Program History Log:'],['../w3ft40_8f.html#autotoc_md78',1,'Program History Log:'],['../xstore_8f.html#autotoc_md124',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md114',1,'Program History Log:'],['../xmovex_8f.html#autotoc_md123',1,'Program History Log:'],['../xdopen_8f.html#autotoc_md122',1,'Program History Log:'],['../w3ymdh4_8f.html#autotoc_md121',1,'Program History Log:'],['../w3valdat_8f.html#autotoc_md120',1,'Program History Log:'],['../w3utcdat_8f.html#autotoc_md119',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md118',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md117',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md116',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md115',1,'Program History Log:'],['../w3nogds_8f.html#autotoc_md100',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md113',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md112',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md111',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md110',1,'Program History Log:'],['../w3unpk77_8f.html#autotoc_md105',1,'Program History Log:'],['../w3trnarg_8f.html#autotoc_md104',1,'Program History Log:'],['../w3tagb_8f.html#autotoc_md103',1,'Program History Log:'],['../w3reddat_8f.html#autotoc_md102',1,'Program History Log:'],['../w3pradat_8f.html#autotoc_md101',1,'Program History Log:'],['../w3ft03_8f.html#autotoc_md45',1,'Program History Log:'],['../w3ft12_8f.html#autotoc_md55',1,'Program History Log:'],['../w3ft11_8f.html#autotoc_md54',1,'Program History Log:'],['../w3ft10_8f.html#autotoc_md53',1,'Program History Log:'],['../w3ft09_8f.html#autotoc_md52',1,'Program History Log:'],['../w3ft08_8f.html#autotoc_md51',1,'Program History Log:'],['../w3ft07_8f.html#autotoc_md50',1,'Program History Log:'],['../w3ft06v_8f.html#autotoc_md49',1,'Program History Log:'],['../w3ft06_8f.html#autotoc_md48',1,'Program History Log:'],['../w3ft05v_8f.html#autotoc_md47',1,'Program History Log:'],['../w3ft05_8f.html#autotoc_md46',1,'Program History Log:'],['../w3ft16_8f.html#autotoc_md56',1,'Program History Log:'],['../w3ft02_8f.html#autotoc_md44',1,'Program History Log:'],['../w3ft01_8f.html#autotoc_md43',1,'Program History Log:'],['../w3ft00_8f.html#autotoc_md42',1,'Program History Log:'],['../w3fs26_8f.html#autotoc_md41',1,'Program History Log:'],['../w3fs21_8f.html#autotoc_md40',1,'Program History Log:'],['../w3fs15_8f.html#autotoc_md39',1,'Program History Log:'],['../w3fs13_8f.html#autotoc_md38',1,'Program History Log:'],['../w3fp13_8f.html#autotoc_md37',1,'Program History Log:'],['../w3fp12_8f.html#autotoc_md36',1,'Program History Log:'],['../w3fp11_8f.html#autotoc_md35',1,'Program History Log:'],['../w3ft209_8f.html#autotoc_md66',1,'Program History Log:'],['../w3ft33_8f.html#autotoc_md75',1,'Program History Log:'],['../w3ft32_8f.html#autotoc_md74',1,'Program History Log:'],['../w3ft26_8f.html#autotoc_md73',1,'Program History Log:'],['../w3ft214_8f.html#autotoc_md72',1,'Program History Log:'],['../w3ft213_8f.html#autotoc_md71',1,'Program History Log:'],['../w3ft212_8f.html#autotoc_md70',1,'Program History Log:'],['../w3ft211_8f.html#autotoc_md69',1,'Program History Log:'],['../w3ft210_8f.html#autotoc_md68',1,'Program History Log:'],['../w3ft21_8f.html#autotoc_md67',1,'Program History Log:'],['../w3ft38_8f.html#autotoc_md76',1,'Program History Log:'],['../w3ft208_8f.html#autotoc_md65',1,'Program History Log:'],['../w3ft207_8f.html#autotoc_md64',1,'Program History Log:'],['../w3ft206_8f.html#autotoc_md63',1,'Program History Log:'],['../w3ft205_8f.html#autotoc_md62',1,'Program History Log:'],['../w3ft204_8f.html#autotoc_md61',1,'Program History Log:'],['../w3ft203_8f.html#autotoc_md60',1,'Program History Log:'],['../w3ft202_8f.html#autotoc_md59',1,'Program History Log:'],['../w3ft201_8f.html#autotoc_md58',1,'Program History Log:'],['../w3ft17_8f.html#autotoc_md57',1,'Program History Log:']]], + ['lprod_20true_20input_20products_20file_3a_20note_20all_20products_20below_20except_20sea_20surface_20temperature_20are_20available_20in_20the_20fnoc_20operational_20products_20data_20dump_20most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_13',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]] ]; diff --git a/search/all_f.html b/search/all_f.html deleted file mode 100644 index b23da6ce..00000000 --- a/search/all_f.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/all_f.js b/search/all_f.js index bcc8dd79..6af855c4 100644 --- a/search/all_f.js +++ b/search/all_f.js @@ -1,4 +1,20 @@ var searchData= [ - ['value1_235',['value1',['../w3fp06_8f.html#a857d20cd6a97ba1e266d803b2092670c',1,'w3fp06.f']]] + ['makgds_0',['makgds',['../makgds_8f90.html#a132c655a1a21b17ef23ee83108d7d4ac',1,'makgds.f90']]], + ['makgds_2ef90_1',['makgds.f90',['../makgds_8f90.html',1,'']]], + ['makwmo_2',['makwmo',['../makwmo_8f.html#acb3df40c99edbb45efe0d6b9a53af7de',1,'makwmo.f']]], + ['makwmo_2ef_3',['makwmo.f',['../makwmo_8f.html',1,'']]], + ['manipulation_4',['Bit and Byte Manipulation',['../index.html#autotoc_md9',1,'']]], + ['mersenne_5ftwister_5',['mersenne_twister',['../namespacemersenne__twister.html',1,'']]], + ['mersenne_5ftwister_2ef_6',['mersenne_twister.f',['../mersenne__twister_8f.html',1,'']]], + ['misc01_7',['misc01',['../w3miscan_8f.html#a77f06920ef1ce938ca29cc1ea7a18b56',1,'w3miscan.f']]], + ['misc04_8',['misc04',['../w3miscan_8f.html#af225a39ea11be14a9d8ae53744bd70b1',1,'w3miscan.f']]], + ['misc05_9',['misc05',['../w3miscan_8f.html#a6ebad02513c61fc41c51db9cf3bbaf7f',1,'w3miscan.f']]], + ['misc06_10',['misc06',['../w3miscan_8f.html#a2fbfd745aaa9ecb372ff2524a682ccae',1,'w3miscan.f']]], + ['misc10_11',['misc10',['../w3miscan_8f.html#ae39c3c17acb9b8b9e8865dce77e99179',1,'w3miscan.f']]], + ['mkfldsep_12',['mkfldsep',['../mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045',1,'mkfldsep.f']]], + ['mkfldsep_2ef_13',['mkfldsep.f',['../mkfldsep_8f.html',1,'']]], + ['most_20ncep_20products_20data_20dumps_20contain_20only_20wind_20speed_20total_20precipitable_20water_20cloud_20water_20and_20sea_20surface_20temperature_20all_20over_20ocean_20only_20_3a_14',['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)}:',['../w3miscan_8f.html#autotoc_md85',1,'']]], + ['mova2i_15',['mova2i',['../mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0',1,'mova2i.f']]], + ['mova2i_2ef_16',['mova2i.f',['../mova2i_8f.html',1,'']]] ]; diff --git a/search/classes_0.html b/search/classes_0.html deleted file mode 100644 index af8159ee..00000000 --- a/search/classes_0.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/classes_0.js b/search/classes_0.js index f1654397..ddf0c1ba 100644 --- a/search/classes_0.js +++ b/search/classes_0.js @@ -1,4 +1,8 @@ var searchData= [ - ['getarg_527',['getarg',['../interfaceargs__mod_1_1getarg.html',1,'args_mod']]] + ['random_5fgauss_0',['random_gauss',['../interfacemersenne__twister_1_1random__gauss.html',1,'mersenne_twister']]], + ['random_5findex_1',['random_index',['../interfacemersenne__twister_1_1random__index.html',1,'mersenne_twister']]], + ['random_5fnumber_2',['random_number',['../interfacemersenne__twister_1_1random__number.html',1,'mersenne_twister']]], + ['random_5fsetseed_3',['random_setseed',['../interfacemersenne__twister_1_1random__setseed.html',1,'mersenne_twister']]], + ['random_5fstat_4',['random_stat',['../structmersenne__twister_1_1random__stat.html',1,'mersenne_twister']]] ]; diff --git a/search/classes_1.html b/search/classes_1.html deleted file mode 100644 index 576e9168..00000000 --- a/search/classes_1.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/classes_1.js b/search/classes_1.js deleted file mode 100644 index 0119cb95..00000000 --- a/search/classes_1.js +++ /dev/null @@ -1,4 +0,0 @@ -var searchData= -[ - ['iargc_528',['iargc',['../interfaceargs__mod_1_1iargc.html',1,'args_mod']]] -]; diff --git a/search/close.png b/search/close.png deleted file mode 100644 index 9342d3dfeea7b7c4ee610987e717804b5a42ceb9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 273 zcmV+s0q*{ZP)4(RlMby96)VwnbG{ zbe&}^BDn7x>$<{ck4zAK-=nT;=hHG)kmplIF${xqm8db3oX6wT3bvp`TE@m0cg;b) zBuSL}5?N7O(iZLdAlz@)b)Rd~DnSsSX&P5qC`XwuFwcAYLC+d2>+1(8on;wpt8QIC X2MT$R4iQDd00000NkvXXu0mjfia~GN diff --git a/search/close.svg b/search/close.svg new file mode 100644 index 00000000..337d6cc1 --- /dev/null +++ b/search/close.svg @@ -0,0 +1,18 @@ + + + + + + diff --git a/search/files_0.html b/search/files_0.html deleted file mode 100644 index 9498842a..00000000 --- a/search/files_0.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_0.js b/search/files_0.js index 7fb0b6f5..ff97dc32 100644 --- a/search/files_0.js +++ b/search/files_0.js @@ -1,5 +1,4 @@ var searchData= [ - ['aea_2ef_531',['aea.f',['../aea_8f.html',1,'']]], - ['args_5fmod_2ef_532',['args_mod.f',['../args__mod_8f.html',1,'']]] + ['aea_2ef_0',['aea.f',['../aea_8f.html',1,'']]] ]; diff --git a/search/files_1.html b/search/files_1.html deleted file mode 100644 index 7050ef48..00000000 --- a/search/files_1.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_1.js b/search/files_1.js index 95b8d186..b20e9d43 100644 --- a/search/files_1.js +++ b/search/files_1.js @@ -1,5 +1,5 @@ var searchData= [ - ['errexit_2ef_533',['errexit.f',['../errexit_8f.html',1,'']]], - ['errmsg_2ef_534',['errmsg.f',['../errmsg_8f.html',1,'']]] + ['errexit_2ef_0',['errexit.f',['../errexit_8f.html',1,'']]], + ['errmsg_2ef_1',['errmsg.f',['../errmsg_8f.html',1,'']]] ]; diff --git a/search/files_2.html b/search/files_2.html deleted file mode 100644 index 497cdf5c..00000000 --- a/search/files_2.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_2.js b/search/files_2.js index 702a4e0a..b4ccaccc 100644 --- a/search/files_2.js +++ b/search/files_2.js @@ -1,5 +1,5 @@ var searchData= [ - ['fparsei_2ef_535',['fparsei.f',['../fparsei_8f.html',1,'']]], - ['fparser_2ef_536',['fparser.f',['../fparser_8f.html',1,'']]] + ['fparsei_2ef_0',['fparsei.f',['../fparsei_8f.html',1,'']]], + ['fparser_2ef_1',['fparser.f',['../fparser_8f.html',1,'']]] ]; diff --git a/search/files_3.html b/search/files_3.html deleted file mode 100644 index 1ba106b2..00000000 --- a/search/files_3.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_3.js b/search/files_3.js index 3af7b5f9..f127b310 100644 --- a/search/files_3.js +++ b/search/files_3.js @@ -1,31 +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,'']]] + ['gbyte_2ef_0',['gbyte.f',['../gbyte_8f.html',1,'']]], + ['gbytec_2ef_1',['gbytec.f',['../gbytec_8f.html',1,'']]], + ['gbytes_2ef_2',['gbytes.f',['../gbytes_8f.html',1,'']]], + ['gbytesc_2ef_3',['gbytesc.f',['../gbytesc_8f.html',1,'']]], + ['getbit_2ef_4',['getbit.f',['../getbit_8f.html',1,'']]], + ['getgb_2ef_5',['getgb.f',['../getgb_8f.html',1,'']]], + ['getgb1_2ef_6',['getgb1.f',['../getgb1_8f.html',1,'']]], + ['getgb1r_2ef_7',['getgb1r.f',['../getgb1r_8f.html',1,'']]], + ['getgb1re_2ef_8',['getgb1re.f',['../getgb1re_8f.html',1,'']]], + ['getgb1s_2ef_9',['getgb1s.f',['../getgb1s_8f.html',1,'']]], + ['getgbe_2ef_10',['getgbe.f',['../getgbe_8f.html',1,'']]], + ['getgbeh_2ef_11',['getgbeh.f',['../getgbeh_8f.html',1,'']]], + ['getgbem_2ef_12',['getgbem.f',['../getgbem_8f.html',1,'']]], + ['getgbemh_2ef_13',['getgbemh.f',['../getgbemh_8f.html',1,'']]], + ['getgbemn_2ef_14',['getgbemn.f',['../getgbemn_8f.html',1,'']]], + ['getgbemp_2ef_15',['getgbemp.f',['../getgbemp_8f.html',1,'']]], + ['getgbens_2ef_16',['getgbens.f',['../getgbens_8f.html',1,'']]], + ['getgbep_2ef_17',['getgbep.f',['../getgbep_8f.html',1,'']]], + ['getgbex_2ef_18',['getgbex.f',['../getgbex_8f.html',1,'']]], + ['getgbexm_2ef_19',['getgbexm.f',['../getgbexm_8f.html',1,'']]], + ['getgbh_2ef_20',['getgbh.f',['../getgbh_8f.html',1,'']]], + ['getgbm_2ef_21',['getgbm.f',['../getgbm_8f.html',1,'']]], + ['getgbmh_2ef_22',['getgbmh.f',['../getgbmh_8f.html',1,'']]], + ['getgbmp_2ef_23',['getgbmp.f',['../getgbmp_8f.html',1,'']]], + ['getgbp_2ef_24',['getgbp.f',['../getgbp_8f.html',1,'']]], + ['getgi_2ef_25',['getgi.f',['../getgi_8f.html',1,'']]], + ['getgir_2ef_26',['getgir.f',['../getgir_8f.html',1,'']]], + ['gtbits_2ef_27',['gtbits.f',['../gtbits_8f.html',1,'']]] ]; diff --git a/search/files_4.html b/search/files_4.html deleted file mode 100644 index 753b7b10..00000000 --- a/search/files_4.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_4.js b/search/files_4.js index dfdc5b94..eb66e251 100644 --- a/search/files_4.js +++ b/search/files_4.js @@ -1,11 +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,'']]] + ['idsdef_2ef_0',['idsdef.f',['../idsdef_8f.html',1,'']]], + ['instrument_2ef_1',['instrument.f',['../instrument_8f.html',1,'']]], + ['isrchne_2ef_2',['isrchne.f',['../isrchne_8f.html',1,'']]], + ['iw3jdn_2ef_3',['iw3jdn.f',['../iw3jdn_8f.html',1,'']]], + ['iw3mat_2ef_4',['iw3mat.f',['../iw3mat_8f.html',1,'']]], + ['iw3pds_2ef_5',['iw3pds.f',['../iw3pds_8f.html',1,'']]], + ['iw3unp29_2ef_6',['iw3unp29.f',['../iw3unp29_8f.html',1,'']]], + ['ixgb_2ef_7',['ixgb.f',['../ixgb_8f.html',1,'']]] ]; diff --git a/search/files_5.html b/search/files_5.html deleted file mode 100644 index 7b6affd7..00000000 --- a/search/files_5.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_5.js b/search/files_5.js index 8ed3ba37..6f4eabc9 100644 --- a/search/files_5.js +++ b/search/files_5.js @@ -1,4 +1,4 @@ var searchData= [ - ['lengds_2ef_573',['lengds.f',['../lengds_8f.html',1,'']]] + ['lengds_2ef_0',['lengds.f',['../lengds_8f.html',1,'']]] ]; diff --git a/search/files_6.html b/search/files_6.html deleted file mode 100644 index 802ebf71..00000000 --- a/search/files_6.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_6.js b/search/files_6.js index 54257dc3..5150afad 100644 --- a/search/files_6.js +++ b/search/files_6.js @@ -1,7 +1,8 @@ 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,'']]] + ['makgds_2ef90_0',['makgds.f90',['../makgds_8f90.html',1,'']]], + ['makwmo_2ef_1',['makwmo.f',['../makwmo_8f.html',1,'']]], + ['mersenne_5ftwister_2ef_2',['mersenne_twister.f',['../mersenne__twister_8f.html',1,'']]], + ['mkfldsep_2ef_3',['mkfldsep.f',['../mkfldsep_8f.html',1,'']]], + ['mova2i_2ef_4',['mova2i.f',['../mova2i_8f.html',1,'']]] ]; diff --git a/search/files_7.html b/search/files_7.html deleted file mode 100644 index 365e6484..00000000 --- a/search/files_7.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_7.js b/search/files_7.js index 4bcd3224..91b0ae2b 100644 --- a/search/files_7.js +++ b/search/files_7.js @@ -1,4 +1,4 @@ var searchData= [ - ['orders_2ef_578',['orders.f',['../orders_8f.html',1,'']]] + ['orders_2ef_0',['orders.f',['../orders_8f.html',1,'']]] ]; diff --git a/search/files_8.html b/search/files_8.html deleted file mode 100644 index 3df0f2fa..00000000 --- a/search/files_8.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_8.js b/search/files_8.js index f290deba..d7fa5d7f 100644 --- a/search/files_8.js +++ b/search/files_8.js @@ -1,11 +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,'']]] + ['pdsens_2ef_0',['pdsens.f',['../pdsens_8f.html',1,'']]], + ['pdseup_2ef_1',['pdseup.f',['../pdseup_8f.html',1,'']]], + ['putgb_2ef_2',['putgb.f',['../putgb_8f.html',1,'']]], + ['putgbe_2ef_3',['putgbe.f',['../putgbe_8f.html',1,'']]], + ['putgben_2ef_4',['putgben.f',['../putgben_8f.html',1,'']]], + ['putgbens_2ef_5',['putgbens.f',['../putgbens_8f.html',1,'']]], + ['putgbex_2ef_6',['putgbex.f',['../putgbex_8f.html',1,'']]], + ['putgbn_2ef_7',['putgbn.f',['../putgbn_8f.html',1,'']]] ]; diff --git a/search/files_9.html b/search/files_9.html deleted file mode 100644 index 52f8b6c0..00000000 --- a/search/files_9.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_9.js b/search/files_9.js index 59b3242a..94c7bf70 100644 --- a/search/files_9.js +++ b/search/files_9.js @@ -1,4 +1,4 @@ var searchData= [ - ['q9ie32_2ef_587',['q9ie32.f',['../q9ie32_8f.html',1,'']]] + ['q9ie32_2ef_0',['q9ie32.f',['../q9ie32_8f.html',1,'']]] ]; diff --git a/search/files_a.html b/search/files_a.html deleted file mode 100644 index 11d4c117..00000000 --- a/search/files_a.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_a.js b/search/files_a.js index 3995dd2c..4c74f75b 100644 --- a/search/files_a.js +++ b/search/files_a.js @@ -1,4 +1,4 @@ var searchData= [ - ['r63w72_2ef_588',['r63w72.f',['../r63w72_8f.html',1,'']]] + ['r63w72_2ef_0',['r63w72.f',['../r63w72_8f.html',1,'']]] ]; diff --git a/search/files_b.html b/search/files_b.html deleted file mode 100644 index 9fc83436..00000000 --- a/search/files_b.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_b.js b/search/files_b.js index 30635ac0..673b508e 100644 --- a/search/files_b.js +++ b/search/files_b.js @@ -1,9 +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,'']]] + ['sbyte_2ef_0',['sbyte.f',['../sbyte_8f.html',1,'']]], + ['sbytec_2ef_1',['sbytec.f',['../sbytec_8f.html',1,'']]], + ['sbytes_2ef_2',['sbytes.f',['../sbytes_8f.html',1,'']]], + ['sbytesc_2ef_3',['sbytesc.f',['../sbytesc_8f.html',1,'']]], + ['skgb_2ef_4',['skgb.f',['../skgb_8f.html',1,'']]], + ['summary_2ec_5',['summary.c',['../summary_8c.html',1,'']]] ]; diff --git a/search/files_c.html b/search/files_c.html deleted file mode 100644 index c266b4c2..00000000 --- a/search/files_c.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_c.js b/search/files_c.js index a0b920d9..4884ce81 100644 --- a/search/files_c.js +++ b/search/files_c.js @@ -1,147 +1,145 @@ 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,'']]] + ['w3ai00_2ef_0',['w3ai00.f',['../w3ai00_8f.html',1,'']]], + ['w3ai01_2ef_1',['w3ai01.f',['../w3ai01_8f.html',1,'']]], + ['w3ai08_2ef_2',['w3ai08.f',['../w3ai08_8f.html',1,'']]], + ['w3ai15_2ef_3',['w3ai15.f',['../w3ai15_8f.html',1,'']]], + ['w3ai18_2ef_4',['w3ai18.f',['../w3ai18_8f.html',1,'']]], + ['w3ai19_2ef_5',['w3ai19.f',['../w3ai19_8f.html',1,'']]], + ['w3ai24_2ef_6',['w3ai24.f',['../w3ai24_8f.html',1,'']]], + ['w3ai38_2ef_7',['w3ai38.f',['../w3ai38_8f.html',1,'']]], + ['w3ai39_2ef_8',['w3ai39.f',['../w3ai39_8f.html',1,'']]], + ['w3ai40_2ef_9',['w3ai40.f',['../w3ai40_8f.html',1,'']]], + ['w3ai41_2ef_10',['w3ai41.f',['../w3ai41_8f.html',1,'']]], + ['w3aq15_2ef_11',['w3aq15.f',['../w3aq15_8f.html',1,'']]], + ['w3as00_2ef_12',['w3as00.f',['../w3as00_8f.html',1,'']]], + ['w3ctzdat_2ef_13',['w3ctzdat.f',['../w3ctzdat_8f.html',1,'']]], + ['w3difdat_2ef_14',['w3difdat.f',['../w3difdat_8f.html',1,'']]], + ['w3doxdat_2ef_15',['w3doxdat.f',['../w3doxdat_8f.html',1,'']]], + ['w3fa01_2ef_16',['w3fa01.f',['../w3fa01_8f.html',1,'']]], + ['w3fa03_2ef_17',['w3fa03.f',['../w3fa03_8f.html',1,'']]], + ['w3fa03v_2ef_18',['w3fa03v.f',['../w3fa03v_8f.html',1,'']]], + ['w3fa04_2ef_19',['w3fa04.f',['../w3fa04_8f.html',1,'']]], + ['w3fa06_2ef_20',['w3fa06.f',['../w3fa06_8f.html',1,'']]], + ['w3fa09_2ef_21',['w3fa09.f',['../w3fa09_8f.html',1,'']]], + ['w3fa11_2ef_22',['w3fa11.f',['../w3fa11_8f.html',1,'']]], + ['w3fa12_2ef_23',['w3fa12.f',['../w3fa12_8f.html',1,'']]], + ['w3fa13_2ef_24',['w3fa13.f',['../w3fa13_8f.html',1,'']]], + ['w3fb00_2ef_25',['w3fb00.f',['../w3fb00_8f.html',1,'']]], + ['w3fb01_2ef_26',['w3fb01.f',['../w3fb01_8f.html',1,'']]], + ['w3fb02_2ef_27',['w3fb02.f',['../w3fb02_8f.html',1,'']]], + ['w3fb03_2ef_28',['w3fb03.f',['../w3fb03_8f.html',1,'']]], + ['w3fb04_2ef_29',['w3fb04.f',['../w3fb04_8f.html',1,'']]], + ['w3fb05_2ef_30',['w3fb05.f',['../w3fb05_8f.html',1,'']]], + ['w3fb06_2ef_31',['w3fb06.f',['../w3fb06_8f.html',1,'']]], + ['w3fb07_2ef_32',['w3fb07.f',['../w3fb07_8f.html',1,'']]], + ['w3fb08_2ef_33',['w3fb08.f',['../w3fb08_8f.html',1,'']]], + ['w3fb09_2ef_34',['w3fb09.f',['../w3fb09_8f.html',1,'']]], + ['w3fb10_2ef_35',['w3fb10.f',['../w3fb10_8f.html',1,'']]], + ['w3fb11_2ef_36',['w3fb11.f',['../w3fb11_8f.html',1,'']]], + ['w3fb12_2ef_37',['w3fb12.f',['../w3fb12_8f.html',1,'']]], + ['w3fc02_2ef_38',['w3fc02.f',['../w3fc02_8f.html',1,'']]], + ['w3fc05_2ef_39',['w3fc05.f',['../w3fc05_8f.html',1,'']]], + ['w3fc06_2ef_40',['w3fc06.f',['../w3fc06_8f.html',1,'']]], + ['w3fc07_2ef_41',['w3fc07.f',['../w3fc07_8f.html',1,'']]], + ['w3fc08_2ef_42',['w3fc08.f',['../w3fc08_8f.html',1,'']]], + ['w3fi01_2ef_43',['w3fi01.f',['../w3fi01_8f.html',1,'']]], + ['w3fi02_2ef_44',['w3fi02.f',['../w3fi02_8f.html',1,'']]], + ['w3fi03_2ef_45',['w3fi03.f',['../w3fi03_8f.html',1,'']]], + ['w3fi04_2ef_46',['w3fi04.f',['../w3fi04_8f.html',1,'']]], + ['w3fi18_2ef_47',['w3fi18.f',['../w3fi18_8f.html',1,'']]], + ['w3fi19_2ef_48',['w3fi19.f',['../w3fi19_8f.html',1,'']]], + ['w3fi20_2ef_49',['w3fi20.f',['../w3fi20_8f.html',1,'']]], + ['w3fi32_2ef_50',['w3fi32.f',['../w3fi32_8f.html',1,'']]], + ['w3fi47_2ef_51',['w3fi47.f',['../w3fi47_8f.html',1,'']]], + ['w3fi48_2ef_52',['w3fi48.f',['../w3fi48_8f.html',1,'']]], + ['w3fi58_2ef_53',['w3fi58.f',['../w3fi58_8f.html',1,'']]], + ['w3fi59_2ef_54',['w3fi59.f',['../w3fi59_8f.html',1,'']]], + ['w3fi61_2ef_55',['w3fi61.f',['../w3fi61_8f.html',1,'']]], + ['w3fi62_2ef_56',['w3fi62.f',['../w3fi62_8f.html',1,'']]], + ['w3fi63_2ef_57',['w3fi63.f',['../w3fi63_8f.html',1,'']]], + ['w3fi64_2ef_58',['w3fi64.f',['../w3fi64_8f.html',1,'']]], + ['w3fi65_2ef_59',['w3fi65.f',['../w3fi65_8f.html',1,'']]], + ['w3fi66_2ef_60',['w3fi66.f',['../w3fi66_8f.html',1,'']]], + ['w3fi67_2ef_61',['w3fi67.f',['../w3fi67_8f.html',1,'']]], + ['w3fi68_2ef_62',['w3fi68.f',['../w3fi68_8f.html',1,'']]], + ['w3fi69_2ef_63',['w3fi69.f',['../w3fi69_8f.html',1,'']]], + ['w3fi70_2ef_64',['w3fi70.f',['../w3fi70_8f.html',1,'']]], + ['w3fi71_2ef_65',['w3fi71.f',['../w3fi71_8f.html',1,'']]], + ['w3fi72_2ef_66',['w3fi72.f',['../w3fi72_8f.html',1,'']]], + ['w3fi73_2ef_67',['w3fi73.f',['../w3fi73_8f.html',1,'']]], + ['w3fi74_2ef_68',['w3fi74.f',['../w3fi74_8f.html',1,'']]], + ['w3fi75_2ef_69',['w3fi75.f',['../w3fi75_8f.html',1,'']]], + ['w3fi76_2ef_70',['w3fi76.f',['../w3fi76_8f.html',1,'']]], + ['w3fi78_2ef_71',['w3fi78.f',['../w3fi78_8f.html',1,'']]], + ['w3fi82_2ef_72',['w3fi82.f',['../w3fi82_8f.html',1,'']]], + ['w3fi83_2ef_73',['w3fi83.f',['../w3fi83_8f.html',1,'']]], + ['w3fi85_2ef_74',['w3fi85.f',['../w3fi85_8f.html',1,'']]], + ['w3fi88_2ef_75',['w3fi88.f',['../w3fi88_8f.html',1,'']]], + ['w3fi92_2ef_76',['w3fi92.f',['../w3fi92_8f.html',1,'']]], + ['w3fm07_2ef_77',['w3fm07.f',['../w3fm07_8f.html',1,'']]], + ['w3fm08_2ef_78',['w3fm08.f',['../w3fm08_8f.html',1,'']]], + ['w3fp04_2ef_79',['w3fp04.f',['../w3fp04_8f.html',1,'']]], + ['w3fp05_2ef_80',['w3fp05.f',['../w3fp05_8f.html',1,'']]], + ['w3fp06_2ef_81',['w3fp06.f',['../w3fp06_8f.html',1,'']]], + ['w3fp10_2ef_82',['w3fp10.f',['../w3fp10_8f.html',1,'']]], + ['w3fp11_2ef_83',['w3fp11.f',['../w3fp11_8f.html',1,'']]], + ['w3fp12_2ef_84',['w3fp12.f',['../w3fp12_8f.html',1,'']]], + ['w3fp13_2ef_85',['w3fp13.f',['../w3fp13_8f.html',1,'']]], + ['w3fs13_2ef_86',['w3fs13.f',['../w3fs13_8f.html',1,'']]], + ['w3fs15_2ef_87',['w3fs15.f',['../w3fs15_8f.html',1,'']]], + ['w3fs21_2ef_88',['w3fs21.f',['../w3fs21_8f.html',1,'']]], + ['w3fs26_2ef_89',['w3fs26.f',['../w3fs26_8f.html',1,'']]], + ['w3ft00_2ef_90',['w3ft00.f',['../w3ft00_8f.html',1,'']]], + ['w3ft01_2ef_91',['w3ft01.f',['../w3ft01_8f.html',1,'']]], + ['w3ft02_2ef_92',['w3ft02.f',['../w3ft02_8f.html',1,'']]], + ['w3ft03_2ef_93',['w3ft03.f',['../w3ft03_8f.html',1,'']]], + ['w3ft05_2ef_94',['w3ft05.f',['../w3ft05_8f.html',1,'']]], + ['w3ft05v_2ef_95',['w3ft05v.f',['../w3ft05v_8f.html',1,'']]], + ['w3ft06_2ef_96',['w3ft06.f',['../w3ft06_8f.html',1,'']]], + ['w3ft06v_2ef_97',['w3ft06v.f',['../w3ft06v_8f.html',1,'']]], + ['w3ft07_2ef_98',['w3ft07.f',['../w3ft07_8f.html',1,'']]], + ['w3ft08_2ef_99',['w3ft08.f',['../w3ft08_8f.html',1,'']]], + ['w3ft09_2ef_100',['w3ft09.f',['../w3ft09_8f.html',1,'']]], + ['w3ft10_2ef_101',['w3ft10.f',['../w3ft10_8f.html',1,'']]], + ['w3ft11_2ef_102',['w3ft11.f',['../w3ft11_8f.html',1,'']]], + ['w3ft12_2ef_103',['w3ft12.f',['../w3ft12_8f.html',1,'']]], + ['w3ft16_2ef_104',['w3ft16.f',['../w3ft16_8f.html',1,'']]], + ['w3ft17_2ef_105',['w3ft17.f',['../w3ft17_8f.html',1,'']]], + ['w3ft201_2ef_106',['w3ft201.f',['../w3ft201_8f.html',1,'']]], + ['w3ft202_2ef_107',['w3ft202.f',['../w3ft202_8f.html',1,'']]], + ['w3ft203_2ef_108',['w3ft203.f',['../w3ft203_8f.html',1,'']]], + ['w3ft204_2ef_109',['w3ft204.f',['../w3ft204_8f.html',1,'']]], + ['w3ft205_2ef_110',['w3ft205.f',['../w3ft205_8f.html',1,'']]], + ['w3ft206_2ef_111',['w3ft206.f',['../w3ft206_8f.html',1,'']]], + ['w3ft207_2ef_112',['w3ft207.f',['../w3ft207_8f.html',1,'']]], + ['w3ft208_2ef_113',['w3ft208.f',['../w3ft208_8f.html',1,'']]], + ['w3ft209_2ef_114',['w3ft209.f',['../w3ft209_8f.html',1,'']]], + ['w3ft21_2ef_115',['w3ft21.f',['../w3ft21_8f.html',1,'']]], + ['w3ft210_2ef_116',['w3ft210.f',['../w3ft210_8f.html',1,'']]], + ['w3ft211_2ef_117',['w3ft211.f',['../w3ft211_8f.html',1,'']]], + ['w3ft212_2ef_118',['w3ft212.f',['../w3ft212_8f.html',1,'']]], + ['w3ft213_2ef_119',['w3ft213.f',['../w3ft213_8f.html',1,'']]], + ['w3ft214_2ef_120',['w3ft214.f',['../w3ft214_8f.html',1,'']]], + ['w3ft26_2ef_121',['w3ft26.f',['../w3ft26_8f.html',1,'']]], + ['w3ft32_2ef_122',['w3ft32.f',['../w3ft32_8f.html',1,'']]], + ['w3ft33_2ef_123',['w3ft33.f',['../w3ft33_8f.html',1,'']]], + ['w3ft38_2ef_124',['w3ft38.f',['../w3ft38_8f.html',1,'']]], + ['w3ft39_2ef_125',['w3ft39.f',['../w3ft39_8f.html',1,'']]], + ['w3ft40_2ef_126',['w3ft40.f',['../w3ft40_8f.html',1,'']]], + ['w3ft41_2ef_127',['w3ft41.f',['../w3ft41_8f.html',1,'']]], + ['w3ft43v_2ef_128',['w3ft43v.f',['../w3ft43v_8f.html',1,'']]], + ['w3kind_2ef_129',['w3kind.f',['../w3kind_8f.html',1,'']]], + ['w3locdat_2ef_130',['w3locdat.f',['../w3locdat_8f.html',1,'']]], + ['w3miscan_2ef_131',['w3miscan.f',['../w3miscan_8f.html',1,'']]], + ['w3movdat_2ef_132',['w3movdat.f',['../w3movdat_8f.html',1,'']]], + ['w3nogds_2ef_133',['w3nogds.f',['../w3nogds_8f.html',1,'']]], + ['w3pradat_2ef_134',['w3pradat.f',['../w3pradat_8f.html',1,'']]], + ['w3reddat_2ef_135',['w3reddat.f',['../w3reddat_8f.html',1,'']]], + ['w3tagb_2ef_136',['w3tagb.f',['../w3tagb_8f.html',1,'']]], + ['w3trnarg_2ef_137',['w3trnarg.f',['../w3trnarg_8f.html',1,'']]], + ['w3unpk77_2ef_138',['w3unpk77.f',['../w3unpk77_8f.html',1,'']]], + ['w3utcdat_2ef_139',['w3utcdat.f',['../w3utcdat_8f.html',1,'']]], + ['w3valdat_2ef_140',['w3valdat.f',['../w3valdat_8f.html',1,'']]], + ['w3ymdh4_2ef_141',['w3ymdh4.f',['../w3ymdh4_8f.html',1,'']]] ]; diff --git a/search/files_d.html b/search/files_d.html deleted file mode 100644 index d2ca3c1c..00000000 --- a/search/files_d.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/files_d.js b/search/files_d.js index 7aee38ae..fcf24186 100644 --- a/search/files_d.js +++ b/search/files_d.js @@ -1,6 +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,'']]] + ['xdopen_2ef_0',['xdopen.f',['../xdopen_8f.html',1,'']]], + ['xmovex_2ef_1',['xmovex.f',['../xmovex_8f.html',1,'']]], + ['xstore_2ef_2',['xstore.f',['../xstore_8f.html',1,'']]] ]; diff --git a/search/functions_0.html b/search/functions_0.html deleted file mode 100644 index eb4c5014..00000000 --- a/search/functions_0.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_0.js b/search/functions_0.js index 20e18052..bfc17862 100644 --- a/search/functions_0.js +++ b/search/functions_0.js @@ -1,12 +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']]] + ['aea_0',['aea',['../aea_8f.html#a7658132d90c68ca690e04be7d7ef6681',1,'aea.f']]], + ['ai081_1',['ai081',['../w3ai08_8f.html#a287605e7ec4319ea51164043fa1f9d73',1,'w3ai08.f']]], + ['ai082_2',['ai082',['../w3ai08_8f.html#a7dee92cbb450627df9b2dd8e3272abb8',1,'w3ai08.f']]], + ['ai082a_3',['ai082a',['../w3ai08_8f.html#a3df6d0ec86b78aea8c650696d0a0b21f',1,'w3ai08.f']]], + ['ai083_4',['ai083',['../w3ai08_8f.html#a45260b5f0f299ccea0ab0ac6f7be1fe5',1,'w3ai08.f']]], + ['ai084_5',['ai084',['../w3ai08_8f.html#af169362b14ce4c1f632823554fdc5495',1,'w3ai08.f']]], + ['ai085_6',['ai085',['../w3ai08_8f.html#a6a8d7e193514ad239d73c3bdd30a6576',1,'w3ai08.f']]], + ['ai085a_7',['ai085a',['../w3ai08_8f.html#acd0cb9edc0509005a5121d3fa2eb2037',1,'w3ai08.f']]], + ['ai087_8',['ai087',['../w3ai08_8f.html#a9c9abd1f5e91a16eb04e1e83bc436238',1,'w3ai08.f']]] ]; diff --git a/search/functions_1.html b/search/functions_1.html deleted file mode 100644 index ef4088b8..00000000 --- a/search/functions_1.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_1.js b/search/functions_1.js index 3fbc4341..21098014 100644 --- a/search/functions_1.js +++ b/search/functions_1.js @@ -1,4 +1,4 @@ var searchData= [ - ['bucket_751',['bucket',['../summary_8c.html#ac30f918e4632256526a027a73c95da78',1,'summary.c']]] + ['bucket_0',['bucket',['../summary_8c.html#ac30f918e4632256526a027a73c95da78',1,'summary.c']]] ]; diff --git a/search/functions_10.html b/search/functions_10.html deleted file mode 100644 index 1bdc1257..00000000 --- a/search/functions_10.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_10.js b/search/functions_10.js index 0fd2f36e..e84744c7 100644 --- a/search/functions_10.js +++ b/search/functions_10.js @@ -1,144 +1,145 @@ 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']]] + ['w3ai00_0',['w3ai00',['../w3ai00_8f.html#a4d10019a7be86cad3b458e0556e0e163',1,'w3ai00.f']]], + ['w3ai01_1',['w3ai01',['../w3ai01_8f.html#acf00ef759655cd640826064c50ff8150',1,'w3ai01.f']]], + ['w3ai08_2',['w3ai08',['../w3ai08_8f.html#a50cf1edd8615abf5c6c333c8e790f63b',1,'w3ai08.f']]], + ['w3ai15_3',['w3ai15',['../w3ai15_8f.html#a87103805250f46624e11c6ca8c68b288',1,'w3ai15.f']]], + ['w3ai18_4',['w3ai18',['../w3ai18_8f.html#ac5f95206395f4fff1f8bd74dbc8a929b',1,'w3ai18.f']]], + ['w3ai19_5',['w3ai19',['../w3ai19_8f.html#a94ced6d87294ca6fd467da8e9b42096b',1,'w3ai19.f']]], + ['w3ai24_6',['w3ai24',['../w3ai24_8f.html#a2468984a80b3966028f29391a091a5f2',1,'w3ai24.f']]], + ['w3ai38_7',['w3ai38',['../w3ai38_8f.html#a8c31fa8b048696a5616b55d753eaa193',1,'w3ai38.f']]], + ['w3ai39_8',['w3ai39',['../w3ai39_8f.html#a997a055c96092bc5e8ef74404f34e7d1',1,'w3ai39.f']]], + ['w3ai40_9',['w3ai40',['../w3ai40_8f.html#a1675f4f6d98aa6a1cdbd2dfd44975d49',1,'w3ai40.f']]], + ['w3ai41_10',['w3ai41',['../w3ai41_8f.html#aec7a595f5288838e71110ac432b1777a',1,'w3ai41.f']]], + ['w3aq15_11',['w3aq15',['../w3aq15_8f.html#ab150670d527c962c1deceb71106976d3',1,'w3aq15.f']]], + ['w3as00_12',['w3as00',['../w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529',1,'w3as00.f']]], + ['w3ctzdat_13',['w3ctzdat',['../w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035',1,'w3ctzdat.f']]], + ['w3difdat_14',['w3difdat',['../w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1',1,'w3difdat.f']]], + ['w3doxdat_15',['w3doxdat',['../w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29',1,'w3doxdat.f']]], + ['w3fa01_16',['w3fa01',['../w3fa01_8f.html#acfc4149f4d9c51d2b5b9888e932f25ca',1,'w3fa01.f']]], + ['w3fa03_17',['w3fa03',['../w3fa03_8f.html#a7805169d794ed38e57ba685e6241100b',1,'w3fa03.f']]], + ['w3fa03v_18',['w3fa03v',['../w3fa03v_8f.html#a1d2407e31446d6ad82bd4e2cb61fd5d7',1,'w3fa03v.f']]], + ['w3fa04_19',['w3fa04',['../w3fa04_8f.html#a4a761802c7bab00ea502026e7863696a',1,'w3fa04.f']]], + ['w3fa06_20',['w3fa06',['../w3fa06_8f.html#aa82de1d1f83eb4bb981a5d00b3af13d9',1,'w3fa06.f']]], + ['w3fa09_21',['w3fa09',['../w3fa09_8f.html#ad48026b7570d6ac92635a6719c9ef7fc',1,'w3fa09.f']]], + ['w3fa11_22',['w3fa11',['../w3fa11_8f.html#ac97049f63913eb3d3af50c42ea29e5c8',1,'w3fa11.f']]], + ['w3fa12_23',['w3fa12',['../w3fa12_8f.html#a74541e2949ce81754b1e8a4a3e5d946f',1,'w3fa12.f']]], + ['w3fa13_24',['w3fa13',['../w3fa13_8f.html#a79f0efdd8bbc53bd8c9bc9aa7ca41811',1,'w3fa13.f']]], + ['w3fb00_25',['w3fb00',['../w3fb00_8f.html#a6581d211e674bcbe0b47b2d65e9aa671',1,'w3fb00.f']]], + ['w3fb01_26',['w3fb01',['../w3fb01_8f.html#aa4c5be625575219d8a21032e55ffa8ee',1,'w3fb01.f']]], + ['w3fb02_27',['w3fb02',['../w3fb02_8f.html#aac12d4245442631655101f5a4b27aee2',1,'w3fb02.f']]], + ['w3fb03_28',['w3fb03',['../w3fb03_8f.html#ac1d9e9f45629c503bd63fc3e79c9892f',1,'w3fb03.f']]], + ['w3fb04_29',['w3fb04',['../w3fb04_8f.html#a3b860b612d62a311ec6364ed3ecd1ca4',1,'w3fb04.f']]], + ['w3fb05_30',['w3fb05',['../w3fb05_8f.html#af9bdbe0b4b7576494298c0b50c6fc837',1,'w3fb05.f']]], + ['w3fb06_31',['w3fb06',['../w3fb06_8f.html#a3b5622b466f3ab1d3c93b8c3606ca27e',1,'w3fb06.f']]], + ['w3fb07_32',['w3fb07',['../w3fb07_8f.html#ade62d0dff4cb419a076b295780e1c72d',1,'w3fb07.f']]], + ['w3fb08_33',['w3fb08',['../w3fb08_8f.html#a404c4d79a1162f49baeebe63f6a48174',1,'w3fb08.f']]], + ['w3fb09_34',['w3fb09',['../w3fb09_8f.html#a97d39b7d805646bba7510a3fb06f44ea',1,'w3fb09.f']]], + ['w3fb10_35',['w3fb10',['../w3fb10_8f.html#aa7f39f82090c39b8550d19c26fd6e88c',1,'w3fb10.f']]], + ['w3fb11_36',['w3fb11',['../w3fb11_8f.html#a44ef8585ec761cc4360677a4043ae836',1,'w3fb11.f']]], + ['w3fb12_37',['w3fb12',['../w3fb12_8f.html#a8bf51dda5c2baf121134274723c79837',1,'w3fb12.f']]], + ['w3fc02_38',['w3fc02',['../w3fc02_8f.html#aa7ac60b61ee09def3c2e5e2005575cec',1,'w3fc02.f']]], + ['w3fc05_39',['w3fc05',['../w3fc05_8f.html#a2a855302ae772a201af2e93a43fa8fa9',1,'w3fc05.f']]], + ['w3fc06_40',['w3fc06',['../w3fc06_8f.html#a4b85830235c80e0c007cba0d9e2ad7e8',1,'w3fc06.f']]], + ['w3fc07_41',['w3fc07',['../w3fc07_8f.html#aa2d422861395fb930f4a8a235beb5735',1,'w3fc07.f']]], + ['w3fc08_42',['w3fc08',['../w3fc08_8f.html#ab866267da1ef5f8208ffe29f38590b6c',1,'w3fc08.f']]], + ['w3fi01_43',['w3fi01',['../w3fi01_8f.html#a45d73d5e35cbbe33e27e9c11684ca491',1,'w3fi01.f']]], + ['w3fi02_44',['w3fi02',['../w3fi02_8f.html#a12ce6be899705cebb27f675ef5413353',1,'w3fi02.f']]], + ['w3fi03_45',['w3fi03',['../w3fi03_8f.html#a875772e1917cd6bf73eabca330b517de',1,'w3fi03.f']]], + ['w3fi04_46',['w3fi04',['../w3fi04_8f.html#a59af48612285f36dae46e14f4b0e8a85',1,'w3fi04.f']]], + ['w3fi18_47',['w3fi18',['../w3fi18_8f.html#a3e60fdacb75b639d8e444a507259a1e8',1,'w3fi18.f']]], + ['w3fi19_48',['w3fi19',['../w3fi19_8f.html#a4eef5192d8f6d23e77aef025680f7b9f',1,'w3fi19.f']]], + ['w3fi20_49',['w3fi20',['../w3fi20_8f.html#a9ef932fe706763c5afc84a7c6797d415',1,'w3fi20.f']]], + ['w3fi32_50',['w3fi32',['../w3fi32_8f.html#a873077240f7b409fea74580cbfed49ad',1,'w3fi32.f']]], + ['w3fi47_51',['w3fi47',['../w3fi47_8f.html#ad09c2b7b4957ee75a21baf17c5ae091e',1,'w3fi47.f']]], + ['w3fi48_52',['w3fi48',['../w3fi48_8f.html#aa7d2d23ac60388b262bab73ae8434fa7',1,'w3fi48.f']]], + ['w3fi58_53',['w3fi58',['../w3fi58_8f.html#a06f9456e4b8c768f7853a0ba42a5d229',1,'w3fi58.f']]], + ['w3fi59_54',['w3fi59',['../w3fi59_8f.html#a8bba5bf7656b97615cfba69962c91782',1,'w3fi59.f']]], + ['w3fi61_55',['w3fi61',['../w3fi61_8f.html#a41ee42bf0040218d3bf0c0c93716d12e',1,'w3fi61.f']]], + ['w3fi62_56',['w3fi62',['../w3fi62_8f.html#a462db56d61f6d13371250087a22255ba',1,'w3fi62.f']]], + ['w3fi63_57',['w3fi63',['../w3fi63_8f.html#a275d433403624224a7d8da4c820b76be',1,'w3fi63.f']]], + ['w3fi64_58',['w3fi64',['../w3fi64_8f.html#a450e698ffae06cf8cd67fa9e2ba1170b',1,'w3fi64.f']]], + ['w3fi65_59',['w3fi65',['../w3fi65_8f.html#a04761367dc026f8b456d586d186a5dcd',1,'w3fi65.f']]], + ['w3fi66_60',['w3fi66',['../w3fi66_8f.html#a70b3cfe6a9e87d8b292ab36cfe2e2811',1,'w3fi66.f']]], + ['w3fi67_61',['w3fi67',['../w3fi67_8f.html#a7d0d66e5c01d134ce7e40a6f33e54479',1,'w3fi67.f']]], + ['w3fi68_62',['w3fi68',['../w3fi68_8f.html#a2f103e1d1423a0f9585dbf5633758020',1,'w3fi68.f']]], + ['w3fi69_63',['w3fi69',['../w3fi69_8f.html#adcd583a43ddb3397dc354375ca5e5029',1,'w3fi69.f']]], + ['w3fi70_64',['w3fi70',['../w3fi70_8f.html#a804adf2c4205b93098ecb914e5a138ba',1,'w3fi70.f']]], + ['w3fi71_65',['w3fi71',['../w3fi71_8f.html#a8093d4ae34f8b50308c55b03ac0d2fc6',1,'w3fi71.f']]], + ['w3fi72_66',['w3fi72',['../w3fi72_8f.html#af30a5edb120c0910beafc6ee46d1f3c5',1,'w3fi72.f']]], + ['w3fi73_67',['w3fi73',['../w3fi73_8f.html#a16b6fc47763b666ed5c21c66e65b0e63',1,'w3fi73.f']]], + ['w3fi74_68',['w3fi74',['../w3fi74_8f.html#aa3d0542b1282d44be47215d59e6432dc',1,'w3fi74.f']]], + ['w3fi75_69',['w3fi75',['../w3fi75_8f.html#a132bfbd67589901d6bb5e9f72158a0c7',1,'w3fi75.f']]], + ['w3fi76_70',['w3fi76',['../w3fi76_8f.html#a9e0b5a3150bf143ba67534a40ddd2856',1,'w3fi76.f']]], + ['w3fi78_71',['w3fi78',['../w3fi78_8f.html#a412826ca598b211d75aa9b6be5dded05',1,'w3fi78.f']]], + ['w3fi82_72',['w3fi82',['../w3fi82_8f.html#a2888bd47bed9eb1b569ec4da20dcac8f',1,'w3fi82.f']]], + ['w3fi83_73',['w3fi83',['../w3fi83_8f.html#ad0372b453a84bbc270281245dbbad82e',1,'w3fi83.f']]], + ['w3fi85_74',['w3fi85',['../w3fi85_8f.html#a7b304c2b30215c2ca98f21d240d4335b',1,'w3fi85.f']]], + ['w3fi88_75',['w3fi88',['../w3fi88_8f.html#a597695a8a2eff93db31a2eb8d93ee8c9',1,'w3fi88.f']]], + ['w3fi92_76',['w3fi92',['../w3fi92_8f.html#a22888b37a35c7f9abe63dc5cfd743422',1,'w3fi92.f']]], + ['w3fm07_77',['w3fm07',['../w3fm07_8f.html#a03b3b4ebb95c829f88ab858b6709cfd7',1,'w3fm07.f']]], + ['w3fm08_78',['w3fm08',['../w3fm08_8f.html#ad5d5a454e8cdb3623fbdb0df3f44cbcc',1,'w3fm08.f']]], + ['w3fp04_79',['w3fp04',['../w3fp04_8f.html#abc0c89b29a4a74847841e5a1aa35e49a',1,'w3fp04.f']]], + ['w3fp05_80',['w3fp05',['../w3fp05_8f.html#a68a1b19e798523cddbf6d2aea4751362',1,'w3fp05.f']]], + ['w3fp06_81',['w3fp06',['../w3fp06_8f.html#a1912bdef4280f84618d529e4764ac8fd',1,'w3fp06.f']]], + ['w3fp10_82',['w3fp10',['../w3fp10_8f.html#ac8a2ca08aafc6e727d1e230f69c734b3',1,'w3fp10.f']]], + ['w3fp11_83',['w3fp11',['../w3fp11_8f.html#a0e68dda36ce06180df15d26525b8ad92',1,'w3fp11.f']]], + ['w3fp12_84',['w3fp12',['../w3fp12_8f.html#a90be3644f6c4c935c450a188c5193a3f',1,'w3fp12.f']]], + ['w3fp13_85',['w3fp13',['../w3fp13_8f.html#a56fb62646dcbbcea7bc5239ed6f5acd0',1,'w3fp13.f']]], + ['w3fs13_86',['w3fs13',['../w3fs13_8f.html#afce9c885afc9ee59a125a8db9ac5eee4',1,'w3fs13.f']]], + ['w3fs15_87',['w3fs15',['../w3fs15_8f.html#a6503e7b854ccc60e9a09e85413642c5c',1,'w3fs15.f']]], + ['w3fs21_88',['w3fs21',['../w3fs21_8f.html#a9af93d7745b3435c83155476954bbdb8',1,'w3fs21.f']]], + ['w3fs26_89',['w3fs26',['../w3fs26_8f.html#a907c7328b67cac5929274519593d6c83',1,'w3fs26.f']]], + ['w3ft00_90',['w3ft00',['../w3ft00_8f.html#aef914a82466f1f10f20f61a45cba4676',1,'w3ft00.f']]], + ['w3ft01_91',['w3ft01',['../w3ft01_8f.html#a526211242588a42f89dd5f724dd78595',1,'w3ft01.f']]], + ['w3ft02_92',['w3ft02',['../w3ft02_8f.html#a2d66a49241741b516a284f7881c67160',1,'w3ft02.f']]], + ['w3ft03_93',['w3ft03',['../w3ft03_8f.html#a4989ac1555e50285597693623cc2da77',1,'w3ft03.f']]], + ['w3ft05_94',['w3ft05',['../w3ft05_8f.html#affc8959bc48cc6dde6f3d7930a8b407f',1,'w3ft05.f']]], + ['w3ft05v_95',['w3ft05v',['../w3ft05v_8f.html#a261ecb9571005278007fb4a6fbaf422a',1,'w3ft05v.f']]], + ['w3ft06_96',['w3ft06',['../w3ft06_8f.html#a9a0693ca342aef48beac578a24c71e76',1,'w3ft06.f']]], + ['w3ft06v_97',['w3ft06v',['../w3ft06v_8f.html#aa210c5c31ea35f700b91ed8ce6ed1239',1,'w3ft06v.f']]], + ['w3ft07_98',['w3ft07',['../w3ft07_8f.html#aa7bd2293b69b72da36707f39093fb0dd',1,'w3ft07.f']]], + ['w3ft08_99',['w3ft08',['../w3ft08_8f.html#ad0708ff0b06b672a0f6cff08ca6edba8',1,'w3ft08.f']]], + ['w3ft09_100',['w3ft09',['../w3ft09_8f.html#a43204d3a7e4ec58530223d8561565f49',1,'w3ft09.f']]], + ['w3ft10_101',['w3ft10',['../w3ft10_8f.html#a2d7a4e0d67089df728f1011ed937e6b6',1,'w3ft10.f']]], + ['w3ft11_102',['w3ft11',['../w3ft11_8f.html#a011258b47ddeb5935f8e1ca9dca6bc28',1,'w3ft11.f']]], + ['w3ft12_103',['w3ft12',['../w3ft12_8f.html#a34a66be43ef2429781f8346af0c4fbb1',1,'w3ft12.f']]], + ['w3ft16_104',['w3ft16',['../w3ft16_8f.html#a4cfdf338d54decb5ebc703952f1b8258',1,'w3ft16.f']]], + ['w3ft17_105',['w3ft17',['../w3ft17_8f.html#ad1ef28f2b547a1d73110bfea51bd92c3',1,'w3ft17.f']]], + ['w3ft201_106',['w3ft201',['../w3ft201_8f.html#a4579b97893470f676e00332877d14a8a',1,'w3ft201.f']]], + ['w3ft202_107',['w3ft202',['../w3ft202_8f.html#af3cc7cf79e145b0c0b05b77f18a6bc3e',1,'w3ft202.f']]], + ['w3ft203_108',['w3ft203',['../w3ft203_8f.html#a33e491f31a1b02e212f2d38e938fff95',1,'w3ft203.f']]], + ['w3ft204_109',['w3ft204',['../w3ft204_8f.html#a05244863fcba4deeecafd48af8f97435',1,'w3ft204.f']]], + ['w3ft205_110',['w3ft205',['../w3ft205_8f.html#aeecada5cbfb2d7fee1e5a24f2e7b694e',1,'w3ft205.f']]], + ['w3ft206_111',['w3ft206',['../w3ft206_8f.html#a11bbf4178c5e3290da90771366c95aaa',1,'w3ft206.f']]], + ['w3ft207_112',['w3ft207',['../w3ft207_8f.html#a5be00916db03675c80fb3177a464f262',1,'w3ft207.f']]], + ['w3ft208_113',['w3ft208',['../w3ft208_8f.html#a39df24e7c5c06b8b094f9baf7a637068',1,'w3ft208.f']]], + ['w3ft209_114',['w3ft209',['../w3ft209_8f.html#a2482ea3acabfb84f5b4277e5d09c2d36',1,'w3ft209.f']]], + ['w3ft21_115',['w3ft21',['../w3ft21_8f.html#a918182b6d42437b6657cf5d23d7d9240',1,'w3ft21.f']]], + ['w3ft210_116',['w3ft210',['../w3ft210_8f.html#a262a8baf12c888d64c696bc3ba05be04',1,'w3ft210.f']]], + ['w3ft211_117',['w3ft211',['../w3ft211_8f.html#aee78a998ceaf5a96225189c7e3be7262',1,'w3ft211.f']]], + ['w3ft212_118',['w3ft212',['../w3ft212_8f.html#af275f1336203bfcbb465545daaa39fe5',1,'w3ft212.f']]], + ['w3ft213_119',['w3ft213',['../w3ft213_8f.html#afd9acc707a0050ee144f922d2fd7f561',1,'w3ft213.f']]], + ['w3ft214_120',['w3ft214',['../w3ft214_8f.html#a6f956d8742bb119f8ebf3e1eeb95d78b',1,'w3ft214.f']]], + ['w3ft26_121',['w3ft26',['../w3ft26_8f.html#a225e7f8bb24f8c2878453792a88cee97',1,'w3ft26.f']]], + ['w3ft32_122',['w3ft32',['../w3ft32_8f.html#a505bbee044cd5b9c1484ef45ded77d52',1,'w3ft32.f']]], + ['w3ft33_123',['w3ft33',['../w3ft33_8f.html#a7c1d44437b786040567e37bcbc44765f',1,'w3ft33.f']]], + ['w3ft38_124',['w3ft38',['../w3ft38_8f.html#a650ca7b1763805ead1c270d68d9a12c4',1,'w3ft38.f']]], + ['w3ft39_125',['w3ft39',['../w3ft39_8f.html#aacebb1724c4f1396a70221ce78ed2fd5',1,'w3ft39.f']]], + ['w3ft40_126',['w3ft40',['../w3ft40_8f.html#ac08e699870c05a14afcf7f90d27d8094',1,'w3ft40.f']]], + ['w3ft41_127',['w3ft41',['../w3ft41_8f.html#a6f67ac7895427653fd746467ce92a2ad',1,'w3ft41.f']]], + ['w3ft43v_128',['w3ft43v',['../w3ft43v_8f.html#a77e63a518c43c75ba9538080631c60fc',1,'w3ft43v.f']]], + ['w3kind_129',['w3kind',['../w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a',1,'w3kind.f']]], + ['w3locdat_130',['w3locdat',['../w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1',1,'w3locdat.f']]], + ['w3miscan_131',['w3miscan',['../w3miscan_8f.html#aeeda29d4c214b97b0f8b9eb7f847f0db',1,'w3miscan.f']]], + ['w3movdat_132',['w3movdat',['../w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339',1,'w3movdat.f']]], + ['w3nogds_133',['w3nogds',['../w3nogds_8f.html#a5717adc8ddf26fc6a7fdcd02d60a8c5b',1,'w3nogds.f']]], + ['w3pradat_134',['w3pradat',['../w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6',1,'w3pradat.f']]], + ['w3reddat_135',['w3reddat',['../w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb',1,'w3reddat.f']]], + ['w3tagb_136',['w3tagb',['../w3tagb_8f.html#a7e2cdefc989c6ec94d6366fe46e86b2f',1,'w3tagb.f']]], + ['w3trnarg_137',['w3trnarg',['../w3trnarg_8f.html#aa93f106864755e8a7347b10d425e1764',1,'w3trnarg.f']]], + ['w3unpk77_138',['w3unpk77',['../w3unpk77_8f.html#a5f0f3e0fe1648c04ba5a47a13f405c4f',1,'w3unpk77.f']]], + ['w3utcdat_139',['w3utcdat',['../w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a',1,'w3utcdat.f']]], + ['w3valdat_140',['w3valdat',['../w3valdat_8f.html#a8a051a793c804f190e2da69fd1e16ebe',1,'w3valdat.f']]], + ['w3ymdh4_141',['w3ymdh4',['../w3ymdh4_8f.html#a6ec6f6ef8936c7069feafafcb4ca333b',1,'w3ymdh4.f']]] ]; diff --git a/search/functions_11.html b/search/functions_11.html deleted file mode 100644 index 188076ef..00000000 --- a/search/functions_11.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_11.js b/search/functions_11.js index 2bfc158f..f47360b1 100644 --- a/search/functions_11.js +++ b/search/functions_11.js @@ -1,6 +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']]] + ['xdopen_0',['xdopen',['../xdopen_8f.html#a941a5a5172e73a4d75553437ad275ece',1,'xdopen.f']]], + ['xmovex_1',['xmovex',['../xmovex_8f.html#a9966425854c3a77f854b1397051af333',1,'xmovex.f']]], + ['xstore_2',['xstore',['../xstore_8f.html#ad26510a638e68e3e62108516ffc9e5dc',1,'xstore.f']]] ]; diff --git a/search/functions_2.html b/search/functions_2.html deleted file mode 100644 index ca5aa10e..00000000 --- a/search/functions_2.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_2.js b/search/functions_2.js index 7bfdf09c..b9f83c75 100644 --- a/search/functions_2.js +++ b/search/functions_2.js @@ -1,6 +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']]] + ['c01o29_0',['c01o29',['../iw3unp29_8f.html#a8f442c71c59f776fbf89cfed665f90a4',1,'iw3unp29.f']]], + ['climo_1',['climo',['../w3fp06_8f.html#ae0b22fa11b8fe72122318b34fff3c384',1,'w3fp06.f']]], + ['cputim_2',['cputim',['../summary_8c.html#a85f50c91b93171e345aa393946e62aa9',1,'summary.c']]] ]; diff --git a/search/functions_3.html b/search/functions_3.html deleted file mode 100644 index d79f55b8..00000000 --- a/search/functions_3.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_3.js b/search/functions_3.js index 76e306cd..9eb6a533 100644 --- a/search/functions_3.js +++ b/search/functions_3.js @@ -1,7 +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']]] + ['elapse_0',['elapse',['../summary_8c.html#a5c5678e05ce08da171d237db078d2c30',1,'summary.c']]], + ['end_5ftimer_1',['end_timer',['../summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22',1,'summary.c']]], + ['errexit_2',['errexit',['../errexit_8f.html#acdfe2a7413809994b26b8cbc335326d8',1,'errexit.f']]], + ['errmsg_3',['errmsg',['../errmsg_8f.html#aa029ec617c24e6ff25756009764a254a',1,'errmsg.f']]] ]; diff --git a/search/functions_4.html b/search/functions_4.html deleted file mode 100644 index 1657cad0..00000000 --- a/search/functions_4.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_4.js b/search/functions_4.js index e51a9af5..cdad3722 100644 --- a/search/functions_4.js +++ b/search/functions_4.js @@ -1,62 +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']]] + ['fi631_0',['fi631',['../w3fi63_8f.html#a14d2f9e6b5fb3226561e037897d203c3',1,'w3fi63.f']]], + ['fi632_1',['fi632',['../w3fi63_8f.html#ab0e08b59a11033f2b30c4597a9442fb7',1,'w3fi63.f']]], + ['fi633_2',['fi633',['../w3fi63_8f.html#af02433c4bfbebcb7e7350ecbe7a61b81',1,'w3fi63.f']]], + ['fi634_3',['fi634',['../w3fi63_8f.html#af01235610bd0574b0f96269311efa508',1,'w3fi63.f']]], + ['fi634x_4',['fi634x',['../w3fi63_8f.html#a70c16565c866b4d5147e74b75c2c8ab3',1,'w3fi63.f']]], + ['fi635_5',['fi635',['../w3fi63_8f.html#ac10256c2bd0659630e821caf1c7ea44d',1,'w3fi63.f']]], + ['fi636_6',['fi636',['../w3fi63_8f.html#a88dd0a17439f927fd7d2d742c6f7e310',1,'w3fi63.f']]], + ['fi637_7',['fi637',['../w3fi63_8f.html#a52ab350d030e063ea1573ed81431d89e',1,'w3fi63.f']]], + ['fi6701_8',['fi6701',['../w3fi67_8f.html#a129e4781542ae749c23dc0a8961110ce',1,'w3fi67.f']]], + ['fi6702_9',['fi6702',['../w3fi67_8f.html#ae78fbedd62a4b1dc408e12a56f269d2e',1,'w3fi67.f']]], + ['fi6703_10',['fi6703',['../w3fi67_8f.html#aa4d148d976e36638d4499d8f1d24bb55',1,'w3fi67.f']]], + ['fi6704_11',['fi6704',['../w3fi67_8f.html#adf36991a9797826ba0e6af26bc047a22',1,'w3fi67.f']]], + ['fi6705_12',['fi6705',['../w3fi67_8f.html#a18dfd077ec80be85e96192fb2627ce38',1,'w3fi67.f']]], + ['fi6706_13',['fi6706',['../w3fi67_8f.html#a8f8a60d99fe5feb50640a40f9e869c08',1,'w3fi67.f']]], + ['fi6707_14',['fi6707',['../w3fi67_8f.html#a7657ec760cf65383ff753091f47be6ad',1,'w3fi67.f']]], + ['fi6708_15',['fi6708',['../w3fi67_8f.html#ad5e2e788e8e08893f9e72880bf462d07',1,'w3fi67.f']]], + ['fi6709_16',['fi6709',['../w3fi67_8f.html#a08e6952dbff783ad8064c86284b7338b',1,'w3fi67.f']]], + ['fi6710_17',['fi6710',['../w3fi67_8f.html#a7d30a98528a6c8cedc7b76c112862ea7',1,'w3fi67.f']]], + ['fi7501_18',['fi7501',['../w3fi75_8f.html#a32a2a7401b114f4fc586df3beba1740f',1,'w3fi75.f']]], + ['fi7502_19',['fi7502',['../w3fi75_8f.html#a7f98512b07c6233808c17cc41d39d34c',1,'w3fi75.f']]], + ['fi7503_20',['fi7503',['../w3fi75_8f.html#a3c5445cb4d0324926bf799220832227d',1,'w3fi75.f']]], + ['fi7505_21',['fi7505',['../w3fi75_8f.html#ab7aeef8ecb7b6e109f40de24ef9c466e',1,'w3fi75.f']]], + ['fi7513_22',['fi7513',['../w3fi75_8f.html#a080e563a3a2efeccaad9f91ac50f47e6',1,'w3fi75.f']]], + ['fi7516_23',['fi7516',['../w3fi75_8f.html#ae8e50fdcf98e231dd87ac0cac3407a23',1,'w3fi75.f']]], + ['fi7517_24',['fi7517',['../w3fi75_8f.html#a27b075bf60130cc76e5af83a4631df21',1,'w3fi75.f']]], + ['fi7518_25',['fi7518',['../w3fi75_8f.html#a229a0a1cdb13a4ac40e64396a062b0ab',1,'w3fi75.f']]], + ['fi7801_26',['fi7801',['../w3fi78_8f.html#a49815e08605c968b2fecd0dcbdabe304',1,'w3fi78.f']]], + ['fi7802_27',['fi7802',['../w3fi78_8f.html#af68f1a1dbbc01729e49a3f9b5d8ff62e',1,'w3fi78.f']]], + ['fi7803_28',['fi7803',['../w3fi78_8f.html#a9b9826d7fd1020f442d3d2a6c13a8239',1,'w3fi78.f']]], + ['fi7804_29',['fi7804',['../w3fi78_8f.html#a7f339d55f5933f4ab915a26098bb0e6e',1,'w3fi78.f']]], + ['fi7805_30',['fi7805',['../w3fi78_8f.html#ae8c42f7f8ccfa1726cb092ddd414c87a',1,'w3fi78.f']]], + ['fi7806_31',['fi7806',['../w3fi78_8f.html#a1ddd77e21e7b12f733c96d0d14092208',1,'w3fi78.f']]], + ['fi7807_32',['fi7807',['../w3fi78_8f.html#a4fe95ebc53f5ab1c5effb0a2cf9a1824',1,'w3fi78.f']]], + ['fi7808_33',['fi7808',['../w3fi78_8f.html#aab7538e5347a195c3eaae1a6bd035a5b',1,'w3fi78.f']]], + ['fi7809_34',['fi7809',['../w3fi78_8f.html#a3c7efbd2d1d06f5eadeb47912d1f1b88',1,'w3fi78.f']]], + ['fi7810_35',['fi7810',['../w3fi78_8f.html#aa7e94634a4e5b52d7a1fcc00d163180e',1,'w3fi78.f']]], + ['fi8501_36',['fi8501',['../w3fi85_8f.html#aa0c98da314499613dded4ed29bd67007',1,'w3fi85.f']]], + ['fi8502_37',['fi8502',['../w3fi85_8f.html#aeeb668d3a0405f063fc381f2b6fadf1e',1,'w3fi85.f']]], + ['fi8503_38',['fi8503',['../w3fi85_8f.html#a2288a2988c66dc8a5e48981f36ba4d38',1,'w3fi85.f']]], + ['fi8505_39',['fi8505',['../w3fi85_8f.html#a7a5c1f8087abe23f5aa386dcc6578b88',1,'w3fi85.f']]], + ['fi8506_40',['fi8506',['../w3fi85_8f.html#ab119068cfe66eb960c13bf8fcf3fdd18',1,'w3fi85.f']]], + ['fi8508_41',['fi8508',['../w3fi85_8f.html#ad0e2adc571586558aa11ae9c6220f19b',1,'w3fi85.f']]], + ['fi8509_42',['fi8509',['../w3fi85_8f.html#a2d4241923113f9d2570abb615cf6e6f9',1,'w3fi85.f']]], + ['fi8511_43',['fi8511',['../w3fi85_8f.html#a0ccde573a90a01365eb9e289a1d7cd65',1,'w3fi85.f']]], + ['fi8512_44',['fi8512',['../w3fi85_8f.html#ae31c2999baedbd4f7d4e8b6ee4bbd319',1,'w3fi85.f']]], + ['fi8513_45',['fi8513',['../w3fi85_8f.html#aff8d7f9b19c5927af493f76286da2192',1,'w3fi85.f']]], + ['fi8801_46',['fi8801',['../w3fi88_8f.html#a2fed25546da8e6018a9a7ef4f84da0d4',1,'w3fi88.f']]], + ['fi8802_47',['fi8802',['../w3fi88_8f.html#af7dc9d23ed351c8f1e385475ca39c737',1,'w3fi88.f']]], + ['fi8803_48',['fi8803',['../w3fi88_8f.html#a32eb617143dc3a3b49a1bbfef5960ed5',1,'w3fi88.f']]], + ['fi8804_49',['fi8804',['../w3fi88_8f.html#a17cd06929f54d9886b5d2a4677fcf8e1',1,'w3fi88.f']]], + ['fi8805_50',['fi8805',['../w3fi88_8f.html#a7c494f653f8c6abcffaea6a5918163ab',1,'w3fi88.f']]], + ['fi8806_51',['fi8806',['../w3fi88_8f.html#a9a711b7afb78b8e4e813d29a6d00343e',1,'w3fi88.f']]], + ['fi8807_52',['fi8807',['../w3fi88_8f.html#a8962db3dac489d800d8fc9cc13a0641b',1,'w3fi88.f']]], + ['fi8808_53',['fi8808',['../w3fi88_8f.html#a157d9ffb48327791c26dc6ddac872eda',1,'w3fi88.f']]], + ['fi8809_54',['fi8809',['../w3fi88_8f.html#ada2a564df0576afd8796b682c9c50b73',1,'w3fi88.f']]], + ['fi8810_55',['fi8810',['../w3fi88_8f.html#ade4fae47f4dcc026b6ffb64e03f55651',1,'w3fi88.f']]], + ['fi8811_56',['fi8811',['../w3fi88_8f.html#a09e14e694efd5f48b403ec0dfff7f63c',1,'w3fi88.f']]], + ['fparsei_57',['fparsei',['../fparsei_8f.html#a3f5e219fe4f03b8ccb20e4a7e5cbe832',1,'fparsei.f']]], + ['fparser_58',['fparser',['../fparser_8f.html#a614ee9606f217b051a2643684051df50',1,'fparser.f']]] ]; diff --git a/search/functions_5.html b/search/functions_5.html deleted file mode 100644 index 9301d6b9..00000000 --- a/search/functions_5.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_5.js b/search/functions_5.js index 71250ed0..e11d146e 100644 --- a/search/functions_5.js +++ b/search/functions_5.js @@ -1,30 +1,31 @@ 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']]] + ['gbyte_0',['gbyte',['../gbyte_8f.html#ad8ac424552647ef42f4b054733f7b7b1',1,'gbyte.f']]], + ['gbytec_1',['gbytec',['../gbytec_8f.html#a43bd8d585799cf64eb09804156200064',1,'gbytec.f']]], + ['gbytes_2',['gbytes',['../gbytes_8f.html#a69f5a171f262da1e5a75f8a3810f4a82',1,'gbytes.f']]], + ['gbytesc_3',['gbytesc',['../gbytesc_8f.html#ad46c14caec87fa3f7d379d52fd8173bc',1,'gbytesc.f']]], + ['getbit_4',['getbit',['../getbit_8f.html#a4d5fdf661844c7978d879e815608d8f0',1,'getbit.f']]], + ['getgb_5',['getgb',['../getgb_8f.html#a98040aebeda65b55ed5c61d891e49ccf',1,'getgb.f']]], + ['getgb1_6',['getgb1',['../getgb1_8f.html#a75aa7f2cd8878c41dc74056854b7bade',1,'getgb1.f']]], + ['getgb1r_7',['getgb1r',['../getgb1r_8f.html#a982dff5bb7d495326427c13fc654d7bb',1,'getgb1r.f']]], + ['getgb1re_8',['getgb1re',['../getgb1re_8f.html#a58c5662f20d4a9ed1881394b25818565',1,'getgb1re.f']]], + ['getgb1s_9',['getgb1s',['../getgb1s_8f.html#a5005a2bc8cb1f85d4ab9d897c73e8344',1,'getgb1s.f']]], + ['getgbe_10',['getgbe',['../getgbe_8f.html#a131d2957b2e9ec6248fde892f7c82a01',1,'getgbe.f']]], + ['getgbeh_11',['getgbeh',['../getgbeh_8f.html#a880ba6974d201e5b100eda8d57251dbe',1,'getgbeh.f']]], + ['getgbem_12',['getgbem',['../getgbem_8f.html#a52148a120ff1d3de25afdc5e7843c3e9',1,'getgbem.f']]], + ['getgbemh_13',['getgbemh',['../getgbemh_8f.html#a0cfcd2b0adf1907f29efd836cee13554',1,'getgbemh.f']]], + ['getgbemn_14',['getgbemn',['../getgbemn_8f.html#aac1e0617524cfcef1651f92133f0c959',1,'getgbemn.f']]], + ['getgbemp_15',['getgbemp',['../getgbemp_8f.html#a6f58776aeb1ed2f7e367bf4a01a1ad35',1,'getgbemp.f']]], + ['getgbens_16',['getgbens',['../getgbens_8f.html#ac722b1ceb7e6a1af1c810c6c84434dcf',1,'getgbens.f']]], + ['getgbep_17',['getgbep',['../getgbep_8f.html#a9cbd8064fd141a45c07846c00931eab0',1,'getgbep.f']]], + ['getgbex_18',['getgbex',['../getgbex_8f.html#a6767d5f6b448d03e5f0a154bf7ed4090',1,'getgbex.f']]], + ['getgbexm_19',['getgbexm',['../getgbexm_8f.html#a660f20529705ee3731e6544771eedf4d',1,'getgbexm.f']]], + ['getgbh_20',['getgbh',['../getgbh_8f.html#afe4595036ec84fc5868e9a0cdaa75a4c',1,'getgbh.f']]], + ['getgbm_21',['getgbm',['../getgbm_8f.html#a13e5b7b94989de452f47d062a917e8f9',1,'getgbm.f']]], + ['getgbmh_22',['getgbmh',['../getgbmh_8f.html#a0fe386a75ceff44f8914bc6d883c28f4',1,'getgbmh.f']]], + ['getgbmp_23',['getgbmp',['../getgbmp_8f.html#a87989f48a32883137be354ba99db080b',1,'getgbmp.f']]], + ['getgbp_24',['getgbp',['../getgbp_8f.html#ab997b10791523905a4bbd1c6d3d4d258',1,'getgbp.f']]], + ['getgi_25',['getgi',['../getgi_8f.html#acdad122216fa099a6a3a45cbf85ec1c2',1,'getgi.f']]], + ['getgir_26',['getgir',['../getgir_8f.html#a1d594876e11881c99690d52b4091849f',1,'getgir.f']]], + ['gtbits_27',['gtbits',['../gtbits_8f.html#a0f90e24d4c196fe0bdf31f938110c704',1,'gtbits.f']]] ]; diff --git a/search/functions_6.html b/search/functions_6.html deleted file mode 100644 index 9c4f5fc6..00000000 --- a/search/functions_6.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_6.js b/search/functions_6.js index f150796b..7f1bade3 100644 --- a/search/functions_6.js +++ b/search/functions_6.js @@ -1,14 +1,15 @@ 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']]] + ['i01o29_0',['i01o29',['../iw3unp29_8f.html#a687b1ecdce871d1cf438f4fb2be95425',1,'iw3unp29.f']]], + ['i02o29_1',['i02o29',['../iw3unp29_8f.html#a83aa538c2e5a51c40a981974247d82c7',1,'iw3unp29.f']]], + ['i03o29_2',['i03o29',['../iw3unp29_8f.html#a291446927c470179df611e56fbc0ff6f',1,'iw3unp29.f']]], + ['i05o29_3',['i05o29',['../iw3unp29_8f.html#a5cb8ae5d00bc1141f789b08555083739',1,'iw3unp29.f']]], + ['idsdef_4',['idsdef',['../idsdef_8f.html#af116d5532c9d7b1e288ff59b1e75800c',1,'idsdef.f']]], + ['instrument_5',['instrument',['../instrument_8f.html#a9e01b91f60a070be2a253f818d3d9732',1,'instrument.f']]], + ['isrchne_6',['isrchne',['../isrchne_8f.html#a53cf06203460280eb4f894b66282b5fd',1,'isrchne.f']]], + ['iw3jdn_7',['iw3jdn',['../iw3jdn_8f.html#a2bb3a8c7551117779d303813bf2d7a2c',1,'iw3jdn.f']]], + ['iw3mat_8',['iw3mat',['../iw3mat_8f.html#aa53ca2552f7a06ad9141f16197b82fda',1,'iw3mat.f']]], + ['iw3pds_9',['iw3pds',['../iw3pds_8f.html#ab3b0c789b44fe2ae4b1422c6beb6a4f1',1,'iw3pds.f']]], + ['iw3unp29_10',['iw3unp29',['../iw3unp29_8f.html#a79f04733a38667022a957e6c1b9093b6',1,'iw3unp29.f']]], + ['ixgb_11',['ixgb',['../ixgb_8f.html#ab80631a0d3fc8e1450bee116bc16e205',1,'ixgb.f']]] ]; diff --git a/search/functions_7.html b/search/functions_7.html deleted file mode 100644 index 46b5c0f6..00000000 --- a/search/functions_7.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_7.js b/search/functions_7.js index 0a1d12ec..80bcf0cd 100644 --- a/search/functions_7.js +++ b/search/functions_7.js @@ -1,7 +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']]] + ['lengds_0',['lengds',['../lengds_8f.html#af9d4e4b97b2d11e238290791aad2b989',1,'lengds.f']]], + ['line01_1',['line01',['../w3fp06_8f.html#ae1b5ebd2418050ad3b381f3f8d608bc6',1,'w3fp06.f']]], + ['line02_2',['line02',['../w3fp06_8f.html#ad054774044780f0d653a6e9e187b21f9',1,'w3fp06.f']]], + ['line03_3',['line03',['../w3fp06_8f.html#a947acf07eeb32317d7ff0c144682c8ad',1,'w3fp06.f']]] ]; diff --git a/search/functions_8.html b/search/functions_8.html deleted file mode 100644 index 31a1d950..00000000 --- a/search/functions_8.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_8.js b/search/functions_8.js index bb90232f..19940333 100644 --- a/search/functions_8.js +++ b/search/functions_8.js @@ -1,11 +1,12 @@ 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']]] + ['makgds_0',['makgds',['../makgds_8f90.html#a132c655a1a21b17ef23ee83108d7d4ac',1,'makgds.f90']]], + ['makwmo_1',['makwmo',['../makwmo_8f.html#acb3df40c99edbb45efe0d6b9a53af7de',1,'makwmo.f']]], + ['misc01_2',['misc01',['../w3miscan_8f.html#a77f06920ef1ce938ca29cc1ea7a18b56',1,'w3miscan.f']]], + ['misc04_3',['misc04',['../w3miscan_8f.html#af225a39ea11be14a9d8ae53744bd70b1',1,'w3miscan.f']]], + ['misc05_4',['misc05',['../w3miscan_8f.html#a6ebad02513c61fc41c51db9cf3bbaf7f',1,'w3miscan.f']]], + ['misc06_5',['misc06',['../w3miscan_8f.html#a2fbfd745aaa9ecb372ff2524a682ccae',1,'w3miscan.f']]], + ['misc10_6',['misc10',['../w3miscan_8f.html#ae39c3c17acb9b8b9e8865dce77e99179',1,'w3miscan.f']]], + ['mkfldsep_7',['mkfldsep',['../mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045',1,'mkfldsep.f']]], + ['mova2i_8',['mova2i',['../mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0',1,'mova2i.f']]] ]; diff --git a/search/functions_9.html b/search/functions_9.html deleted file mode 100644 index 9a8e4290..00000000 --- a/search/functions_9.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_9.js b/search/functions_9.js index 54872ec9..a16ed303 100644 --- a/search/functions_9.js +++ b/search/functions_9.js @@ -1,4 +1,4 @@ var searchData= [ - ['orders_868',['orders',['../orders_8f.html#a311c2453b613d259dc8e998f6d6aa944',1,'orders.f']]] + ['orders_0',['orders',['../orders_8f.html#a606ed1b385c755d9ebbc4de760349893',1,'orders.f']]] ]; diff --git a/search/functions_a.html b/search/functions_a.html deleted file mode 100644 index 5ecc152c..00000000 --- a/search/functions_a.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_a.js b/search/functions_a.js index f0a1e781..c6920c78 100644 --- a/search/functions_a.js +++ b/search/functions_a.js @@ -1,12 +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']]] + ['pdsens_0',['pdsens',['../pdsens_8f.html#ad99e2996ab77fc0da4f298babf729a41',1,'pdsens.f']]], + ['pdseup_1',['pdseup',['../pdseup_8f.html#aaac6faa5251b1c5320b6b055bcede9d2',1,'pdseup.f']]], + ['print_5ftiming_2',['print_timing',['../summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0',1,'summary.c']]], + ['putgb_3',['putgb',['../putgb_8f.html#ab6da73b9f8ae839b451816f9916c231a',1,'putgb.f']]], + ['putgbe_4',['putgbe',['../putgbe_8f.html#a08a29a941cd31cd04ee22f5139023e69',1,'putgbe.f']]], + ['putgben_5',['putgben',['../putgben_8f.html#a74d7f0a61a5f7937731d2b632555c69f',1,'putgben.f']]], + ['putgbens_6',['putgbens',['../putgbens_8f.html#ad7551417c16d5720c2678f42443a045f',1,'putgbens.f']]], + ['putgbex_7',['putgbex',['../putgbex_8f.html#a4d66cc2839c13fd35ae337aa79616ce6',1,'putgbex.f']]], + ['putgbn_8',['putgbn',['../putgbn_8f.html#aec976c38f8bad78272ad997b4313a0cb',1,'putgbn.f']]] ]; diff --git a/search/functions_b.html b/search/functions_b.html deleted file mode 100644 index e301fedd..00000000 --- a/search/functions_b.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_b.js b/search/functions_b.js index 1ce11a91..483992c5 100644 --- a/search/functions_b.js +++ b/search/functions_b.js @@ -1,6 +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']]] + ['q9e3i6_0',['q9e3i6',['../w3ai00_8f.html#a564f42a42124d4a94e956e051ad59969',1,'w3ai00.f']]], + ['q9ei32_1',['q9ei32',['../w3ai00_8f.html#a1fd1329d5e770895def939d0467928ef',1,'w3ai00.f']]], + ['q9ie32_2',['q9ie32',['../q9ie32_8f.html#aa70d08ca2156165a1d7e6ada7698274f',1,'q9ie32.f']]] ]; diff --git a/search/functions_c.html b/search/functions_c.html deleted file mode 100644 index c4f32687..00000000 --- a/search/functions_c.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_c.js b/search/functions_c.js index c79a3020..33518cda 100644 --- a/search/functions_c.js +++ b/search/functions_c.js @@ -1,13 +1,24 @@ 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']]] + ['r01o29_0',['r01o29',['../iw3unp29_8f.html#af86e22354050944e4507e85c314114a0',1,'iw3unp29.f']]], + ['r63w72_1',['r63w72',['../r63w72_8f.html#af3dacce6918418d047d622bbe287a228',1,'r63w72.f']]], + ['random_5fgauss_5ff_2',['random_gauss_f',['../namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437',1,'mersenne_twister']]], + ['random_5fgauss_5fi_3',['random_gauss_i',['../interfacemersenne__twister_1_1random__gauss.html#a2ab29e2f6e4efe8ffd858ff257747173',1,'mersenne_twister::random_gauss']]], + ['random_5fgauss_5fs_4',['random_gauss_s',['../interfacemersenne__twister_1_1random__gauss.html#a50af58f1f0525f0d68b14e6362305b1c',1,'mersenne_twister::random_gauss']]], + ['random_5fgauss_5ft_5',['random_gauss_t',['../interfacemersenne__twister_1_1random__gauss.html#afea5a15176c49f9829db24f555692278',1,'mersenne_twister::random_gauss']]], + ['random_5findex_5ff_6',['random_index_f',['../namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e',1,'mersenne_twister']]], + ['random_5findex_5fi_7',['random_index_i',['../interfacemersenne__twister_1_1random__index.html#adb086879ee9eabb64d4026daacf40567',1,'mersenne_twister::random_index']]], + ['random_5findex_5fs_8',['random_index_s',['../interfacemersenne__twister_1_1random__index.html#ab4356f122440e3e8eb2eccfd16968c84',1,'mersenne_twister::random_index']]], + ['random_5findex_5ft_9',['random_index_t',['../interfacemersenne__twister_1_1random__index.html#af137b7c612966c256b47c9949f8095ba',1,'mersenne_twister::random_index']]], + ['random_5fnumber_5ff_10',['random_number_f',['../namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a',1,'mersenne_twister']]], + ['random_5fnumber_5fi_11',['random_number_i',['../interfacemersenne__twister_1_1random__number.html#a4df934289beedb0e333c1260489949e6',1,'mersenne_twister::random_number']]], + ['random_5fnumber_5fs_12',['random_number_s',['../interfacemersenne__twister_1_1random__number.html#a94e918a10214cfe0c24c303d220452e7',1,'mersenne_twister::random_number']]], + ['random_5fnumber_5ft_13',['random_number_t',['../interfacemersenne__twister_1_1random__number.html#a0f53661cf413d88e71aef77a9a9468ae',1,'mersenne_twister::random_number']]], + ['random_5fseed_14',['random_seed',['../namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad',1,'mersenne_twister']]], + ['random_5fsetseed_5fs_15',['random_setseed_s',['../interfacemersenne__twister_1_1random__setseed.html#af25a7d71ddbad282dd5eb407c0bd907d',1,'mersenne_twister::random_setseed']]], + ['random_5fsetseed_5ft_16',['random_setseed_t',['../interfacemersenne__twister_1_1random__setseed.html#a21dac133ee7db7e53a1161f36efe9d11',1,'mersenne_twister::random_setseed']]], + ['resource_17',['resource',['../summary_8c.html#a585b71c74faea63d161810774ef8da9e',1,'summary.c']]], + ['risc02_18',['risc02',['../w3miscan_8f.html#aae1710f52170633399d23802b4ad8b51',1,'w3miscan.f']]], + ['risc02xx_19',['risc02xx',['../w3miscan_8f.html#aa99de7615b5b2a0f60a385c3be1ba9da',1,'w3miscan.f']]], + ['risc03_20',['risc03',['../w3miscan_8f.html#ab194d2809f49e869082d6ae6b3b977c9',1,'w3miscan.f']]] ]; diff --git a/search/functions_d.html b/search/functions_d.html deleted file mode 100644 index 7a1ed065..00000000 --- a/search/functions_d.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_d.js b/search/functions_d.js index 40a56b8d..c63eaec2 100644 --- a/search/functions_d.js +++ b/search/functions_d.js @@ -1,12 +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']]] + ['s06o29_0',['s06o29',['../iw3unp29_8f.html#aaa7ab7bf0bec88768b0fcb9921f07ff1',1,'iw3unp29.f']]], + ['sbyte_1',['sbyte',['../sbyte_8f.html#a74f0f88a79864061c3a4234075d39e1b',1,'sbyte.f']]], + ['sbytec_2',['sbytec',['../sbytec_8f.html#a8a4f2a2a7a917e47a36f737aa1d75c14',1,'sbytec.f']]], + ['sbytesc_3',['sbytesc',['../sbytesc_8f.html#ad30c0509f73ae28b2f15fa3c151d491c',1,'sbytesc.f']]], + ['setcl_4',['setcl',['../w3fp06_8f.html#a85c5aff8a14219277412b5178d23c8eb',1,'w3fp06.f']]], + ['skgb_5',['skgb',['../skgb_8f.html#a33d9c42574632a3c57ecc85d17c8e62a',1,'skgb.f']]], + ['start_5f_6',['start_',['../summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e',1,'summary.c']]], + ['start_5ftimer_7',['start_timer',['../summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7',1,'summary.c']]], + ['summary_5f_8',['summary_',['../summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110',1,'summary.c']]] ]; diff --git a/search/functions_e.html b/search/functions_e.html deleted file mode 100644 index 22d2a6bf..00000000 --- a/search/functions_e.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_e.js b/search/functions_e.js index ea0ead34..03c0ad5f 100644 --- a/search/functions_e.js +++ b/search/functions_e.js @@ -1,12 +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']]] + ['unpk7701_0',['unpk7701',['../w3unpk77_8f.html#a6e6b3e1b8bac81ed3db73ab1fca6c40f',1,'w3unpk77.f']]], + ['unpk7702_1',['unpk7702',['../w3unpk77_8f.html#a35877dbb88d9e6fb89b1807238f95018',1,'w3unpk77.f']]], + ['unpk7703_2',['unpk7703',['../w3unpk77_8f.html#ac39a6820df8dfea69d930ab738b8b07e',1,'w3unpk77.f']]], + ['unpk7704_3',['unpk7704',['../w3unpk77_8f.html#a9dfb4c67d159cc49f2a43151ec25e915',1,'w3unpk77.f']]], + ['unpk7705_4',['unpk7705',['../w3unpk77_8f.html#a3b7ce3ad5342da6e89fbbeb173ae47d5',1,'w3unpk77.f']]], + ['unpk7706_5',['unpk7706',['../w3unpk77_8f.html#a781d7a1d34ea17a555131bdde0ce1579',1,'w3unpk77.f']]], + ['unpk7707_6',['unpk7707',['../w3unpk77_8f.html#a73cd8561593c0b5c72075104f7200594',1,'w3unpk77.f']]], + ['unpk7708_7',['unpk7708',['../w3unpk77_8f.html#a03a9e7379784e4998d610e00673b05ea',1,'w3unpk77.f']]], + ['unpk7709_8',['unpk7709',['../w3unpk77_8f.html#a515f864a3a6adab3695cef735f610479',1,'w3unpk77.f']]] ]; diff --git a/search/functions_f.html b/search/functions_f.html deleted file mode 100644 index 54b7dee0..00000000 --- a/search/functions_f.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/functions_f.js b/search/functions_f.js index b25a4681..3a3de884 100644 --- a/search/functions_f.js +++ b/search/functions_f.js @@ -1,4 +1,4 @@ var searchData= [ - ['value1_909',['value1',['../w3fp06_8f.html#a857d20cd6a97ba1e266d803b2092670c',1,'w3fp06.f']]] + ['value1_0',['value1',['../w3fp06_8f.html#a50f973cd14b24a8da68b625d31c18dfa',1,'w3fp06.f']]] ]; diff --git a/search/mag.svg b/search/mag.svg new file mode 100644 index 00000000..ffb6cf0d --- /dev/null +++ b/search/mag.svg @@ -0,0 +1,24 @@ + + + + + + + diff --git a/search/mag_d.svg b/search/mag_d.svg new file mode 100644 index 00000000..4122773f --- /dev/null +++ b/search/mag_d.svg @@ -0,0 +1,24 @@ + + + + + + + diff --git a/search/mag_sel.png b/search/mag_sel.png deleted file mode 100644 index 39c0ed52a25dd9d080ee0d42ae6c6042bdfa04d7..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 465 zcmeAS@N?(olHy`uVBq!ia0vp^B0wz6!2%?$TA$hhDVB6cUq=Rpjs4tz5?O(Kg=CK) zUj~NU84L`?eGCi_EEpJ?t}-xGu`@87+QPtK?83kxQ`TapwHK(CDaqU2h2ejD|C#+j z9%q3^WHAE+w=f7ZGR&GI0Tg5}@$_|Nf5gMiEhFgvHvB$N=!mC_V~EE2vzPXI9ZnEo zd+1zHor@dYLod2Y{ z@R$7$Z!PXTbY$|@#T!bMzm?`b<(R`cbw(gxJHzu zB$lLFB^RXvDF!10LknF)BV7aY5JN*NBMU1-b8Q0yD+2>vd*|CI8glbfGSez?Ylunu RoetE%;OXk;vd$@?2>>CYplSdB diff --git a/search/mag_sel.svg b/search/mag_sel.svg new file mode 100644 index 00000000..553dba87 --- /dev/null +++ b/search/mag_sel.svg @@ -0,0 +1,31 @@ + + + + + + + + + diff --git a/search/mag_seld.svg b/search/mag_seld.svg new file mode 100644 index 00000000..c906f84c --- /dev/null +++ b/search/mag_seld.svg @@ -0,0 +1,31 @@ + + + + + + + + + diff --git a/search/namespaces_0.html b/search/namespaces_0.html deleted file mode 100644 index 21db2c3a..00000000 --- a/search/namespaces_0.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/namespaces_0.js b/search/namespaces_0.js index 1a6d0711..fe9ff53f 100644 --- a/search/namespaces_0.js +++ b/search/namespaces_0.js @@ -1,4 +1,4 @@ var searchData= [ - ['args_5fmod_529',['args_mod',['../namespaceargs__mod.html',1,'']]] + ['mersenne_5ftwister_0',['mersenne_twister',['../namespacemersenne__twister.html',1,'']]] ]; diff --git a/search/namespaces_1.html b/search/namespaces_1.html deleted file mode 100644 index a01efeb1..00000000 --- a/search/namespaces_1.html +++ /dev/null @@ -1,37 +0,0 @@ - - - - - - - - - - -
-
Loading...
-
- -
Searching...
-
No Matches
- -
- - diff --git a/search/namespaces_1.js b/search/namespaces_1.js deleted file mode 100644 index d29bb8d5..00000000 --- a/search/namespaces_1.js +++ /dev/null @@ -1,4 +0,0 @@ -var searchData= -[ - ['mersenne_5ftwister_530',['mersenne_twister',['../namespacemersenne__twister.html',1,'']]] -]; diff --git a/search/nomatches.html b/search/nomatches.html deleted file mode 100644 index 2b9360b6..00000000 --- a/search/nomatches.html +++ /dev/null @@ -1,13 +0,0 @@ - - - - - - - - -
-
No Matches
-
- - diff --git a/search/pages_0.js b/search/pages_0.js new file mode 100644 index 00000000..24c1505c --- /dev/null +++ b/search/pages_0.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['nceplibs_20w3emc_0',['NCEPLIBS-w3emc',['../index.html',1,'']]] +]; diff --git a/search/pages_1.js b/search/pages_1.js new file mode 100644 index 00000000..75517268 --- /dev/null +++ b/search/pages_1.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['w3emc_0',['NCEPLIBS-w3emc',['../index.html',1,'']]] +]; diff --git a/search/search.css b/search/search.css index 9074198f..19f76f9d 100644 --- a/search/search.css +++ b/search/search.css @@ -1,10 +1,33 @@ -/*---------------- Search Box */ +/*---------------- Search Box positioning */ + +#main-menu > li:last-child { + /* This
  • object is the parent of the search bar */ + display: flex; + justify-content: center; + align-items: center; + height: 36px; + margin-right: 1em; +} + +/*---------------- Search box styling */ + +.SRPage * { + font-weight: normal; + line-height: normal; +} + +dark-mode-toggle { + margin-left: 5px; + display: flex; + float: right; +} #MSearchBox { + display: inline-block; white-space : nowrap; - background: white; + background: var(--search-background-color); border-radius: 0.65em; - box-shadow: inset 0.5px 0.5px 3px 0px #555; + box-shadow: var(--search-box-shadow); z-index: 102; } @@ -17,28 +40,47 @@ #MSearchSelect { display: inline-block; vertical-align: middle; - height: 1.4em; - padding: 0 0 0 0.3em; - margin: 0; + width: 20px; + height: 19px; + background-image: var(--search-magnification-select-image); + margin: 0 0 0 0.3em; + padding: 0; +} + +#MSearchSelectExt { + display: inline-block; + vertical-align: middle; + width: 10px; + height: 19px; + background-image: var(--search-magnification-image); + margin: 0 0 0 0.5em; + padding: 0; } + #MSearchField { display: inline-block; vertical-align: middle; width: 7.5em; - height: 1.1em; + height: 19px; margin: 0 0.15em; padding: 0; line-height: 1em; border:none; - color: #909090; + color: var(--search-foreground-color); outline: none; - font-family: Arial, Verdana, sans-serif; + font-family: var(--font-family-search); -webkit-border-radius: 0px; border-radius: 0px; background: none; } +@media(hover: none) { + /* to avoid zooming on iOS */ + #MSearchField { + font-size: 16px; + } +} #MSearchBox .right { display: inline-block; @@ -59,23 +101,15 @@ } #MSearchCloseImg { - height: 1.4em; padding: 0.3em; margin: 0; } .MSearchBoxActive #MSearchField { - color: #000000; + color: var(--search-active-color); } -#main-menu > li:last-child { - /* This
  • object is the parent of the search bar */ - display: flex; - justify-content: center; - align-items: center; - height: 36px; - margin-right: 1em; -} + /*---------------- Search filter selection */ @@ -83,8 +117,8 @@ display: none; position: absolute; left: 0; top: 0; - border: 1px solid #90A5CE; - background-color: #F9FAFC; + border: 1px solid var(--search-filter-border-color); + background-color: var(--search-filter-background-color); z-index: 10001; padding-top: 4px; padding-bottom: 4px; @@ -97,7 +131,7 @@ } .SelectItem { - font: 8pt Arial, Verdana, sans-serif; + font: 8pt var(--font-family-search); padding-left: 2px; padding-right: 12px; border: 0px; @@ -105,7 +139,7 @@ span.SelectionMark { margin-right: 4px; - font-family: monospace; + font-family: var(--font-family-monospace); outline-style: none; text-decoration: none; } @@ -113,7 +147,7 @@ span.SelectionMark { a.SelectItem { display: block; outline-style: none; - color: #000000; + color: var(--search-filter-foreground-color); text-decoration: none; padding-left: 6px; padding-right: 12px; @@ -121,14 +155,14 @@ a.SelectItem { a.SelectItem:focus, a.SelectItem:active { - color: #000000; + color: var(--search-filter-foreground-color); outline-style: none; text-decoration: none; } a.SelectItem:hover { - color: #FFFFFF; - background-color: #3D578C; + color: var(--search-filter-highlight-text-color); + background-color: var(--search-filter-highlight-bg-color); outline-style: none; text-decoration: none; cursor: pointer; @@ -138,7 +172,7 @@ a.SelectItem:hover { /*---------------- Search results window */ iframe#MSearchResults { - width: 60ex; + /*width: 60ex;*/ height: 15em; } @@ -146,9 +180,12 @@ iframe#MSearchResults { display: none; position: absolute; left: 0; top: 0; - border: 1px solid #000; - background-color: #EEF1F7; + border: 1px solid var(--search-results-border-color); + background-color: var(--search-results-background-color); z-index:10000; + width: 300px; + height: 400px; + overflow: auto; } /* ----------------------------------- */ @@ -156,7 +193,6 @@ iframe#MSearchResults { #SRIndex { clear:both; - padding-bottom: 15px; } .SREntry { @@ -169,8 +205,9 @@ iframe#MSearchResults { padding: 1px 5px; } -body.SRPage { +div.SRPage { margin: 5px 2px; + background-color: var(--search-results-background-color); } .SRChildren { @@ -182,17 +219,18 @@ body.SRPage { } .SRSymbol { - font-weight: bold; - color: #425E97; - font-family: Arial, Verdana, sans-serif; + font-weight: bold; + color: var(--search-results-foreground-color); + font-family: var(--font-family-search); text-decoration: none; outline: none; } a.SRScope { display: block; - color: #425E97; - font-family: Arial, Verdana, sans-serif; + color: var(--search-results-foreground-color); + font-family: var(--font-family-search); + font-size: 8pt; text-decoration: none; outline: none; } @@ -204,14 +242,14 @@ a.SRScope:focus, a.SRScope:active { span.SRScope { padding-left: 4px; - font-family: Arial, Verdana, sans-serif; + font-family: var(--font-family-search); } .SRPage .SRStatus { padding: 2px 5px; font-size: 8pt; font-style: italic; - font-family: Arial, Verdana, sans-serif; + font-family: var(--font-family-search); } .SRResult { @@ -225,14 +263,10 @@ div.searchresults { /*---------------- External search page results */ -.searchresult { - background-color: #F0F3F8; -} - .pages b { color: white; padding: 5px 5px 3px 5px; - background-image: url("../tab_a.png"); + background-image: var(--nav-gradient-active-image-parent); background-repeat: repeat-x; text-shadow: 0 1px 1px #000000; } diff --git a/search/search.js b/search/search.js index fb226f73..6fd40c67 100644 --- a/search/search.js +++ b/search/search.js @@ -73,6 +73,8 @@ function getYPos(item) return y; } +var searchResults = new SearchResults("searchResults"); + /* A class handling everything associated with the search panel. Parameters: @@ -80,7 +82,7 @@ function getYPos(item) storing this instance. Is needed to be able to set timeouts. resultPath - path to use for external files */ -function SearchBox(name, resultsPath, inFrame, label, extension) +function SearchBox(name, resultsPath, extension) { if (!name || !resultsPath) { alert("Missing parameters to SearchBox."); } if (!extension || extension == "") { extension = ".html"; } @@ -96,8 +98,6 @@ function SearchBox(name, resultsPath, inFrame, label, extension) this.hideTimeout = 0; this.searchIndex = 0; this.searchActive = false; - this.insideFrame = inFrame; - this.searchLabel = label; this.extension = extension; // ----------- DOM Elements @@ -136,30 +136,14 @@ function SearchBox(name, resultsPath, inFrame, label, extension) var searchSelectWindow = this.DOMSearchSelectWindow(); var searchField = this.DOMSearchSelect(); - if (this.insideFrame) - { - var left = getXPos(searchField); - var top = getYPos(searchField); - left += searchField.offsetWidth + 6; - top += searchField.offsetHeight; - - // show search selection popup - searchSelectWindow.style.display='block'; - left -= searchSelectWindow.offsetWidth; - searchSelectWindow.style.left = left + 'px'; - searchSelectWindow.style.top = top + 'px'; - } - else - { - var left = getXPos(searchField); - var top = getYPos(searchField); - top += searchField.offsetHeight; + var left = getXPos(searchField); + var top = getYPos(searchField); + top += searchField.offsetHeight; - // show search selection popup - searchSelectWindow.style.display='block'; - searchSelectWindow.style.left = left + 'px'; - searchSelectWindow.style.top = top + 'px'; - } + // show search selection popup + searchSelectWindow.style.display='block'; + searchSelectWindow.style.left = left + 'px'; + searchSelectWindow.style.top = top + 'px'; // stop selection hide timer if (this.hideTimeout) @@ -172,7 +156,7 @@ function SearchBox(name, resultsPath, inFrame, label, extension) this.OnSearchSelectHide = function() { - this.hideTimeout = setTimeout(this.name +".CloseSelectionWindow()", + this.hideTimeout = setTimeout(this.CloseSelectionWindow.bind(this), this.closeSelectionTimeout); } @@ -205,11 +189,13 @@ function SearchBox(name, resultsPath, inFrame, label, extension) } else { - window.frames.MSearchResults.postMessage("take_focus", "*"); + var elem = searchResults.NavNext(0); + if (elem) elem.focus(); } } else if (e.keyCode==27) // Escape out of the search field { + e.stopPropagation(); this.DOMSearchField().blur(); this.DOMPopupSearchResultsWindow().style.display = 'none'; this.DOMSearchClose().style.display = 'none'; @@ -226,7 +212,7 @@ function SearchBox(name, resultsPath, inFrame, label, extension) if (searchValue != "") // non-empty search { // set timer for search update - this.keyTimeout = setTimeout(this.name + '.Search()', + this.keyTimeout = setTimeout(this.Search.bind(this), this.keyTimeoutLength); } else // empty search field @@ -304,6 +290,7 @@ function SearchBox(name, resultsPath, inFrame, label, extension) } else if (e.keyCode==13 || e.keyCode==27) { + e.stopPropagation(); this.OnSelectItem(this.searchIndex); this.CloseSelectionWindow(); this.DOMSearchField().focus(); @@ -341,55 +328,70 @@ function SearchBox(name, resultsPath, inFrame, label, extension) idxChar = searchValue.substr(0, 2); } - var resultsPage; - var resultsPageWithSearch; - var hasResultsPage; + var jsFile; var idx = indexSectionsWithContent[this.searchIndex].indexOf(idxChar); if (idx!=-1) { var hexCode=idx.toString(16); - resultsPage = this.resultsPath + '/' + indexSectionNames[this.searchIndex] + '_' + hexCode + this.extension; - resultsPageWithSearch = resultsPage+'?'+escape(searchValue); - hasResultsPage = true; + jsFile = this.resultsPath + indexSectionNames[this.searchIndex] + '_' + hexCode + '.js'; } - else // nothing available for this search term - { - resultsPage = this.resultsPath + '/nomatches' + this.extension; - resultsPageWithSearch = resultsPage; - hasResultsPage = false; + + var loadJS = function(url, impl, loc){ + var scriptTag = document.createElement('script'); + scriptTag.src = url; + scriptTag.onload = impl; + scriptTag.onreadystatechange = impl; + loc.appendChild(scriptTag); } - window.frames.MSearchResults.location = resultsPageWithSearch; var domPopupSearchResultsWindow = this.DOMPopupSearchResultsWindow(); + var domSearchBox = this.DOMSearchBox(); + var domPopupSearchResults = this.DOMPopupSearchResults(); + var domSearchClose = this.DOMSearchClose(); + var resultsPath = this.resultsPath; + + var handleResults = function() { + document.getElementById("Loading").style.display="none"; + if (typeof searchData !== 'undefined') { + createResults(resultsPath); + document.getElementById("NoMatches").style.display="none"; + } + + if (idx!=-1) { + searchResults.Search(searchValue); + } else { // no file with search results => force empty search results + searchResults.Search('===='); + } - if (domPopupSearchResultsWindow.style.display!='block') - { - var domSearchBox = this.DOMSearchBox(); - this.DOMSearchClose().style.display = 'inline-block'; - 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'; - } + if (domPopupSearchResultsWindow.style.display!='block') + { + domSearchClose.style.display = 'inline-block'; + var left = getXPos(domSearchBox) + 150; + var top = getYPos(domSearchBox) + 20; + domPopupSearchResultsWindow.style.display = 'block'; + left -= domPopupSearchResults.offsetWidth; + var maxWidth = document.body.clientWidth; + var maxHeight = document.body.clientHeight; + var width = 300; + if (left<10) left=10; + if (width+left+8>maxWidth) width=maxWidth-left-8; + var height = 400; + if (height+top+8>maxHeight) height=maxHeight-top-8; + domPopupSearchResultsWindow.style.top = top + 'px'; + domPopupSearchResultsWindow.style.left = left + 'px'; + domPopupSearchResultsWindow.style.width = width + 'px'; + domPopupSearchResultsWindow.style.height = height + 'px'; + } + } + + if (jsFile) { + loadJS(jsFile, handleResults, this.DOMPopupSearchResultsWindow()); + } else { + handleResults(); } this.lastSearchValue = searchValue; - this.lastResultsPage = resultsPage; } // -------- Activation Functions @@ -403,22 +405,15 @@ function SearchBox(name, resultsPath, inFrame, label, extension) ) { this.DOMSearchBox().className = 'MSearchBoxActive'; - - var searchField = this.DOMSearchField(); - - if (searchField.value == this.searchLabel) // clear "Search" term upon entry - { - searchField.value = ''; - this.searchActive = true; - } + 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 = ''; + this.DOMSearchField().value = ''; } } } @@ -647,7 +642,7 @@ function SearchResults(name) } else // return focus to search field { - parent.document.getElementById("MSearchField").focus(); + document.getElementById("MSearchField").focus(); } } else if (this.lastKey==40) // Down @@ -677,8 +672,9 @@ function SearchResults(name) } else if (this.lastKey==27) // Escape { - parent.searchBox.CloseResultsWindow(); - parent.document.getElementById("MSearchField").focus(); + e.stopPropagation(); + searchBox.CloseResultsWindow(); + document.getElementById("MSearchField").focus(); } else if (this.lastKey==13) // Enter { @@ -720,8 +716,9 @@ function SearchResults(name) } else if (this.lastKey==27) // Escape { - parent.searchBox.CloseResultsWindow(); - parent.document.getElementById("MSearchField").focus(); + e.stopPropagation(); + searchBox.CloseResultsWindow(); + document.getElementById("MSearchField").focus(); } else if (this.lastKey==13) // Enter { @@ -744,9 +741,10 @@ function setClassAttr(elem,attr) elem.setAttribute('className',attr); } -function createResults() +function createResults(resultsPath) { var results = document.getElementById("SRResults"); + results.innerHTML = ''; for (var e=0; e(R!W8j_r#qQ#gnr4kAxdU#F0+OBry$Z+ z_0PMi;P|#{d%mw(dnw=jM%@$onTJa%@6Nm3`;2S#nwtVFJI#`U@2Q@@JCCctagvF- z8H=anvo~dTmJ2YA%wA6IHRv%{vxvUm|R)kgZeo zmX%Zb;mpflGZdXCTAgit`||AFzkI#z&(3d4(htA?U2FOL4WF6wY&TB#n3n*I4+hl| z*NBpo#FA92vEu822WQ%mvv4FO#qs` BFGc_W diff --git a/search/search_r.png b/search/search_r.png deleted file mode 100644 index 1af5d21ee13e070d7600f1c4657fde843b953a69..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 553 zcmeAS@N?(olHy`uVBq!ia0vp^LO?9c!2%@BXHTsJQY`6?zK#qG8~eHcB(ehe3dtTp zz6=bxGZ+|(`xqD=STHa&U1eaXVrO7DwS|Gf*oA>XrmV$GYcEhOQT(QLuS{~ooZ2P@v=Xc@RKW@Irliv8_;wroU0*)0O?temdsA~70jrdux+`@W7 z-N(<(C)L?hOO?KV{>8(jC{hpKsws)#Fh zvsO>IB+gb@b+rGWaO&!a9Z{!U+fV*s7TS>fdt&j$L%^U@Epd$~Nl7e8wMs5Z1yT$~ z28I^8hDN#u<{^fLRz?<9hUVG^237_Jy7tbuQ8eV{r(~v8;?@w8^gA7>fx*+&&t;uc GLK6VEQpiUD diff --git a/search/searchdata.js b/search/searchdata.js index 6c26dc78..3db57e8c 100644 --- a/search/searchdata.js +++ b/search/searchdata.js @@ -1,10 +1,11 @@ var indexSectionsWithContent = { - 0: "abcefgilmopqrsuvwx", - 1: "gi", - 2: "am", + 0: "1389:abcdefghilmnopqrstuvwx", + 1: "r", + 2: "m", 3: "aefgilmopqrswx", - 4: "abcefgilmopqrsuvwx" + 4: "abcefgilmopqrsuvwx", + 5: "nw" }; var indexSectionNames = @@ -13,7 +14,8 @@ var indexSectionNames = 1: "classes", 2: "namespaces", 3: "files", - 4: "functions" + 4: "functions", + 5: "pages" }; var indexSectionLabels = @@ -22,6 +24,7 @@ var indexSectionLabels = 1: "Data Structures", 2: "Namespaces", 3: "Files", - 4: "Functions" + 4: "Functions", + 5: "Pages" }; diff --git a/skgb_8f.html b/skgb_8f.html index 22871ccb..4789ab50 100644 --- a/skgb_8f.html +++ b/skgb_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: skgb.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    • @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    skgb.f File Reference
    +
    skgb.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine skgb (lugb, iseek, mseek, lskip, lgrib)
     This subprogram searches a file for the next grib 1 message.
     

    Detailed Description

    Search for next grib message.

    @@ -107,8 +113,8 @@

    Definition in file skgb.f.

    Function/Subroutine Documentation

    - -

    ◆ skgb()

    + +

    ◆ skgb()

    @@ -117,31 +123,31 @@

    subroutine skgb (   - LUGB, + lugb,   - ISEEK, + iseek,   - MSEEK, + mseek,   - LSKIP, + lskip,   - LGRIB  + lgrib  @@ -182,7 +188,7 @@

    • src
    • skgb.f
      • -
    • Generated by doxygen 1.9.1
      • +
    • Generated by doxygen 1.9.8

    diff --git a/skgb_8f.js b/skgb_8f.js index 3004b89e..385cd31c 100644 --- a/skgb_8f.js +++ b/skgb_8f.js @@ -1,4 +1,4 @@ var skgb_8f = [ - [ "skgb", "skgb_8f.html#a7654c30923c8fa28091b5cb300c93311", null ] + [ "skgb", "skgb_8f.html#a33d9c42574632a3c57ecc85d17c8e62a", null ] ]; \ No newline at end of file diff --git a/skgb_8f_source.html b/skgb_8f_source.html index 639d51e9..0cfb45fa 100644 --- a/skgb_8f_source.html +++ b/skgb_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: skgb.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,92 +81,100 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    skgb.f
    +
    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
    -
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    -
    skgb
    subroutine skgb(LUGB, ISEEK, MSEEK, LSKIP, LGRIB)
    This subprogram searches a file for the next grib 1 message.
    Definition: skgb.f:27
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Search for next grib message.
    +
    3C> @author Mark Iredell @date 1993-11-22
    +
    4
    +
    5C> This subprogram searches a file for the next grib 1 message.
    +
    6C> A grib 1 message is identified by its indicator section, i.e.
    +
    7C> an 8-byte sequence with 'grib' in bytes 1-4 and 1 in byte 8.
    +
    8C> If found, the length of the message is decoded from bytes 5-7.
    +
    9C> The search is done over a given section of the file.
    +
    10C> The search is terminated if an eof or i/o error is encountered.
    +
    11C>
    +
    12C> Program history log:
    +
    13C> - Mark Iredell 1993-11-22
    +
    14C> - Mark Iredell 1995-10-31 Add call to baread.
    +
    15C> - Mark Iredell 1997-03-14 Check for '7777'.
    +
    16C> - Stephen Gilbert 2001-12-05 Modified to also look for grib2 messages.
    +
    17C>
    +
    18C> @param[in] LUGB Integer logical unit of input grib file.
    +
    19C> @param[in] ISEEK Integer number of bytes to skip before search.
    +
    20C> @param[in] MSEEK Integer maximum number of bytes to search.
    +
    21C> @param[out] LSKIP Integer number of bytes to skip before message.
    +
    22C> @param[out] LGRIB Integer number of bytes in message (0 if not found).
    +
    23C>
    +
    24C> @author Mark Iredell @date 1993-11-22
    +
    25C-----------------------------------------------------------------------
    +
    +
    26 SUBROUTINE skgb(LUGB,ISEEK,MSEEK,LSKIP,LGRIB)
    +
    27 parameter(lseek=128)
    +
    28 CHARACTER Z(LSEEK)
    +
    29 CHARACTER Z4(4)
    +
    30C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    31 lgrib=0
    +
    32 ks=iseek
    +
    33 kn=min(lseek,mseek)
    +
    34 kz=lseek
    +
    35C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    36C LOOP UNTIL GRIB MESSAGE IS FOUND
    +
    37 dowhile(lgrib.EQ.0.AND.kn.GE.8.AND.kz.EQ.lseek)
    +
    38C READ PARTIAL SECTION
    +
    39 CALL baread(lugb,ks,kn,kz,z)
    +
    40 km=kz-8+1
    +
    41 k=0
    +
    42C 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
    +
    47C 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
    +
    54C 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
    +
    65C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    66 RETURN
    +
    +
    67 END
    +
    gbytec
    subroutine gbytec(in, iout, iskip, nbyte)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition gbytec.f:14
    +
    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/splitbard.png b/splitbard.png new file mode 100644 index 0000000000000000000000000000000000000000..8367416d757fd7b6dc4272b6432dc75a75abd068 GIT binary patch literal 282 zcmeAS@N?(olHy`uVBq!ia0vp^Yzz!63>-{AmhX=Jf@VhhFKy35^fiT zT~&lUj3=cDh^%3HDY9k5CEku}PHXNoNC(_$U3XPb&Q*ME25pT;2(*BOgAf<+R$lzakPG`kF31()Fx{L5Wrac|GQzjeE= zueY1`Ze{#x<8=S|`~MgGetGce)#vN&|J{Cd^tS%;tBYTo?+^d68<#n_Y_xx`J||4O V@QB{^CqU0Kc)I$ztaD0e0svEzbJzd? literal 0 HcmV?d00001 diff --git a/structmersenne__twister_1_1random__stat.html b/structmersenne__twister_1_1random__stat.html new file mode 100644 index 00000000..bf35f898 --- /dev/null +++ b/structmersenne__twister_1_1random__stat.html @@ -0,0 +1,172 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister::random_stat Type Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc 2.11.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    +
    + +
    +
    +Data Fields
    +
    mersenne_twister::random_stat Type Reference
    +
    +
    + + + + + + + + +

    +Data Fields

    real gset
     
    integer iset
     
    integer, dimension(0:n-1) mt
     
    +

    Detailed Description

    +
    +

    Definition at line 119 of file mersenne_twister.f.

    +

    Field Documentation

    + +

    ◆ gset

    + +
    +
    + + + + +
    real mersenne_twister::random_stat::gset
    +
    + +

    Definition at line 124 of file mersenne_twister.f.

    + +
    +
    + +

    ◆ iset

    + +
    +
    + + + + +
    integer mersenne_twister::random_stat::iset
    +
    + +

    Definition at line 123 of file mersenne_twister.f.

    + +
    +
    + +

    ◆ mt

    + +
    +
    + + + + +
    integer, dimension(0:n-1) mersenne_twister::random_stat::mt
    +
    + +

    Definition at line 122 of file mersenne_twister.f.

    + +
    +
    +
    The documentation for this type was generated from the following file: +
    +
    + + + + diff --git a/summary_8c.html b/summary_8c.html index 35ea21e8..1b8333b4 100644 --- a/summary_8c.html +++ b/summary_8c.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: summary.c File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,17 +76,23 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions | Variables
    -
    -
    summary.c File Reference
    +
    summary.c File Reference
    @@ -104,451 +110,310 @@

    Go to the source code of this file.

    - - + - + - + - + - + - + - + - + - +

    +

    Functions

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

    +

    Variables

    -double cpu_comm
    double cpu_comm
     
    -double f_bytes
    double f_bytes
     
    -double final_wall
    double final_wall
     
    -static FILE * fp = NULL
    static FILE * fp = NULL
     
    -struct time_data MPI_Abort_data
    struct time_data MPI_Abort_data
     
    -struct time_data MPI_Address_data
    struct time_data MPI_Address_data
     
    -struct time_data MPI_Allgather_data
    struct time_data MPI_Allgather_data
     
    -struct time_data MPI_Allgatherv_data
    struct time_data MPI_Allgatherv_data
     
    -struct time_data MPI_Allreduce_data
    struct time_data MPI_Allreduce_data
     
    -struct time_data MPI_Alltoall_data
    struct time_data MPI_Alltoall_data
     
    -struct time_data MPI_Alltoallv_data
    struct time_data MPI_Alltoallv_data
     
    -struct time_data MPI_Attr_delete_data
    struct time_data MPI_Attr_delete_data
     
    -struct time_data MPI_Attr_get_data
    struct time_data MPI_Attr_get_data
     
    -struct time_data MPI_Attr_put_data
    struct time_data MPI_Attr_put_data
     
    -struct time_data MPI_Barrier_data
    struct time_data MPI_Barrier_data
     
    -struct time_data MPI_Bcast_data
    struct time_data MPI_Bcast_data
     
    -struct time_data MPI_Bsend_data
    struct time_data MPI_Bsend_data
     
    -struct time_data MPI_Bsend_init_data
    struct time_data MPI_Bsend_init_data
     
    -struct time_data MPI_Buffer_attach_data
    struct time_data MPI_Buffer_attach_data
     
    -struct time_data MPI_Buffer_detach_data
    struct time_data MPI_Buffer_detach_data
     
    -struct time_data MPI_Cancel_data
    struct time_data MPI_Cancel_data
     
    -struct time_data MPI_Cart_coords_data
    struct time_data MPI_Cart_coords_data
     
    -struct time_data MPI_Cart_create_data
    struct time_data MPI_Cart_create_data
     
    -struct time_data MPI_Cart_get_data
    struct time_data MPI_Cart_get_data
     
    -struct time_data MPI_Cart_map_data
    struct time_data MPI_Cart_map_data
     
    -struct time_data MPI_Cart_rank_data
    struct time_data MPI_Cart_rank_data
     
    -struct time_data MPI_Cart_shift_data
    struct time_data MPI_Cart_shift_data
     
    -struct time_data MPI_Cart_sub_data
    struct time_data MPI_Cart_sub_data
     
    -struct time_data MPI_Cartdim_get_data
    struct time_data MPI_Cartdim_get_data
     
    -struct time_data MPI_Comm_compare_data
    struct time_data MPI_Comm_compare_data
     
    -struct time_data MPI_Comm_create_data
    struct time_data MPI_Comm_create_data
     
    -struct time_data MPI_Comm_dup_data
    struct time_data MPI_Comm_dup_data
     
    -struct time_data MPI_Comm_free_data
    struct time_data MPI_Comm_free_data
     
    -struct time_data MPI_Comm_group_data
    struct time_data MPI_Comm_group_data
     
    -struct time_data MPI_Comm_rank_data
    struct time_data MPI_Comm_rank_data
     
    -struct time_data MPI_Comm_remote_group_data
    struct time_data MPI_Comm_remote_group_data
     
    -struct time_data MPI_Comm_remote_size_data
    struct time_data MPI_Comm_remote_size_data
     
    -struct time_data MPI_Comm_size_data
    struct time_data MPI_Comm_size_data
     
    -struct time_data MPI_Comm_split_data
    struct time_data MPI_Comm_split_data
     
    -struct time_data MPI_Comm_test_inter_data
    struct time_data MPI_Comm_test_inter_data
     
    -struct time_data MPI_Dims_create_data
    struct time_data MPI_Dims_create_data
     
    -struct time_data MPI_Errhandler_create_data
    struct time_data MPI_Errhandler_create_data
     
    -struct time_data MPI_Errhandler_free_data
    struct time_data MPI_Errhandler_free_data
     
    -struct time_data MPI_Errhandler_get_data
    struct time_data MPI_Errhandler_get_data
     
    -struct time_data MPI_Errhandler_set_data
    struct time_data MPI_Errhandler_set_data
     
    -struct time_data MPI_Error_class_data
    struct time_data MPI_Error_class_data
     
    -struct time_data MPI_Error_string_data
    struct time_data MPI_Error_string_data
     
    -struct time_data MPI_Gather_data
    struct time_data MPI_Gather_data
     
    -struct time_data MPI_Gatherv_data
    struct time_data MPI_Gatherv_data
     
    -struct time_data MPI_Get_count_data
    struct time_data MPI_Get_count_data
     
    -struct time_data MPI_Get_elements_data
    struct time_data MPI_Get_elements_data
     
    -struct time_data MPI_Get_processor_name_data
    struct time_data MPI_Get_processor_name_data
     
    -struct time_data MPI_Graph_create_data
    struct time_data MPI_Graph_create_data
     
    -struct time_data MPI_Graph_get_data
    struct time_data MPI_Graph_get_data
     
    -struct time_data MPI_Graph_map_data
    struct time_data MPI_Graph_map_data
     
    -struct time_data MPI_Graph_neighbors_count_data
    struct time_data MPI_Graph_neighbors_count_data
     
    -struct time_data MPI_Graph_neighbors_data
    struct time_data MPI_Graph_neighbors_data
     
    -struct time_data MPI_Graphdims_get_data
    struct time_data MPI_Graphdims_get_data
     
    -struct time_data MPI_Group_compare_data
    struct time_data MPI_Group_compare_data
     
    -struct time_data MPI_Group_difference_data
    struct time_data MPI_Group_difference_data
     
    -struct time_data MPI_Group_excl_data
    struct time_data MPI_Group_excl_data
     
    -struct time_data MPI_Group_free_data
    struct time_data MPI_Group_free_data
     
    -struct time_data MPI_Group_incl_data
    struct time_data MPI_Group_incl_data
     
    -struct time_data MPI_Group_intersection_data
    struct time_data MPI_Group_intersection_data
     
    -struct time_data MPI_Group_range_excl_data
    struct time_data MPI_Group_range_excl_data
     
    -struct time_data MPI_Group_range_incl_data
    struct time_data MPI_Group_range_incl_data
     
    -struct time_data MPI_Group_rank_data
    struct time_data MPI_Group_rank_data
     
    -struct time_data MPI_Group_size_data
    struct time_data MPI_Group_size_data
     
    -struct time_data MPI_Group_translate_ranks_data
    struct time_data MPI_Group_translate_ranks_data
     
    -struct time_data MPI_Group_union_data
    struct time_data MPI_Group_union_data
     
    -struct time_data MPI_Ibsend_data
    struct time_data MPI_Ibsend_data
     
    -struct time_data MPI_Initialized_data
    struct time_data MPI_Initialized_data
     
    -struct time_data MPI_Intercomm_create_data
    struct time_data MPI_Intercomm_create_data
     
    -struct time_data MPI_Intercomm_merge_data
    struct time_data MPI_Intercomm_merge_data
     
    -struct time_data MPI_Iprobe_data
    struct time_data MPI_Iprobe_data
     
    -struct time_data MPI_Irecv_data
    struct time_data MPI_Irecv_data
     
    -struct time_data MPI_Irsend_data
    struct time_data MPI_Irsend_data
     
    -struct time_data MPI_Isend_data
    struct time_data MPI_Isend_data
     
    -struct time_data MPI_Issend_data
    struct time_data MPI_Issend_data
     
    -struct time_data MPI_Keyval_create_data
    struct time_data MPI_Keyval_create_data
     
    -struct time_data MPI_Keyval_free_data
    struct time_data MPI_Keyval_free_data
     
    -struct time_data MPI_Op_create_data
    struct time_data MPI_Op_create_data
     
    -struct time_data MPI_Op_free_data
    struct time_data MPI_Op_free_data
     
    -struct time_data MPI_Pack_data
    struct time_data MPI_Pack_data
     
    -struct time_data MPI_Pack_size_data
    struct time_data MPI_Pack_size_data
     
    -struct time_data MPI_Probe_data
    struct time_data MPI_Probe_data
     
    -struct time_data MPI_Recv_data
    struct time_data MPI_Recv_data
     
    -struct time_data MPI_Recv_init_data
    struct time_data MPI_Recv_init_data
     
    -struct time_data MPI_Reduce_data
    struct time_data MPI_Reduce_data
     
    -struct time_data MPI_Reduce_scatter_data
    struct time_data MPI_Reduce_scatter_data
     
    -struct time_data MPI_Request_free_data
    struct time_data MPI_Request_free_data
     
    -struct time_data MPI_Rsend_data
    struct time_data MPI_Rsend_data
     
    -struct time_data MPI_Rsend_init_data
    struct time_data MPI_Rsend_init_data
     
    -struct time_data MPI_Scan_data
    struct time_data MPI_Scan_data
     
    -struct time_data MPI_Scatter_data
    struct time_data MPI_Scatter_data
     
    -struct time_data MPI_Scatterv_data
    struct time_data MPI_Scatterv_data
     
    -struct time_data MPI_Send_data
    struct time_data MPI_Send_data
     
    -struct time_data MPI_Send_init_data
    struct time_data MPI_Send_init_data
     
    -struct time_data MPI_Sendrecv_data
    struct time_data MPI_Sendrecv_data
     
    -struct time_data MPI_Sendrecv_replace_data
    struct time_data MPI_Sendrecv_replace_data
     
    -struct time_data MPI_Ssend_data
    struct time_data MPI_Ssend_data
     
    -struct time_data MPI_Ssend_init_data
    struct time_data MPI_Ssend_init_data
     
    -struct time_data MPI_Start_data
    struct time_data MPI_Start_data
     
    -struct time_data MPI_Startall_data
    struct time_data MPI_Startall_data
     
    -struct time_data MPI_Test_cancelled_data
    struct time_data MPI_Test_cancelled_data
     
    -struct time_data MPI_Test_data
    struct time_data MPI_Test_data
     
    -struct time_data MPI_Testall_data
    struct time_data MPI_Testall_data
     
    -struct time_data MPI_Testany_data
    struct time_data MPI_Testany_data
     
    -struct time_data MPI_Testsome_data
    struct time_data MPI_Testsome_data
     
    -struct time_data MPI_Topo_test_data
    struct time_data MPI_Topo_test_data
     
    -struct time_data MPI_Type_commit_data
    struct time_data MPI_Type_commit_data
     
    -struct time_data MPI_Type_contiguous_data
    struct time_data MPI_Type_contiguous_data
     
    -struct time_data MPI_Type_extent_data
    struct time_data MPI_Type_extent_data
     
    -struct time_data MPI_Type_free_data
    struct time_data MPI_Type_free_data
     
    -struct time_data MPI_Type_hindexed_data
    struct time_data MPI_Type_hindexed_data
     
    -struct time_data MPI_Type_hvector_data
    struct time_data MPI_Type_hvector_data
     
    -struct time_data MPI_Type_indexed_data
    struct time_data MPI_Type_indexed_data
     
    -struct time_data MPI_Type_lb_data
    struct time_data MPI_Type_lb_data
     
    -struct time_data MPI_Type_size_data
    struct time_data MPI_Type_size_data
     
    -struct time_data MPI_Type_struct_data
    struct time_data MPI_Type_struct_data
     
    -struct time_data MPI_Type_ub_data
    struct time_data MPI_Type_ub_data
     
    -struct time_data MPI_Type_vector_data
    struct time_data MPI_Type_vector_data
     
    -struct time_data MPI_Unpack_data
    struct time_data MPI_Unpack_data
     
    -struct time_data MPI_Wait_data
    struct time_data MPI_Wait_data
     
    -struct time_data MPI_Waitall_data
    struct time_data MPI_Waitall_data
     
    -struct time_data MPI_Waitany_data
    struct time_data MPI_Waitany_data
     
    -struct time_data MPI_Waitsome_data
    struct time_data MPI_Waitsome_data
     
    -struct time_data MPI_Wtick_data
    struct time_data MPI_Wtick_data
     
    -struct time_data MPI_Wtime_data
    struct time_data MPI_Wtime_data
     
    -int msglen
    int msglen
     
    -int mypid
    int mypid
     
    -int numtask
    int numtask
     
    -int procid_0
    int procid_0
     
    -int profile
    int profile
     
    -double start_wall
    double start_wall
     
    -double tbytes
    double tbytes
     
    -double tcpu
    double tcpu
     
    -double tot_wall
    double tot_wall
     
    -int trace_flag
    int trace_flag
     
    -double twall
    double twall
     
    -double wall_comm
    double wall_comm
     

    Detailed Description

    @@ -564,8 +429,8 @@

    Definition in file summary.c.

    Function Documentation

    - -

    ◆ bucket()

    + +

    ◆ bucket()

    @@ -592,8 +457,8 @@

    -

    ◆ cputim()

    + +

    ◆ cputim()

    @@ -631,8 +496,8 @@

    -

    ◆ elapse()

    + +

    ◆ elapse()

    @@ -659,8 +524,8 @@

    -

    ◆ end_timer()

    + +

    ◆ end_timer()

    @@ -687,8 +552,8 @@

    -

    ◆ print_timing()

    + +

    ◆ print_timing()

    @@ -726,8 +591,8 @@

    -

    ◆ resource()

    + +

    ◆ resource()

    @@ -747,8 +612,8 @@

    -

    ◆ start_()

    + +

    ◆ start_()

    @@ -768,8 +633,8 @@

    -

    ◆ start_timer()

    + +

    ◆ start_timer()

    @@ -796,8 +661,8 @@

    -

    ◆ summary_()

    + +

    ◆ summary_()

    @@ -822,6 +687,2271 @@

    Definition at line 437 of file summary.c.

    +

    +
    +

    Variable Documentation

    + +

    ◆ cpu_comm

    + +
    +
    + + + + +
    double cpu_comm
    +
    + +

    Definition at line 47 of file summary.c.

    + +
    +
    + +

    ◆ f_bytes

    + +
    +
    + + + + +
    double f_bytes
    +
    + +

    Definition at line 45 of file summary.c.

    + +
    +
    + +

    ◆ final_wall

    + +
    +
    + + + + +
    double final_wall
    +
    + +

    Definition at line 46 of file summary.c.

    + +
    +
    + +

    ◆ fp

    + +
    +
    + + + + + +
    + + + + +
    FILE* fp = NULL
    +     		+static
    +
    + +

    Definition at line 40 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Abort_data

    + +
    +
    + + + + +
    struct time_data MPI_Abort_data
    +
    + +

    Definition at line 112 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Address_data

    + +
    +
    + + + + +
    struct time_data MPI_Address_data
    +
    + +

    Definition at line 123 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Allgather_data

    + +
    +
    + + + + +
    struct time_data MPI_Allgather_data
    +
    + +

    Definition at line 66 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Allgatherv_data

    + +
    +
    + + + + +
    struct time_data MPI_Allgatherv_data
    +
    + +

    Definition at line 67 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Allreduce_data

    + +
    +
    + + + + +
    struct time_data MPI_Allreduce_data
    +
    + +

    Definition at line 68 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Alltoall_data

    + +
    +
    + + + + +
    struct time_data MPI_Alltoall_data
    +
    + +

    Definition at line 69 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Alltoallv_data

    + +
    +
    + + + + +
    struct time_data MPI_Alltoallv_data
    +
    + +

    Definition at line 70 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Attr_delete_data

    + +
    +
    + + + + +
    struct time_data MPI_Attr_delete_data
    +
    + +

    Definition at line 82 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Attr_get_data

    + +
    +
    + + + + +
    struct time_data MPI_Attr_get_data
    +
    + +

    Definition at line 83 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Attr_put_data

    + +
    +
    + + + + +
    struct time_data MPI_Attr_put_data
    +
    + +

    Definition at line 84 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Barrier_data

    + +
    +
    + + + + +
    struct time_data MPI_Barrier_data
    +
    + +

    Definition at line 71 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Bcast_data

    + +
    +
    + + + + +
    struct time_data MPI_Bcast_data
    +
    + +

    Definition at line 72 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Bsend_data

    + +
    +
    + + + + +
    struct time_data MPI_Bsend_data
    +
    + +

    Definition at line 124 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Bsend_init_data

    + +
    +
    + + + + +
    struct time_data MPI_Bsend_init_data
    +
    + +

    Definition at line 125 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Buffer_attach_data

    + +
    +
    + + + + +
    struct time_data MPI_Buffer_attach_data
    +
    + +

    Definition at line 126 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Buffer_detach_data

    + +
    +
    + + + + +
    struct time_data MPI_Buffer_detach_data
    +
    + +

    Definition at line 127 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cancel_data

    + +
    +
    + + + + +
    struct time_data MPI_Cancel_data
    +
    + +

    Definition at line 128 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_coords_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_coords_data
    +
    + +

    Definition at line 175 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_create_data
    +
    + +

    Definition at line 176 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_get_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_get_data
    +
    + +

    Definition at line 177 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_map_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_map_data
    +
    + +

    Definition at line 178 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_rank_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_rank_data
    +
    + +

    Definition at line 179 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_shift_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_shift_data
    +
    + +

    Definition at line 180 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cart_sub_data

    + +
    +
    + + + + +
    struct time_data MPI_Cart_sub_data
    +
    + +

    Definition at line 181 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Cartdim_get_data

    + +
    +
    + + + + +
    struct time_data MPI_Cartdim_get_data
    +
    + +

    Definition at line 182 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_compare_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_compare_data
    +
    + +

    Definition at line 85 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_create_data
    +
    + +

    Definition at line 86 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_dup_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_dup_data
    +
    + +

    Definition at line 87 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_free_data
    +
    + +

    Definition at line 88 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_group_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_group_data
    +
    + +

    Definition at line 89 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_rank_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_rank_data
    +
    + +

    Definition at line 90 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_remote_group_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_remote_group_data
    +
    + +

    Definition at line 91 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_remote_size_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_remote_size_data
    +
    + +

    Definition at line 92 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_size_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_size_data
    +
    + +

    Definition at line 93 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_split_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_split_data
    +
    + +

    Definition at line 94 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Comm_test_inter_data

    + +
    +
    + + + + +
    struct time_data MPI_Comm_test_inter_data
    +
    + +

    Definition at line 95 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Dims_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Dims_create_data
    +
    + +

    Definition at line 183 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Errhandler_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Errhandler_create_data
    +
    + +

    Definition at line 114 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Errhandler_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Errhandler_free_data
    +
    + +

    Definition at line 115 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Errhandler_get_data

    + +
    +
    + + + + +
    struct time_data MPI_Errhandler_get_data
    +
    + +

    Definition at line 116 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Errhandler_set_data

    + +
    +
    + + + + +
    struct time_data MPI_Errhandler_set_data
    +
    + +

    Definition at line 118 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Error_class_data

    + +
    +
    + + + + +
    struct time_data MPI_Error_class_data
    +
    + +

    Definition at line 113 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Error_string_data

    + +
    +
    + + + + +
    struct time_data MPI_Error_string_data
    +
    + +

    Definition at line 117 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Gather_data

    + +
    +
    + + + + +
    struct time_data MPI_Gather_data
    +
    + +

    Definition at line 73 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Gatherv_data

    + +
    +
    + + + + +
    struct time_data MPI_Gatherv_data
    +
    + +

    Definition at line 74 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Get_count_data

    + +
    +
    + + + + +
    struct time_data MPI_Get_count_data
    +
    + +

    Definition at line 133 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Get_elements_data

    + +
    +
    + + + + +
    struct time_data MPI_Get_elements_data
    +
    + +

    Definition at line 132 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Get_processor_name_data

    + +
    +
    + + + + +
    struct time_data MPI_Get_processor_name_data
    +
    + +

    Definition at line 119 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Graph_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Graph_create_data
    +
    + +

    Definition at line 184 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Graph_get_data

    + +
    +
    + + + + +
    struct time_data MPI_Graph_get_data
    +
    + +

    Definition at line 185 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Graph_map_data

    + +
    +
    + + + + +
    struct time_data MPI_Graph_map_data
    +
    + +

    Definition at line 186 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Graph_neighbors_count_data

    + +
    +
    + + + + +
    struct time_data MPI_Graph_neighbors_count_data
    +
    + +

    Definition at line 188 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Graph_neighbors_data

    + +
    +
    + + + + +
    struct time_data MPI_Graph_neighbors_data
    +
    + +

    Definition at line 187 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Graphdims_get_data

    + +
    +
    + + + + +
    struct time_data MPI_Graphdims_get_data
    +
    + +

    Definition at line 189 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_compare_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_compare_data
    +
    + +

    Definition at line 96 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_difference_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_difference_data
    +
    + +

    Definition at line 97 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_excl_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_excl_data
    +
    + +

    Definition at line 98 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_free_data
    +
    + +

    Definition at line 99 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_incl_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_incl_data
    +
    + +

    Definition at line 100 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_intersection_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_intersection_data
    +
    + +

    Definition at line 101 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_range_excl_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_range_excl_data
    +
    + +

    Definition at line 103 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_range_incl_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_range_incl_data
    +
    + +

    Definition at line 104 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_rank_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_rank_data
    +
    + +

    Definition at line 102 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_size_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_size_data
    +
    + +

    Definition at line 105 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_translate_ranks_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_translate_ranks_data
    +
    + +

    Definition at line 106 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Group_union_data

    + +
    +
    + + + + +
    struct time_data MPI_Group_union_data
    +
    + +

    Definition at line 107 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Ibsend_data

    + +
    +
    + + + + +
    struct time_data MPI_Ibsend_data
    +
    + +

    Definition at line 134 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Initialized_data

    + +
    +
    + + + + +
    struct time_data MPI_Initialized_data
    +
    + +

    Definition at line 120 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Intercomm_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Intercomm_create_data
    +
    + +

    Definition at line 108 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Intercomm_merge_data

    + +
    +
    + + + + +
    struct time_data MPI_Intercomm_merge_data
    +
    + +

    Definition at line 109 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Iprobe_data

    + +
    +
    + + + + +
    struct time_data MPI_Iprobe_data
    +
    + +

    Definition at line 135 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Irecv_data

    + +
    +
    + + + + +
    struct time_data MPI_Irecv_data
    +
    + +

    Definition at line 136 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Irsend_data

    + +
    +
    + + + + +
    struct time_data MPI_Irsend_data
    +
    + +

    Definition at line 137 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Isend_data

    + +
    +
    + + + + +
    struct time_data MPI_Isend_data
    +
    + +

    Definition at line 138 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Issend_data

    + +
    +
    + + + + +
    struct time_data MPI_Issend_data
    +
    + +

    Definition at line 139 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Keyval_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Keyval_create_data
    +
    + +

    Definition at line 110 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Keyval_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Keyval_free_data
    +
    + +

    Definition at line 111 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Op_create_data

    + +
    +
    + + + + +
    struct time_data MPI_Op_create_data
    +
    + +

    Definition at line 75 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Op_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Op_free_data
    +
    + +

    Definition at line 76 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Pack_data

    + +
    +
    + + + + +
    struct time_data MPI_Pack_data
    +
    + +

    Definition at line 140 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Pack_size_data

    + +
    +
    + + + + +
    struct time_data MPI_Pack_size_data
    +
    + +

    Definition at line 141 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Probe_data

    + +
    +
    + + + + +
    struct time_data MPI_Probe_data
    +
    + +

    Definition at line 142 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Recv_data

    + +
    +
    + + + + +
    struct time_data MPI_Recv_data
    +
    + +

    Definition at line 143 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Recv_init_data

    + +
    +
    + + + + +
    struct time_data MPI_Recv_init_data
    +
    + +

    Definition at line 130 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Reduce_data

    + +
    +
    + + + + +
    struct time_data MPI_Reduce_data
    +
    + +

    Definition at line 78 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Reduce_scatter_data

    + +
    +
    + + + + +
    struct time_data MPI_Reduce_scatter_data
    +
    + +

    Definition at line 77 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Request_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Request_free_data
    +
    + +

    Definition at line 129 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Rsend_data

    + +
    +
    + + + + +
    struct time_data MPI_Rsend_data
    +
    + +

    Definition at line 144 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Rsend_init_data

    + +
    +
    + + + + +
    struct time_data MPI_Rsend_init_data
    +
    + +

    Definition at line 145 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Scan_data

    + +
    +
    + + + + +
    struct time_data MPI_Scan_data
    +
    + +

    Definition at line 79 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Scatter_data

    + +
    +
    + + + + +
    struct time_data MPI_Scatter_data
    +
    + +

    Definition at line 80 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Scatterv_data

    + +
    +
    + + + + +
    struct time_data MPI_Scatterv_data
    +
    + +

    Definition at line 81 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Send_data

    + +
    +
    + + + + +
    struct time_data MPI_Send_data
    +
    + +

    Definition at line 146 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Send_init_data

    + +
    +
    + + + + +
    struct time_data MPI_Send_init_data
    +
    + +

    Definition at line 131 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Sendrecv_data

    + +
    +
    + + + + +
    struct time_data MPI_Sendrecv_data
    +
    + +

    Definition at line 147 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Sendrecv_replace_data

    + +
    +
    + + + + +
    struct time_data MPI_Sendrecv_replace_data
    +
    + +

    Definition at line 148 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Ssend_data

    + +
    +
    + + + + +
    struct time_data MPI_Ssend_data
    +
    + +

    Definition at line 149 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Ssend_init_data

    + +
    +
    + + + + +
    struct time_data MPI_Ssend_init_data
    +
    + +

    Definition at line 150 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Start_data

    + +
    +
    + + + + +
    struct time_data MPI_Start_data
    +
    + +

    Definition at line 151 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Startall_data

    + +
    +
    + + + + +
    struct time_data MPI_Startall_data
    +
    + +

    Definition at line 152 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Test_cancelled_data

    + +
    +
    + + + + +
    struct time_data MPI_Test_cancelled_data
    +
    + +

    Definition at line 156 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Test_data

    + +
    +
    + + + + +
    struct time_data MPI_Test_data
    +
    + +

    Definition at line 153 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Testall_data

    + +
    +
    + + + + +
    struct time_data MPI_Testall_data
    +
    + +

    Definition at line 154 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Testany_data

    + +
    +
    + + + + +
    struct time_data MPI_Testany_data
    +
    + +

    Definition at line 155 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Testsome_data

    + +
    +
    + + + + +
    struct time_data MPI_Testsome_data
    +
    + +

    Definition at line 157 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Topo_test_data

    + +
    +
    + + + + +
    struct time_data MPI_Topo_test_data
    +
    + +

    Definition at line 190 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_commit_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_commit_data
    +
    + +

    Definition at line 158 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_contiguous_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_contiguous_data
    +
    + +

    Definition at line 159 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_extent_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_extent_data
    +
    + +

    Definition at line 160 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_free_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_free_data
    +
    + +

    Definition at line 161 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_hindexed_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_hindexed_data
    +
    + +

    Definition at line 162 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_hvector_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_hvector_data
    +
    + +

    Definition at line 163 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_indexed_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_indexed_data
    +
    + +

    Definition at line 164 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_lb_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_lb_data
    +
    + +

    Definition at line 165 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_size_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_size_data
    +
    + +

    Definition at line 166 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_struct_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_struct_data
    +
    + +

    Definition at line 167 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_ub_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_ub_data
    +
    + +

    Definition at line 168 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Type_vector_data

    + +
    +
    + + + + +
    struct time_data MPI_Type_vector_data
    +
    + +

    Definition at line 169 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Unpack_data

    + +
    +
    + + + + +
    struct time_data MPI_Unpack_data
    +
    + +

    Definition at line 170 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Wait_data

    + +
    +
    + + + + +
    struct time_data MPI_Wait_data
    +
    + +

    Definition at line 171 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Waitall_data

    + +
    +
    + + + + +
    struct time_data MPI_Waitall_data
    +
    + +

    Definition at line 172 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Waitany_data

    + +
    +
    + + + + +
    struct time_data MPI_Waitany_data
    +
    + +

    Definition at line 173 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Waitsome_data

    + +
    +
    + + + + +
    struct time_data MPI_Waitsome_data
    +
    + +

    Definition at line 174 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Wtick_data

    + +
    +
    + + + + +
    struct time_data MPI_Wtick_data
    +
    + +

    Definition at line 121 of file summary.c.

    + +
    +
    + +

    ◆ MPI_Wtime_data

    + +
    +
    + + + + +
    struct time_data MPI_Wtime_data
    +
    + +

    Definition at line 122 of file summary.c.

    + +
    +
    + +

    ◆ msglen

    + +
    +
    + + + + +
    int msglen
    +
    + +

    Definition at line 43 of file summary.c.

    + +
    +
    + +

    ◆ mypid

    + +
    +
    + + + + +
    int mypid
    +
    + +

    Definition at line 41 of file summary.c.

    + +
    +
    + +

    ◆ numtask

    + +
    +
    + + + + +
    int numtask
    +
    + +

    Definition at line 41 of file summary.c.

    + +
    +
    + +

    ◆ procid_0

    + +
    +
    + + + + +
    int procid_0
    +
    + +

    Definition at line 42 of file summary.c.

    + +
    +
    + +

    ◆ profile

    + +
    +
    + + + + +
    int profile
    +
    + +

    Definition at line 43 of file summary.c.

    + +
    +
    + +

    ◆ start_wall

    + +
    +
    + + + + +
    double start_wall
    +
    + +

    Definition at line 46 of file summary.c.

    + +
    +
    + +

    ◆ tbytes

    + +
    +
    + + + + +
    double tbytes
    +
    + +

    Definition at line 45 of file summary.c.

    + +
    +
    + +

    ◆ tcpu

    + +
    +
    + + + + +
    double tcpu
    +
    + +

    Definition at line 45 of file summary.c.

    + +
    +
    + +

    ◆ tot_wall

    + +
    +
    + + + + +
    double tot_wall
    +
    + +

    Definition at line 46 of file summary.c.

    + +
    +
    + +

    ◆ trace_flag

    + +
    +
    + + + + +
    int trace_flag
    +
    + +

    Definition at line 44 of file summary.c.

    + +
    +
    + +

    ◆ twall

    + +
    +
    + + + + +
    double twall
    +
    + +

    Definition at line 45 of file summary.c.

    + +
    +
    + +

    ◆ wall_comm

    + +
    +
    + + + + +
    double wall_comm
    +
    + +

    Definition at line 47 of file summary.c.

    +

    @@ -830,7 +2960,7 @@

    diff --git a/summary_8c.js b/summary_8c.js index 96c72d7c..3401d7e1 100644 --- a/summary_8c.js +++ b/summary_8c.js @@ -8,146 +8,5 @@ var summary_8c = [ "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 ] + [ "summary_", "summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110", null ] ]; \ No newline at end of file diff --git a/summary_8c_source.html b/summary_8c_source.html index 09a3e9c7..918ad526 100644 --- a/summary_8c_source.html +++ b/summary_8c_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: summary.c Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,442 +81,466 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    summary.c
    +
    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 }
    -
    print_timing
    void print_timing(char *string, struct time_data *time)
    Definition: summary.c:381
    -
    resource
    void resource()
    Definition: summary.c:299
    -
    elapse
    void elapse(double *timer)
    Definition: summary.c:211
    -
    summary_
    void summary_(int *returnVal)
    Definition: summary.c:437
    -
    cputim
    void cputim(double *usr, double *sys)
    Definition: summary.c:234
    -
    start_timer
    void start_timer(struct time_data *time)
    Definition: summary.c:260
    -
    end_timer
    void end_timer(struct time_data *time)
    Definition: summary.c:279
    -
    bucket
    int bucket(int lng)
    Definition: summary.c:196
    -
    start_
    void start_()
    Definition: summary.c:458
    +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
    +
    40static FILE *fp = NULL;
    +
    41int numtask, mypid;
    +
    42int procid_0;
    +
    43int profile, msglen;
    +
    44int trace_flag;
    +
    45double tcpu, twall, tbytes, f_bytes;
    +
    46double tot_wall, final_wall, start_wall;
    +
    47double cpu_comm, wall_comm;
    +
    48#ifdef _AIX
    +
    49extern double rtc ();
    +
    50#endif
    +
    51struct 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
    +
    66struct time_data MPI_Allgather_data;
    +
    67struct time_data MPI_Allgatherv_data;
    +
    68struct time_data MPI_Allreduce_data;
    +
    69struct time_data MPI_Alltoall_data;
    +
    70struct time_data MPI_Alltoallv_data;
    +
    71struct time_data MPI_Barrier_data;
    +
    72struct time_data MPI_Bcast_data;
    +
    73struct time_data MPI_Gather_data;
    +
    74struct time_data MPI_Gatherv_data;
    +
    75struct time_data MPI_Op_create_data;
    +
    76struct time_data MPI_Op_free_data;
    +
    77struct time_data MPI_Reduce_scatter_data;
    +
    78struct time_data MPI_Reduce_data;
    +
    79struct time_data MPI_Scan_data;
    +
    80struct time_data MPI_Scatter_data;
    +
    81struct time_data MPI_Scatterv_data;
    +
    82struct time_data MPI_Attr_delete_data;
    +
    83struct time_data MPI_Attr_get_data;
    +
    84struct time_data MPI_Attr_put_data;
    +
    85struct time_data MPI_Comm_compare_data;
    +
    86struct time_data MPI_Comm_create_data;
    +
    87struct time_data MPI_Comm_dup_data;
    +
    88struct time_data MPI_Comm_free_data;
    +
    89struct time_data MPI_Comm_group_data;
    +
    90struct time_data MPI_Comm_rank_data;
    +
    91struct time_data MPI_Comm_remote_group_data;
    +
    92struct time_data MPI_Comm_remote_size_data;
    +
    93struct time_data MPI_Comm_size_data;
    +
    94struct time_data MPI_Comm_split_data;
    +
    95struct time_data MPI_Comm_test_inter_data;
    +
    96struct time_data MPI_Group_compare_data;
    +
    97struct time_data MPI_Group_difference_data;
    +
    98struct time_data MPI_Group_excl_data;
    +
    99struct time_data MPI_Group_free_data;
    +
    100struct time_data MPI_Group_incl_data;
    +
    101struct time_data MPI_Group_intersection_data;
    +
    102struct time_data MPI_Group_rank_data;
    +
    103struct time_data MPI_Group_range_excl_data;
    +
    104struct time_data MPI_Group_range_incl_data;
    +
    105struct time_data MPI_Group_size_data;
    +
    106struct time_data MPI_Group_translate_ranks_data;
    +
    107struct time_data MPI_Group_union_data;
    +
    108struct time_data MPI_Intercomm_create_data;
    +
    109struct time_data MPI_Intercomm_merge_data;
    +
    110struct time_data MPI_Keyval_create_data;
    +
    111struct time_data MPI_Keyval_free_data;
    +
    112struct time_data MPI_Abort_data;
    +
    113struct time_data MPI_Error_class_data;
    +
    114struct time_data MPI_Errhandler_create_data;
    +
    115struct time_data MPI_Errhandler_free_data;
    +
    116struct time_data MPI_Errhandler_get_data;
    +
    117struct time_data MPI_Error_string_data;
    +
    118struct time_data MPI_Errhandler_set_data;
    +
    119struct time_data MPI_Get_processor_name_data;
    +
    120struct time_data MPI_Initialized_data;
    +
    121struct time_data MPI_Wtick_data;
    +
    122struct time_data MPI_Wtime_data;
    +
    123struct time_data MPI_Address_data;
    +
    124struct time_data MPI_Bsend_data;
    +
    125struct time_data MPI_Bsend_init_data;
    +
    126struct time_data MPI_Buffer_attach_data;
    +
    127struct time_data MPI_Buffer_detach_data;
    +
    128struct time_data MPI_Cancel_data;
    +
    129struct time_data MPI_Request_free_data;
    +
    130struct time_data MPI_Recv_init_data;
    +
    131struct time_data MPI_Send_init_data;
    +
    132struct time_data MPI_Get_elements_data;
    +
    133struct time_data MPI_Get_count_data;
    +
    134struct time_data MPI_Ibsend_data;
    +
    135struct time_data MPI_Iprobe_data;
    +
    136struct time_data MPI_Irecv_data;
    +
    137struct time_data MPI_Irsend_data;
    +
    138struct time_data MPI_Isend_data;
    +
    139struct time_data MPI_Issend_data;
    +
    140struct time_data MPI_Pack_data;
    +
    141struct time_data MPI_Pack_size_data;
    +
    142struct time_data MPI_Probe_data;
    +
    143struct time_data MPI_Recv_data;
    +
    144struct time_data MPI_Rsend_data;
    +
    145struct time_data MPI_Rsend_init_data;
    +
    146struct time_data MPI_Send_data;
    +
    147struct time_data MPI_Sendrecv_data;
    +
    148struct time_data MPI_Sendrecv_replace_data;
    +
    149struct time_data MPI_Ssend_data;
    +
    150struct time_data MPI_Ssend_init_data;
    +
    151struct time_data MPI_Start_data;
    +
    152struct time_data MPI_Startall_data;
    +
    153struct time_data MPI_Test_data;
    +
    154struct time_data MPI_Testall_data;
    +
    155struct time_data MPI_Testany_data;
    +
    156struct time_data MPI_Test_cancelled_data;
    +
    157struct time_data MPI_Testsome_data;
    +
    158struct time_data MPI_Type_commit_data;
    +
    159struct time_data MPI_Type_contiguous_data;
    +
    160struct time_data MPI_Type_extent_data;
    +
    161struct time_data MPI_Type_free_data;
    +
    162struct time_data MPI_Type_hindexed_data;
    +
    163struct time_data MPI_Type_hvector_data;
    +
    164struct time_data MPI_Type_indexed_data;
    +
    165struct time_data MPI_Type_lb_data;
    +
    166struct time_data MPI_Type_size_data;
    +
    167struct time_data MPI_Type_struct_data;
    +
    168struct time_data MPI_Type_ub_data;
    +
    169struct time_data MPI_Type_vector_data;
    +
    170struct time_data MPI_Unpack_data;
    +
    171struct time_data MPI_Wait_data;
    +
    172struct time_data MPI_Waitall_data;
    +
    173struct time_data MPI_Waitany_data;
    +
    174struct time_data MPI_Waitsome_data;
    +
    175struct time_data MPI_Cart_coords_data;
    +
    176struct time_data MPI_Cart_create_data;
    +
    177struct time_data MPI_Cart_get_data;
    +
    178struct time_data MPI_Cart_map_data;
    +
    179struct time_data MPI_Cart_rank_data;
    +
    180struct time_data MPI_Cart_shift_data;
    +
    181struct time_data MPI_Cart_sub_data;
    +
    182struct time_data MPI_Cartdim_get_data;
    +
    183struct time_data MPI_Dims_create_data;
    +
    184struct time_data MPI_Graph_create_data;
    +
    185struct time_data MPI_Graph_get_data;
    +
    186struct time_data MPI_Graph_map_data;
    +
    187struct time_data MPI_Graph_neighbors_data;
    +
    188struct time_data MPI_Graph_neighbors_count_data;
    +
    189struct time_data MPI_Graphdims_get_data;
    +
    190struct time_data MPI_Topo_test_data;
    +
    191
    +
    +
    196int bucket (lng)
    +
    197int 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
    +
    +
    211void elapse (timer)
    +
    212double *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
    +
    +
    234void cputim (usr, sys)
    +
    235double *usr;
    +
    236double *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
    +
    +
    260void start_timer (time)
    +
    261struct 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
    +
    +
    279void end_timer (time)
    +
    280struct 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
    +
    +
    299void 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
    +
    +
    381void print_timing (string, time)
    +
    382char *string;
    +
    383struct 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
    +
    +
    437void 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
    +
    +
    458void 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}
    +
    +
    print_timing
    void print_timing(char *string, struct time_data *time)
    Definition summary.c:381
    +
    resource
    void resource()
    Definition summary.c:299
    +
    elapse
    void elapse(double *timer)
    Definition summary.c:211
    +
    summary_
    void summary_(int *returnVal)
    Definition summary.c:437
    +
    cputim
    void cputim(double *usr, double *sys)
    Definition summary.c:234
    +
    start_timer
    void start_timer(struct time_data *time)
    Definition summary.c:260
    +
    end_timer
    void end_timer(struct time_data *time)
    Definition summary.c:279
    +
    bucket
    int bucket(int lng)
    Definition summary.c:196
    +
    start_
    void start_()
    Definition summary.c:458
    diff --git a/tab_ad.png b/tab_ad.png new file mode 100644 index 0000000000000000000000000000000000000000..e34850acfc24be58da6d2fd1ccc6b29cc84fe34d GIT binary patch literal 135 zcmeAS@N?(olHy`uVBq!ia0vp^j6kfy!2~3aiye;!QhuH;jv*C{Z|5d*H3V=pKi{In zd2jxLclDRPylmD}^l7{QOtL{vUjO{-WqItb5sQp2h-99b8^^Scr-=2mblCdZuUm?4 jzOJvgvt3{(cjKLW5(A@0qPS@<&}0TrS3j3^P6y&q2{!U5bk+Tso_B!YCpDh>v z{CM*1U8YvQRyBUHt^Ju0W_sq-?;9@_4equ-bavTs=gk796zopr0EBT&m;e9( literal 0 HcmV?d00001 diff --git a/tab_sd.png b/tab_sd.png new file mode 100644 index 0000000000000000000000000000000000000000..757a565ced4730f85c833fb2547d8e199ae68f19 GIT binary patch literal 188 zcmeAS@N?(olHy`uVBq!ia0vp^j6kfy!2~3aiye;!Qq7(&jv*C{Z|_!fH5o7*c=%9% zcILh!EA=pAQKdx-Cdiev=v{eg{8Ht<{e8_NAN~b=)%W>-WDCE0PyDHGemi$BoXwcK z{>e9^za6*c1ilttWw&V+U;WCPlV9{LdC~Ey%_H(qj`xgfES(4Yz5jSTZfCt`4E$0YRsR*S^mTCR^;V&sxC8{l_Cp7w8-YPgg&ebxsLQ00$vXK>z>% literal 0 HcmV?d00001 diff --git a/tabs.css b/tabs.css index 7d45d36c..71c8a470 100644 --- a/tabs.css +++ b/tabs.css @@ -1 +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}} +.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:0/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}.main-menu-btn{position:relative;display:inline-block;width:36px;height:36px;text-indent:36px;margin-left:8px;white-space:nowrap;overflow:hidden;cursor:pointer;-webkit-tap-highlight-color:rgba(0,0,0,0)}.main-menu-btn-icon,.main-menu-btn-icon:before,.main-menu-btn-icon:after{position:absolute;top:50%;left:2px;height:2px;width:24px;background:var(--nav-menu-button-color);-webkit-transition:all .25s;transition:all .25s}.main-menu-btn-icon:before{content:'';top:-7px;left:0}.main-menu-btn-icon:after{content:'';top:7px;left:0}#main-menu-state:checked ~ .main-menu-btn .main-menu-btn-icon{height:0}#main-menu-state:checked ~ .main-menu-btn .main-menu-btn-icon:before{top:0;-webkit-transform:rotate(-45deg);transform:rotate(-45deg)}#main-menu-state:checked ~ .main-menu-btn .main-menu-btn-icon:after{top:0;-webkit-transform:rotate(45deg);transform:rotate(45deg)}#main-menu-state{position:absolute;width:1px;height:1px;margin:-1px;border:0;padding:0;overflow:hidden;clip:rect(1px,1px,1px,1px)}#main-menu-state:not(:checked) ~ #main-menu{display:none}#main-menu-state:checked ~ #main-menu{display:block}@media(min-width:768px){.main-menu-btn{position:absolute;top:-99999px}#main-menu-state:not(:checked) ~ #main-menu{display:block}}.sm-dox{background-image:var(--nav-gradient-image)}.sm-dox a,.sm-dox a:focus,.sm-dox a:hover,.sm-dox a:active{padding:0 12px;padding-right:43px;font-family:var(--font-family-nav);font-size:13px;font-weight:bold;line-height:36px;text-decoration:none;text-shadow:var(--nav-text-normal-shadow);color:var(--nav-text-normal-color);outline:0}.sm-dox a:hover{background-image:var(--nav-gradient-active-image);background-repeat:repeat-x;color:var(--nav-text-hover-color);text-shadow:var(--nav-text-hover-shadow)}.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:var(--nav-menu-toggle-color);-moz-border-radius:5px;-webkit-border-radius:5px;border-radius:5px}.sm-dox a span.sub-arrow:before{display:block;content:'+'}.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{-moz-border-radius:5px 5px 0 0;-webkit-border-radius:5px;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{-moz-border-radius:0 0 5px 5px;-webkit-border-radius:0;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{-moz-border-radius:0;-webkit-border-radius:0;border-radius:0}.sm-dox ul{background:var(--nav-menu-background-color)}.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:var(--nav-menu-background-color);background-image:none}.sm-dox ul a:hover{background-image:var(--nav-gradient-active-image);background-repeat:repeat-x;color:var(--nav-text-hover-color);text-shadow:0 1px 1px black}.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:var(--nav-gradient-image);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:var(--nav-text-normal-color) transparent transparent transparent;background:transparent;-moz-border-radius:0;-webkit-border-radius:0;border-radius:0}.sm-dox a,.sm-dox a:focus,.sm-dox a:active,.sm-dox a:hover,.sm-dox a.highlighted{padding:0 12px;background-image:var(--nav-separator-image);background-repeat:no-repeat;background-position:right;-moz-border-radius:0 !important;-webkit-border-radius:0;border-radius:0 !important}.sm-dox a:hover{background-image:var(--nav-gradient-active-image);background-repeat:repeat-x;color:var(--nav-text-hover-color);text-shadow:var(--nav-text-hover-shadow)}.sm-dox a:hover span.sub-arrow{border-color:var(--nav-text-hover-color) 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 var(--nav-menu-background-color) transparent}.sm-dox ul{border:1px solid #bbb;padding:5px 0;background:var(--nav-menu-background-color);-moz-border-radius:5px !important;-webkit-border-radius:5px;border-radius:5px !important;-moz-box-shadow:0 5px 9px rgba(0,0,0,0.2);-webkit-box-shadow:0 5px 9px rgba(0,0,0,0.2);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 var(--nav-menu-foreground-color);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:var(--nav-menu-foreground-color);background-image:none;border:0 !important;color:var(--nav-menu-foreground-color);background-image:none}.sm-dox ul a:hover{background-image:var(--nav-gradient-active-image);background-repeat:repeat-x;color:var(--nav-text-hover-color);text-shadow:var(--nav-text-hover-shadow)}.sm-dox ul a:hover span.sub-arrow{border-color:transparent transparent transparent var(--nav-text-hover-color)}.sm-dox span.scroll-up,.sm-dox span.scroll-down{position:absolute;display:none;visibility:hidden;overflow:hidden;background:var(--nav-menu-background-color);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 var(--nav-menu-foreground-color) transparent}.sm-dox span.scroll-down-arrow{top:8px;border-style:solid dashed dashed dashed;border-color:var(--nav-menu-foreground-color) 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;-moz-border-radius:5px;-webkit-border-radius:5px;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:var(--nav-gradient-image)}.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:var(--nav-menu-background-color)}} \ No newline at end of file diff --git a/ver-2.10.0/index.html b/ver-2.10.0/index.html index f3a73a23..dbdcf603 100644 --- a/ver-2.10.0/index.html +++ b/ver-2.10.0/index.html @@ -88,12 +88,6 @@

    NCEPLIBS-w3emc

    -

    -Documentation for Previous Versions

    -

    Introduction

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

    diff --git a/ver-2.11.0/index.html b/ver-2.11.0/index.html index 0a32f954..8a39b885 100644 --- a/ver-2.11.0/index.html +++ b/ver-2.11.0/index.html @@ -88,13 +88,6 @@

    NCEPLIBS-w3emc

    -

    -Documentation for Previous Versions

    -

    Introduction

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

    diff --git a/ver-2.9.3/index.html b/ver-2.9.3/index.html index 0caf85d9..2ee797a2 100644 --- a/ver-2.9.3/index.html +++ b/ver-2.9.3/index.html @@ -88,11 +88,6 @@

    NCEPLIBS-w3emc

    -

    -Documentation for Previous Versions

    -

    Introduction

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

    diff --git a/w3ai00_8f.html b/w3ai00_8f.html index 0ff9e998..428d7e41 100644 --- a/w3ai00_8f.html +++ b/w3ai00_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai00.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai00.f File Reference
    +
    w3ai00.f File Reference
    @@ -94,17 +100,17 @@

    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...
     
    subroutine q9e3i6 (a, b, n, istat)
     Convert ieee 32 bit task 754 floating point numbers to ibm370 64 bit floating point numbers.
     
    subroutine q9ei32 (a, b, n, istat)
     Convert IEEE 32 bit task 754 floating point numbers to IBM370 32 bit floating point numbers.
     
    subroutine w3ai00 (real8, pack, label)
     Converts IEEE floating point numbers to 16 bit packed office note 84 format.
     

    Detailed Description

    Real array to 16 bit packed format.

    @@ -113,8 +119,8 @@

    Definition in file w3ai00.f.

    Function/Subroutine Documentation

    - -

    ◆ q9e3i6()

    + +

    ◆ q9e3i6()

    @@ -123,25 +129,25 @@

    subroutine q9e3i6 ( integer(4), dimension(n)  - A, + a, integer(4), dimension(2,n)  - B, + b,   - N, + n,   - ISTAT  + istat  @@ -178,8 +184,8 @@

    -

    ◆ q9ei32()

    + +

    ◆ q9ei32()

    @@ -188,25 +194,25 @@

    subroutine q9ei32 ( integer(4), dimension(*)  - A, + a, integer(4), dimension(*)  - B, + b,   - N, + n,   - ISTAT  + istat  @@ -247,8 +253,8 @@

    -

    ◆ w3ai00()

    + +

    ◆ w3ai00()

    @@ -257,19 +263,19 @@

    subroutine w3ai00 ( real, dimension(*)  - REAL8, + real8, integer(8), dimension(*)  - PACK, + pack, integer(8), dimension(6)  - LABEL  + label  @@ -323,7 +329,7 @@

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

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai01.f File Reference
    +
    w3ai01.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ai01 (pack, real8, label)
     Unpacks a record in office note 84 format and convert the packed data to ieee real floating point numbers.
     

    Detailed Description

    Unpack record into IEEE F.P.

    @@ -107,8 +113,8 @@

    Definition in file w3ai01.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai01()

    + +

    ◆ w3ai01()

    @@ -117,19 +123,19 @@

    subroutine w3ai01 ( integer(8), dimension(*)  - PACK, + pack, real, dimension(*)  - REAL8, + real8, integer(8), dimension(6)  - LABEL  + label  @@ -172,7 +178,7 @@

    diff --git a/w3ai01_8f.js b/w3ai01_8f.js index 56216060..b35cc1b6 100644 --- a/w3ai01_8f.js +++ b/w3ai01_8f.js @@ -1,4 +1,4 @@ var w3ai01_8f = [ - [ "w3ai01", "w3ai01_8f.html#a222326720cc27c198b6808bd3f601e4a", null ] + [ "w3ai01", "w3ai01_8f.html#acf00ef759655cd640826064c50ff8150", null ] ]; \ No newline at end of file diff --git a/w3ai01_8f_source.html b/w3ai01_8f_source.html index 36ba6c89..75551507 100644 --- a/w3ai01_8f_source.html +++ b/w3ai01_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai01.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,123 +81,131 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ai01.f
    +
    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
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Unpack record into IEEE F.P.
    +
    3C> @author Ralph Jones @date 1989-10-17
    +
    4
    +
    5C> Unpacks a record in office note 84 format and convert the
    +
    6C> packed data to ieee real floating point numbers. The
    +
    7C> office note 84 data is bit for bit the same on the nas-9050 and
    +
    8C> the cray.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Ralph Jones 1989-10-20
    +
    12C> - Ralph Jones 1990-02-02 Change to cray function for integer*2, f.p.
    +
    13C> - Ralph Jones 1990-10-11 Special version of w3ai01 to unpack records
    +
    14c> packed by big version of w3ai00. Will do old and new version.
    +
    15C> - Ralph Jones 1991-03-19 Make special version of w3ai01 to unpack
    +
    16c> big records the operational version.
    +
    17C> - Ralph Jones 1993-06-10 Increace array size to 262144 words.
    +
    18C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    19C> - Stephen Gilbert 1998-11-17 Changed to unpack into IEEE reals for the IBM SP.
    +
    20C>
    +
    21C> @param[in] PACK Integer array with data in office note 84 format to be unpacked.
    +
    22C> @param[out] REAL8 Real array of n words. where n is given in word 6 of pack.
    +
    23c> Word 6 of pack must contain center and scaling values.
    +
    24C> @param[out] LABEL Six word integer label copied from pack,
    +
    25c> 12 office note 84 32 bit id's that are stored into six 64-bit words.
    +
    26C>
    +
    27C> @note Label and pack may be equivalenced.
    +
    28C>
    +
    29C> @author Ralph Jones @date 1989-10-17
    +
    30
    +
    +
    31 SUBROUTINE w3ai01(PACK,REAL8,LABEL)
    +
    32C
    +
    33 REAL REAL8(*)
    +
    34C
    +
    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))
    +
    45C
    +
    46 SAVE
    +
    47C
    +
    48 DATA mask16/z'000000000000FFFF'/
    +
    49 DATA mask32/z'00000000FFFFFFFF'/
    +
    50C
    +
    51C MOVE OFFICE NOTE 84 12 32 BIT ID'S INTO LABEL
    +
    52C
    +
    53 DO 10 i = 1,6
    +
    54 label(i) = pack(i)
    +
    55 10 CONTINUE
    +
    56C
    +
    57C GET WORD COUNT, AVERAGE VALUE, SCALING FACTOR, J, A , N.
    +
    58C
    +
    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
    +
    72C
    +
    73C CONVERT IBM 32 BIT MEAN VALUE TO IEEE F.P. NUMBER
    +
    74C
    +
    75C CALL USSCTC(LABEL(5),5,A,1)
    +
    76 ktemp=label(5)
    +
    77 call q9ie32(rtemp(2),rtemp(1),1,istat)
    +
    78 a=rtemp(1)
    +
    79C
    +
    80C GET SCALING VALUE N, CAN BE NEGATIVE (INTEGER*2 TWO'S COMPL.)
    +
    81C
    +
    82C CALL USICTC(LABEL(6),3,N,1,2)
    +
    83 ktemp=label(6)
    +
    84 n=i2(2)
    +
    85C
    +
    86 twon = 2.0 ** (n - 15)
    +
    87C
    +
    88C UNPACK, CONVERT TO REAL 64 BIT FLOATING POINT DATA
    +
    89C
    +
    90C CALL USICTC(PACK(7),1,ITEMP,J,2)
    +
    91 jtemp(1:65536)=pack(7:65542)
    +
    92C
    +
    93 DO 20 i = 1,j
    +
    94 real8(i) = float(itemp(i)) * twon + a
    +
    95 20 CONTINUE
    +
    96C
    +
    97 RETURN
    +
    +
    98 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
    +
    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
    diff --git a/w3ai08_8f.html b/w3ai08_8f.html index ca91de49..19a5dc67 100644 --- a/w3ai08_8f.html +++ b/w3ai08_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai08.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai08.f File Reference
    +
    w3ai08.f File Reference
    @@ -94,35 +100,35 @@

    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...
     
    subroutine ai081 (msga, kptr, kpds, kret)
     Find 'grib; characters and set pointers to the next byte following 'grib'.
     
    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.
     
    subroutine ai082a (msga, kptr, kpds, kret)
     Extract information from the product description section (version 1).
     
    subroutine ai083 (msga, kptr, kpds, kgds, kret)
     Extract information on unlisted grid to allow conversion to office note 84 format.
     
    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.
     
    subroutine ai085 (msga, kptr, kpds, kbms, data, kret)
     Extract grib data and place into output arry in proper position.
     
    subroutine ai085a (msga, kptr, kpds, kbms, data, kret)
     Extract grib data (version 1) and place into proper position in output array.
     
    subroutine ai087 (, j, kpds, kgds, kret)
     To test when gds is available to see if size mismatch on existing grids (by center) is indicated.
     
    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.
     

    Detailed Description

    Unpack grib field to grib grid.

    @@ -131,8 +137,8 @@

    Definition in file w3ai08.f.

    Function/Subroutine Documentation

    - -

    ◆ ai081()

    + +

    ◆ ai081()

    @@ -141,25 +147,25 @@

    subroutine ai081 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer  - KRET  + kret  @@ -229,8 +235,8 @@

    -

    ◆ ai082()

    + +

    ◆ ai082()

    @@ -239,25 +245,25 @@

    subroutine ai082 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer  - KRET  + kret  @@ -329,8 +335,8 @@

    -

    ◆ ai082a()

    + +

    ◆ ai082a()

    @@ -339,25 +345,25 @@

    subroutine ai082a ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer  - KRET  + kret  @@ -457,8 +463,8 @@

    -

    ◆ ai083()

    + +

    ◆ ai083()

    @@ -467,31 +473,31 @@

    subroutine ai083 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds, integer  - KRET  + kret  @@ -628,8 +634,8 @@

    -

    ◆ ai084()

    + +

    ◆ ai084()

    @@ -638,37 +644,37 @@

    subroutine ai084 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(10)  - KPTR, + kptr, integer, dimension(20)  - KPDS, + kpds, integer, dimension(13)  - KGDS, + kgds, logical, dimension(*)  - KBMS, + kbms, integer  - KRET  + kret  @@ -810,8 +816,8 @@

    -

    ◆ ai085()

    + +

    ◆ ai085()

    @@ -820,37 +826,37 @@

    subroutine ai085 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, logical, dimension(*)  - KBMS, + kbms, real, dimension(*)  - DATA, + data,   - KRET  + kret  @@ -923,8 +929,8 @@

    -

    ◆ ai085a()

    + +

    ◆ ai085a()

    @@ -933,37 +939,37 @@

    subroutine ai085a ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, logical, dimension(*)  - KBMS, + kbms, real, dimension(*)  - DATA, + data,   - KRET  + kret  @@ -1048,8 +1054,8 @@

    -

    ◆ ai087()

    + +

    ◆ ai087()

    @@ -1058,25 +1064,25 @@

    subroutine ai087 ( integer  - J, + j, integer, dimension(20)  - KPDS, + kpds, integer, dimension(13)  - KGDS, + kgds,   - KRET  + kret  @@ -1109,8 +1115,8 @@

    -

    ◆ w3ai08()

    + +

    ◆ w3ai08()

    @@ -1119,43 +1125,43 @@

    subroutine w3ai08 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds, logical, dimension(*)  - KBMS, + kbms, real, dimension(*)  - DATA, + data, integer, dimension(*)  - KPTR, + kptr,   - KRET  + kret  @@ -1341,7 +1347,7 @@

    diff --git a/w3ai08_8f.js b/w3ai08_8f.js index 2a95a5e2..eadf26bd 100644 --- a/w3ai08_8f.js +++ b/w3ai08_8f.js @@ -1,12 +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 ] + [ "ai081", "w3ai08_8f.html#a287605e7ec4319ea51164043fa1f9d73", null ], + [ "ai082", "w3ai08_8f.html#a7dee92cbb450627df9b2dd8e3272abb8", null ], + [ "ai082a", "w3ai08_8f.html#a3df6d0ec86b78aea8c650696d0a0b21f", null ], + [ "ai083", "w3ai08_8f.html#a45260b5f0f299ccea0ab0ac6f7be1fe5", null ], + [ "ai084", "w3ai08_8f.html#af169362b14ce4c1f632823554fdc5495", null ], + [ "ai085", "w3ai08_8f.html#a6a8d7e193514ad239d73c3bdd30a6576", null ], + [ "ai085a", "w3ai08_8f.html#acd0cb9edc0509005a5121d3fa2eb2037", null ], + [ "ai087", "w3ai08_8f.html#a9c9abd1f5e91a16eb04e1e83bc436238", null ], + [ "w3ai08", "w3ai08_8f.html#a50cf1edd8615abf5c6c333c8e790f63b", null ] ]; \ No newline at end of file diff --git a/w3ai08_8f_source.html b/w3ai08_8f_source.html index e2c0a16c..66d64556 100644 --- a/w3ai08_8f_source.html +++ b/w3ai08_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai08.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,2804 +81,2828 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ai08.f
    +
    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
    -
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    -
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    -
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    -
    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
    -
    ai085
    subroutine ai085(MSGA, KPTR, KPDS, KBMS, DATA, KRET)
    Extract grib data and place into output arry in proper position.
    Definition: w3ai08.f:2067
    -
    ai081
    subroutine ai081(MSGA, KPTR, KPDS, KRET)
    Find 'grib; characters and set pointers to the next byte following 'grib'.
    Definition: w3ai08.f:569
    -
    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
    -
    ai082a
    subroutine ai082a(MSGA, KPTR, KPDS, KRET)
    Extract information from the product description section (version 1).
    Definition: w3ai08.f:935
    -
    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
    -
    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
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Unpack grib field to grib grid.
    +
    3C> @author Bill Cavanaugh @date 1988-01-20
    +
    4
    +
    5C> Unpack a grib field to the exact grid specified in the
    +
    6C> message, isolate the bit map and make the values of the product
    +
    7C> description sec (pds) and the grid description sec (gds)
    +
    8C> available in return arrays.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Bill Cavanaugh 1988-01-20
    +
    12C> - Bill Cavanaugh 1990-05-11 To assure that all u.s. grids in the grib decoder
    +
    13C> comply with size changes in the december 1989 revisions.
    +
    14C> - Bill Cavanaugh 1990-05-24 Corrects searching an improper location for grib
    +
    15c> version number in grib messages.
    +
    16C> - William Bostelman 1990-07-15 Modiifed sub. ai084 so that it will test
    +
    17C> the grib bds byte size to determine what ecmwf grid array size is
    +
    18C> to be specified.
    +
    19C> - Ralph Jones 1990-09-14 Change's for ansi fortran, and pds version 1.
    +
    20C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    21C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    22C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    23C>
    +
    24C> @param[in] msga grib field - "grib" thru "7777" char*1
    +
    25C> @param[out] data array containing data elements
    +
    26C> @note (version 0):
    +
    27C> - 1: id of center
    +
    28C> - 2: model identification
    +
    29C> - 3: grid identification
    +
    30C> - 4: gds/bms flag
    +
    31C> - 5: indicator of parameter
    +
    32C> - 6: type of level
    +
    33C> - 7: height/pressure , etc of level
    +
    34C> - 8: year including century
    +
    35C> - 9: month of year
    +
    36C> - 10: day of month
    +
    37C> - 11: hour of day
    +
    38C> - 12: minute of hour
    +
    39C> - 13: indicator of forecast time unit
    +
    40C> - 14: time range 1
    +
    41C> - 15: time range 2
    +
    42C> - 16: time range flag
    +
    43C> - 17: number included in average
    +
    44C> - 18: grib specification edition number
    +
    45C> @param[out] kpds array containing pds elements. (version 1)
    +
    46C> - 1: id of center
    +
    47C> - 2: model identification
    +
    48C> - 3: grid identification
    +
    49C> - 4: gds/bms flag
    +
    50C> - 5: indicator of parameter
    +
    51C> - 6: type of level
    +
    52C> - 7: height/pressure , etc of level
    +
    53C> - 8: year including century
    +
    54C> - 9: month of year
    +
    55C> - 10: day of month
    +
    56C> - 11: hour of day
    +
    57C> - 12: minute of hour
    +
    58C> - 13: indicator of forecast time unit
    +
    59C> - 14: time range 1
    +
    60C> - 15: time range 2
    +
    61C> - 16: time range flag
    +
    62C> - 17: number included in average
    +
    63C> - 18: version nr of grib specification
    +
    64C> - 19: version nr of parameter table
    +
    65C> - 20: total length of grib message (including section 0)
    +
    66C> @param[out] kgds array containing gds elements.
    +
    67C> - 1: data representation type
    +
    68C> - Latitude/longitude grids
    +
    69C> - 2: n(i) nr points on latitude circle
    +
    70C> - 3: n(j) nr points on longitude meridian
    +
    71C> - 4: la(1) latitude of origin
    +
    72C> - 5: lo(1) longitude of origin
    +
    73C> - 6: resolution flag
    +
    74C> - 7: la(2) latitude of extreme point
    +
    75C> - 8: lo(2) longitude of extreme point
    +
    76C> - 9: di longitudinal direction of increment
    +
    77C> - 10: dj latitundinal direction of increment
    +
    78C> - 11: scanning mode flag
    +
    79C> - Polar stereographic grids
    +
    80C> - 2: n(i) nr points along lat circle
    +
    81C> - 3: n(j) nr points along lon circle
    +
    82C> - 4: la(1) latitude of origin
    +
    83C> - 5: lo(1) longitude of origin
    +
    84C> - 6: reserved
    +
    85C> - 7: lov grid orientation
    +
    86C> - 8: dx - x direction increment
    +
    87C> - 9: dy - y direction increment
    +
    88C> - 10: projection center flag
    +
    89C> - 11: scanning mode
    +
    90C> - Spherical harmonic coefficients
    +
    91C> - 2: j pentagonal resolution parameter
    +
    92C> - 3: k pentagonal resolution parameter
    +
    93C> - 4: m pentagonal resolution parameter
    +
    94C> - 5: representation type
    +
    95C> - 6: coefficient storage mode
    +
    96C> - Mercator grids
    +
    97C> - 2: n(i) nr points on latitude circle
    +
    98C> - 3: n(j) nr points on longitude meridian
    +
    99C> - 4: la(1) latitude of origin
    +
    100C> - 5: lo(1) longitude of origin
    +
    101C> - 6: resolution flag
    +
    102C> - 7: la(2) latitude of last grid point
    +
    103C> - 8: lo(2) longitude of last grid point
    +
    104C> - 9: longit dir increment
    +
    105C> - 10: latit dir increment
    +
    106C> - 11: scanning mode flag
    +
    107C> - 12: latitude intersection
    +
    108C> - Lambert conformal grids
    +
    109C> - 2: nx nr points along x-axis
    +
    110C> - 3: ny nr points along y-axis
    +
    111C> - 4: la1 lat of origin (lower left)
    +
    112C> - 5: lo1 lon of origin (lower left)
    +
    113C> - 6: reserved
    +
    114C> - 7: lov - orientation of grid
    +
    115C> - 8: dx - x-dir increment
    +
    116C> - 9: dy - y-dir increment
    +
    117C> - 10: projection center flag
    +
    118C> - 11: scanning mode flag
    +
    119C> - 12: latin 1 - first lat from pole of secant cone inter
    +
    120C> - 13: latin 2 - second lat from pole of secant cone inter
    +
    121C> @param[out] kbms - bitmap describing location of output elements.
    +
    122C> @param[out] kptr - array containing storage for following parameters
    +
    123C> - 1: unused
    +
    124C> - 2: unused
    +
    125C> - 3: length of pds
    +
    126C> - 4: length of gds
    +
    127C> - 5: length of bms
    +
    128C> - 6: length of bds
    +
    129C> - 7: value of current byte
    +
    130C> - 8: unused
    +
    131C> - 9: grib start byte nr
    +
    132C> - 10: grib/grid element count
    +
    133C> @param[out] kret flag indicating quality of completion
    +
    134C>
    +
    135C> @note values for return flag (kret)
    +
    136C> - kret = 0 - normal return, no errors
    +
    137C> - = 1 - 'grib' not found in first 100 chars
    +
    138C> - = 2 - '7777' not in correct location
    +
    139C> - = 3 - unpacked field is larger than 32768
    +
    140C> - = 4 - gds/ grid not one of currently accepted values
    +
    141C> - = 5 - grid not currently avail for center indicated
    +
    142C> - = 8 - temp gds indicated, but gds flag is off
    +
    143C> - = 9 - gds indicates size mismatch with std grid
    +
    144C> - = 10 - incorrect center indicator
    +
    145C>
    +
    146C> @author Bill Cavanaugh @date 1988-01-20
    +
    +
    147 SUBROUTINE w3ai08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
    +
    148C 4 AUG 1988
    +
    149C W3AI08
    +
    150C
    +
    151C
    +
    152C GRIB UNPACKING ROUTINE
    +
    153C
    +
    154C
    +
    155C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
    +
    156C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
    +
    157C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID
    +
    158C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS.
    +
    159C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
    +
    160C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
    +
    161C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
    +
    162C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
    +
    163C
    +
    164C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
    +
    165C
    +
    166C CALL W3AI08(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
    +
    167C
    +
    168C INPUT:
    +
    169C
    +
    170C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
    +
    171C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
    +
    172C
    +
    173C OUTPUT:
    +
    174C
    +
    175C KPDS(100) INTEGER
    +
    176C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
    +
    177C DEFINITION SEC .
    +
    178C (VERSION 0)
    +
    179C KPDS(1) - ID OF CENTER
    +
    180C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
    +
    181C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
    +
    182C KPDS(4) - GDS/BMS FLAG
    +
    183C BIT DEFINITION
    +
    184C 25 0 - GDS OMITTED
    +
    185C 1 - GDS INCLUDED
    +
    186C 26 0 - BMS OMITTED
    +
    187C 1 - BMS INCLUDED
    +
    188C NOTE:- LEFTMOST BIT = 1,
    +
    189C RIGHTMOST BIT = 32
    +
    190C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
    +
    191C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
    +
    192C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
    +
    193C KPDS(8) - YEAR OF CENTURY
    +
    194C KPDS(9) - MONTH OF YEAR
    +
    195C KPDS(10) - DAY OF MONTH
    +
    196C KPDS(11) - HOUR OF DAY
    +
    197C KPDS(12) - MINUTE OF HOUR
    +
    198C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
    +
    199C TABLE 8)
    +
    200C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
    +
    201C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
    +
    202C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
    +
    203C KPDS(17) - NUMBER INCLUDED IN AVERAGE
    +
    204C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
    +
    205C
    +
    206C (VERSION 1)
    +
    207C KPDS(1) - ID OF CENTER
    +
    208C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
    +
    209C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
    +
    210C KPDS(4) - GDS/BMS FLAG
    +
    211C BIT DEFINITION
    +
    212C 25 0 - GDS OMITTED
    +
    213C 1 - GDS INCLUDED
    +
    214C 26 0 - BMS OMITTED
    +
    215C 1 - BMS INCLUDED
    +
    216C NOTE:- LEFTMOST BIT = 1,
    +
    217C RIGHTMOST BIT = 32
    +
    218C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
    +
    219C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
    +
    220C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
    +
    221C KPDS(8) - YEAR INCLUDING CENTURY
    +
    222C KPDS(9) - MONTH OF YEAR
    +
    223C KPDS(10) - DAY OF MONTH
    +
    224C KPDS(11) - HOUR OF DAY
    +
    225C KPDS(12) - MINUTE OF HOUR
    +
    226C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
    +
    227C TABLE 8)
    +
    228C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
    +
    229C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
    +
    230C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
    +
    231C KPDS(17) - NUMBER INCLUDED IN AVERAGE
    +
    232C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
    +
    233C KPDS(19) - VERSION NR OF PARAMETER TABLE
    +
    234C KPDS(20) - TOTAL LENGTH 0F GRIB MESSAGE
    +
    235C (INCLUDING SECTION 0)
    +
    236C KGDS(13) INTEGER
    +
    237C ARRAY CONTAINING GDS ELEMENTS.
    +
    238C
    +
    239C KGDS(1) - DATA REPRESENTATION TYPE
    +
    240C
    +
    241C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
    +
    242C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE
    +
    243C CIRCLE
    +
    244C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE
    +
    245C CIRCLE
    +
    246C KGDS(4) - LA(1) LATITUDE OF ORIGIN
    +
    247C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
    +
    248C KGDS(6) - RESOLUTION FLAG
    +
    249C BIT MEANING
    +
    250C 25 0 - DIRECTION INCREMENTS NOT
    +
    251C GIVEN
    +
    252C 1 - DIRECTION INCREMENTS GIVEN
    +
    253C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT
    +
    254C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT
    +
    255C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT
    +
    256C KGDS(10) - REGULAR LAT/LON GRID
    +
    257C DJ - LATITUDINAL DIRECTION
    +
    258C INCREMENT
    +
    259C GAUSSIAN GRID
    +
    260C N - NUMBER OF LATITUDE CIRCLES
    +
    261C BETWEEN A POLE AND THE EQUATOR
    +
    262C KGDS(11) - SCANNING MODE FLAG
    +
    263C BIT MEANING
    +
    264C 25 0 - POINTS ALONG A LATITUDE
    +
    265C SCAN FROM WEST TO EAST
    +
    266C 1 - POINTS ALONG A LATITUDE
    +
    267C SCAN FROM EAST TO WEST
    +
    268C 26 0 - POINTS ALONG A MERIDIAN
    +
    269C SCAN FROM NORTH TO SOUTH
    +
    270C 1 - POINTS ALONG A MERIDIAN
    +
    271C SCAN FROM SOUTH TO NORTH
    +
    272C 27 0 - POINTS SCAN FIRST ALONG
    +
    273C CIRCLES OF LATITUDE, THEN
    +
    274C ALONG MERIDIANS
    +
    275C (FORTRAN: (I,J))
    +
    276C 1 - POINTS SCAN FIRST ALONG
    +
    277C MERIDIANS THEN ALONG
    +
    278C CIRCLES OF LATITUDE
    +
    279C (FORTRAN: (J,I))
    +
    280C
    +
    281C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12)
    +
    282C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE
    +
    283C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE
    +
    284C KGDS(4) - LA(1) LATITUDE OF ORIGIN
    +
    285C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
    +
    286C KGDS(6) - RESERVED
    +
    287C KGDS(7) - LOV GRID ORIENTATION
    +
    288C KGDS(8) - DX - X DIRECTION INCREMENT
    +
    289C KGDS(9) - DY - Y DIRECTION INCREMENT
    +
    290C KGDS(10) - PROJECTION CENTER FLAG
    +
    291C KGDS(11) - SCANNING MODE
    +
    292C
    +
    293C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
    +
    294C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER
    +
    295C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER
    +
    296C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER
    +
    297C KGDS(5) - REPRESENTATION TYPE
    +
    298C KGDS(6) - COEFFICIENT STORAGE MODE
    +
    299C
    +
    300C MERCATOR GRIDS
    +
    301C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE
    +
    302C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
    +
    303C KGDS(4) - LA(1) LATITUDE OF ORIGIN
    +
    304C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
    +
    305C KGDS(6) - RESOLUTION FLAG
    +
    306C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT
    +
    307C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT
    +
    308C KGDS(9) - LONGIT DIR INCREMENT
    +
    309C KGDS(10) - LATIT DIR INCREMENT
    +
    310C KGDS(11) - SCANNING MODE FLAG
    +
    311C KGDS(12) - LATITUDE INTERSECTION
    +
    312C LAMBERT CONFORMAL GRIDS
    +
    313C KGDS(2) - NX NR POINTS ALONG X-AXIS
    +
    314C KGDS(3) - NY NR POINTS ALONG Y-AXIS
    +
    315C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT)
    +
    316C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT)
    +
    317C KGDS(6) - RESERVED
    +
    318C KGDS(7) - LOV - ORIENTATION OF GRID
    +
    319C KGDS(8) - DX - X-DIR INCREMENT
    +
    320C KGDS(9) - DY - Y-DIR INCREMENT
    +
    321C KGDS(10) - PROJECTION CENTER FLAG
    +
    322C KGDS(11) - SCANNING MODE FLAG
    +
    323C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF
    +
    324C SECANT CONE INTERSECTION
    +
    325C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF
    +
    326C SECANT CONE INTERSECTION
    +
    327C
    +
    328C LBMS(32768) LOGICAL
    +
    329C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
    +
    330C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A
    +
    331C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
    +
    332C ONE WILL BE GENERATED AUTOMATICALLY BY THE
    +
    333C UNPACKING ROUTINE.
    +
    334C
    +
    335C
    +
    336C DATA(32768) REAL
    +
    337C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
    +
    338C
    +
    339C NOTE:- 32768 IS MAXIMUN FIELD SIZE ALLOWABLE
    +
    340C
    +
    341C KPTR(10) INTEGER
    +
    342C ARRAY CONTAINING STORAGE FOR THE FOLLOWING
    +
    343C PARAMETERS.
    +
    344C
    +
    345C (1) - UNUSED
    +
    346C (2) - UNUSED
    +
    347C (3) - LENGTH OF PDS (IN BYTES)
    +
    348C (4) - LENGTH OF GDS (IN BYTES)
    +
    349C (5) - LENGTH OF BMS (IN BYTES)
    +
    350C (6) - LENGTH OF BDS (IN BYTES)
    +
    351C (7) - USED BY UNPACKING ROUTINE
    +
    352C (8) - NUMBER OF DATA POINTS FOR GRID
    +
    353C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER
    +
    354C (10) - USED BY UNPACKING ROUTINE
    +
    355C
    +
    356C
    +
    357C KRET INTEGER
    +
    358C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
    +
    359C
    +
    360C 0 - NO ERRORS DETECTED.
    +
    361C
    +
    362C 1 - 'GRIB' NOT FOUND IN FIRST 100
    +
    363C CHARACTERS.
    +
    364C
    +
    365C 2 - '7777' NOT FOUND, EITHER MISSING OR
    +
    366C TOTAL OF SEC COUNTS OF INDIVIDUAL
    +
    367C SEC'S IS INCORRECT.
    +
    368C
    +
    369C 3 - UNPACKED FIELD IS LARGER THAN 32768.
    +
    370C
    +
    371C 4 - IN GDS, DATA REPRESENTATION TYPE
    +
    372C NOT ONE OF THE CURRENTLY ACCEPTABLE
    +
    373C VALUES. SEE "GRIB" TABLE 9. VALUE
    +
    374C OF INCORRECT TYPE RETURNED IN KGDS(1).
    +
    375C
    +
    376C 5 - GRID INDICATED IN KPDS(3) IS NOT
    +
    377C AVAILABLE FOR THE CENTER INDICATED IN
    +
    378C KPDS(1) AND NO GDS SENT.
    +
    379C
    +
    380C 7 - VERSION INDICATED IN KPDS(18) HAS NOT
    +
    381C YET BEEN INCLUDED IN THE DECODER.
    +
    382C
    +
    383C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD
    +
    384C GRID) BUT FLAG INDICATING PRESENCE OF
    +
    385C GDS IS TURNED OFF. NO METHOD OF
    +
    386C GENERATING PROPER GRID.
    +
    387C
    +
    388C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
    +
    389C MATCH STANDARD NUMBER OF POINTS FOR THIS
    +
    390C GRID (FOR OTHER THAN SPECTRALS). THIS
    +
    391C WILL OCCUR ONLY IF THE GRID.
    +
    392C IDENTIFICATION, KPDS(3), AND A
    +
    393C TRANSMITTED GDS ARE INCONSISTENT.
    +
    394C
    +
    395C 10 - CENTER INDICATOR WAS NOT ONE INDICATED
    +
    396C IN "GRIB" TABLE 1. PLEASE CONTACT AD
    +
    397C PRODUCTION MANAGEMENT BRANCH (W/NMC42)
    +
    398C IF THIS ERROR IS ENCOUNTERED.
    +
    399C
    +
    400C
    +
    401C
    +
    402C LIST OF TEXT MESSAGES FROM CODE
    +
    403C
    +
    404C
    +
    405C W3AI08/AI082
    +
    406C
    +
    407C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
    +
    408C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    409C (W/NMC42)'
    +
    410C
    +
    411C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
    +
    412C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    413C (W/NMC42)'
    +
    414C
    +
    415C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
    +
    416C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
    +
    417C PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
    +
    418C
    +
    419C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
    +
    420C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    421C (W/NMC42)'
    +
    422C
    +
    423C
    +
    424C W3AI08/AI083
    +
    425C
    +
    426C 'POLAR STEREO PROCESSING NOT AVAILABLE' *
    +
    427C
    +
    428C W3AI08/AI084
    +
    429C
    +
    430C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
    +
    431C COEFFICIENTS'
    +
    432C
    +
    433C
    +
    434C W3AI08/AI087
    +
    435C
    +
    436C 'NO CURRENT LISTING OF FNOC GRIDS' *
    +
    437C
    +
    438C
    +
    439C * WILL BE AVAILABLE IN NEXT UPDATE
    +
    440C ***************************************************************
    +
    441C
    +
    442C INCOMING MESSAGE HOLDER
    +
    443 CHARACTER*1 MSGA(*)
    +
    444C BIT MAP
    +
    445 LOGICAL KBMS(*)
    +
    446C
    +
    447C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
    +
    448 INTEGER KPDS(*)
    +
    449C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
    +
    450 INTEGER KGDS(*)
    +
    451C
    +
    452C CONTAINER FOR GRIB GRID
    +
    453 REAL DATA(*)
    +
    454C
    +
    455C ARRAY OF POINTERS AND COUNTERS
    +
    456 INTEGER KPTR(*)
    +
    457C
    +
    458C *****************************************************************
    +
    459C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
    +
    460C FIND 'GRIB' CHARACTERS
    +
    461C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
    +
    462C IF '7777' IS IN PROPER PLACE.
    +
    463C 3.0 PARSE PRODUCT DEFINITION SECTION.
    +
    464C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
    +
    465C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
    +
    466C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
    +
    467C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
    +
    468C DATA AND PLACE INTO PROPER ARRAY.
    +
    469C *******************************************************************
    +
    470C
    +
    471C MAIN DRIVER
    +
    472C
    +
    473C *******************************************************************
    +
    474 kptr(10) = 0
    +
    475C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
    +
    476C USING SEC COUNTS, DETERMINE IF '7777'
    +
    477C IS IN THE PROPER LOCATION
    +
    478C
    +
    479 CALL ai081(msga,kptr,kpds,kret)
    +
    480 IF (kret.NE.0) GO TO 900
    +
    481C
    +
    482C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
    +
    483C
    +
    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
    +
    494C
    +
    495C EXTRACT NEW GRID DESCRIPTION
    +
    496C
    +
    497 CALL ai083(msga,kptr,kpds,kgds,kret)
    +
    498 IF (kret.NE.0) GO TO 900
    +
    499C
    +
    500C EXTRACT OR GENERATE BIT MAP
    +
    501C
    +
    502 CALL ai084(msga,kptr,kpds,kgds,kbms,kret)
    +
    503 IF (kret.NE.0) GO TO 900
    +
    504C
    +
    505C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
    +
    506C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
    +
    507C
    +
    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
    +
    516C
    +
    517 900 RETURN
    +
    +
    518 END
    +
    519
    +
    520C>Find 'grib; characters and set pointers to the next
    +
    521C>byte following 'grib'. If they exist extract counts from gds and
    +
    522C>bms. Extract count from bds. determine if sum of counts actually
    +
    523C>places terminator '7777' at the correct location.
    +
    524C>
    +
    525C> Program history log:
    +
    526C> - Bill Cavanaugh 1988-01-20
    +
    527C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    528C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    529C>
    +
    530C> @param[in] msga grib field - "grib" thru "7777".``
    +
    531C> @param[inout] kptr array containing storage for following parameters.
    +
    532C> - 1: Unused.
    +
    533C> - 2: Unused.
    +
    534C> - 3: Length of pds.
    +
    535C> - 4: Length of gds.
    +
    536C> - 5: Length of bms.
    +
    537C> - 6: Length of bds.
    +
    538C> - 7: Value of current byte.
    +
    539C> - 8: Unused.
    +
    540C> - 9: Grib start byte.
    +
    541C> - 10: Grib/grid element count.
    +
    542C> @param[out] kpds - array containing pds elements..
    +
    543C> - 1: Id of center.
    +
    544C> - 2: Model identification.
    +
    545C> - 3: Grid identification.
    +
    546C> - 4: Gds/bms flag.
    +
    547C> - 5: Indicator of parameter.
    +
    548C> - 6: Type of level.
    +
    549C> - 7: Height/pressure , etc of level.
    +
    550C> - 8: Year of century.
    +
    551C> - 9: Month of year.
    +
    552C> - 10: Day of month.
    +
    553C> - 11: Hour of day.
    +
    554C> - 12: Minute of hour.
    +
    555C> - 13: Indicator of forecast time unit.
    +
    556C> - 14: Time range 1.
    +
    557C> - 15: Time range 2.
    +
    558C> - 16: Time range flag.
    +
    559C> - 17: Number included in average.
    +
    560C> - 18: Version nr of grib specification.
    +
    561C> @param[out] kret Error return.
    +
    562C>
    +
    563C> @note Error returns.
    +
    564C> - kret = 1: No 'grib'.
    +
    565C> - kret = 2: No '7777' or mislocated (by counts).
    +
    566C>
    +
    567C> @author Bill Cavanaugh @date 1988-01-20
    +
    +
    568 SUBROUTINE ai081(MSGA,KPTR,KPDS,KRET)
    +
    569
    +
    570C
    +
    571C INCOMING MESSAGE HOLDER
    +
    572 CHARACTER*1 MSGA(*)
    +
    573C ARRAY OF POINTERS AND COUNTERS
    +
    574 INTEGER KPTR(*)
    +
    575C PRODUCT DESCRIPTION SECTION DATA.
    +
    576 INTEGER KPDS(*)
    +
    577C
    +
    578 INTEGER KRET
    +
    579C
    +
    580C DATA MASK40/Z00000040/
    +
    581C DATA MASK80/Z00000080/
    +
    582C
    +
    583 DATA mask40/64/
    +
    584 DATA mask80/128/
    +
    585C
    +
    586C ******************************************************************
    +
    587 kret = 0
    +
    588C ------------------- 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
    +
    599C
    +
    600 200 CONTINUE
    +
    601 is = kptr(9)
    +
    602C ------------------- HAVE 'GRIB' KEY
    +
    603 kcnt = 0
    +
    604C --------------- 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
    +
    609C
    +
    610C TEST FOR VERSION NUMBER OF PDS 0 OR 1
    +
    611C
    +
    612 IF (kcnt.EQ.24) THEN
    +
    613 kptr(3) = kcnt
    +
    614 igribl = 4
    +
    615C
    +
    616C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 0
    +
    617C
    +
    618 kpds(18) = mova2i(msga(iss + 3))
    +
    619 ELSE
    +
    620 igribl = 8
    +
    621 iss = is + igribl
    +
    622C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 1
    +
    623 kpds(18) = mova2i(msga(is + 7))
    +
    624C
    +
    625C --------------- PARAMETER TABLE VERSION NUMBER FOR INTERNATIONAL
    +
    626C EXCHANGE (CURRENTLY NO. 1)
    +
    627C
    +
    628 kpds(19) = mova2i(msga(iss + 3))
    +
    629C
    +
    630C ---------------- SAVE TOTAL LENGTH OF MESSAGE (INCLUDING SECTION 0)
    +
    631C
    +
    632 kpds(20) = kcnt
    +
    633C
    +
    634C --------------- EXTRACT COUNT FROM PDS VERSION 1
    +
    635C
    +
    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
    +
    642C
    +
    643C --------------- GET GDS, BMS INDICATOR
    +
    644C
    +
    645 kpds(4) = mova2i(msga(iss+7))
    +
    646C
    +
    647C READY FOR NEXT SECTION
    +
    648C
    +
    649 kptr(4) = 0
    +
    650 kptr(5) = 0
    +
    651 IF (iand(kpds(4),mask80).EQ.0) GO TO 600
    +
    652C
    +
    653C --------------- EXTRACT COUNT FROM GDS
    +
    654C
    +
    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
    +
    663C
    +
    664C ---------------- EXTRACT COUNT FROM BMS
    +
    665C
    +
    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
    +
    672C
    +
    673C --------------- EXTRACT COUNT FROM BDS
    +
    674C
    +
    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
    +
    682C
    +
    683C --------------- TEST FOR '7777'
    +
    684C
    +
    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
    +
    698C> Extract information from the product description
    +
    699C> sec, and generate label information to permit storage
    +
    700C> in office note 84 format.
    +
    701C>
    +
    702C> Program history log:
    +
    703C> - Bill Cavanaugh 1988-01-20
    +
    704C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    705C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    706C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    707C>
    +
    708C> @param[in] msga Array containing grib message.
    +
    709C> @param[inout] kptr Array containing storage for following parameters.
    +
    710C> - 1: Unused.
    +
    711C> - 2: Unused.
    +
    712C> - 3: Length of pds.
    +
    713C> - 4: Length of gds.
    +
    714C> - 5: Length of bms.
    +
    715C> - 6: Length of pds.
    +
    716C> - 7: Value of current byte.
    +
    717C> - 8: Unused.
    +
    718C> - 9: Grib start byte nr.
    +
    719C> - 10: Grib/grid element count.
    +
    720C> @param[out] kpds Array containing pds elements.
    +
    721C> - 1: Id of center.
    +
    722C> - 2: Model identification.
    +
    723C> - 3: Grid identification.
    +
    724C> - 4: Gds/bms flag.
    +
    725C> - 5: Indicator of parameter.
    +
    726C> - 6: Type of level.
    +
    727C> - 7: Height/pressure, etc of level.
    +
    728C> - 8: Year of century.
    +
    729C> - 9: Month of year.
    +
    730C> - 10: Day of month.
    +
    731C> - 11: Hour of day.
    +
    732C> - 12: Minute of hour.
    +
    733C> - 13: Indicator of forecast time unit.
    +
    734C> - 14: Time range 1.
    +
    735C> - 15: Time range 2.
    +
    736C> - 16: Time range flag.
    +
    737C> - 17: Number included in average.
    +
    738C> - 18: Version number of grib spefication.
    +
    739C> - 19: Version nr of parameter table.
    +
    740C> - 20: Total length of grib message (including section 0).
    +
    741C> @param[out] kret error return.
    +
    742C>
    +
    743C> @note error return:
    +
    744C> - = 0 - no errors
    +
    745C> - = 8 - temp gds indicated, but no gds
    +
    746C>
    +
    747C> @author Bill Cavanaugh @date 1988-01-20
    +
    +
    748 SUBROUTINE ai082(MSGA,KPTR,KPDS,KRET)
    +
    749C
    +
    750C INCOMING MESSAGE HOLDER
    +
    751 CHARACTER*1 MSGA(*)
    +
    752C
    +
    753C ARRAY OF POINTERS AND COUNTERS
    +
    754 INTEGER KPTR(*)
    +
    755C PRODUCT DESCRIPTION SECTION ENTRIES
    +
    756 INTEGER KPDS(*)
    +
    757C
    +
    758 INTEGER KRET
    +
    759C
    +
    760C -------------------- COLLECT PDS VALUES
    +
    761C KPDS(1) - ID OF CENTER
    +
    762C KPDS(2) - MODEL IDENTIFICATION
    +
    763C KPDS(3) - GRID IDENTIFICATION
    +
    764C KPDS(4) - GDS/BMS FLAG
    +
    765C KPDS(5) - INDICATOR OF PARAMETER
    +
    766C ----------- 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
    +
    782C ----------- KPDS(8) - YEAR OF CENTURY
    +
    783C KPDS(9) - MONTH OF YEAR
    +
    784C KPDS(10) - DAY OF MONTH
    +
    785C KPDS(11) - HOUR OF DAY
    +
    786C KPDS(12) - MINUTE OF HOUR
    +
    787C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
    +
    788C KPDS(14) - TIME RANGE 1
    +
    789C KPDS(15) - TIME RANGE 2
    +
    790C ----------- KPDS(16) - TIME RANGE FLAG
    +
    791C
    +
    792 iss = is + 16
    +
    793 DO 400 i = 0, 7
    +
    794 kpds(i+8) = mova2i(msga(i+iss))
    +
    795 400 CONTINUE
    +
    796C ----------- 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
    +
    802C -----------SKIP OVER SOURCE BYTE 24
    +
    803C ----------- 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
    +
    859C> Extract information from the product description section (version 1).
    +
    860C>
    +
    861C> Program history log:
    +
    862C> - Bill Cavanaugh 1989-11-20
    +
    863C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    864C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    865C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    866C>
    +
    867C> @param[in] MSGA Array containing grib message.
    +
    868C> @param[inout] KPTR Array containing storage for following parameters.
    +
    869C> - 1: Unused.
    +
    870C> - 2: Unused.
    +
    871C> - 3: Length of pds.
    +
    872C> - 4: Length of gds.
    +
    873C> - 5: Length of bms.
    +
    874C> - 6: Length of pds.
    +
    875C> - 7: Value of current byte.
    +
    876C> - 8: Unused.
    +
    877C> - 9: Grib start byte nr.
    +
    878C> - 10: Grib/grid element count.
    +
    879C>
    +
    880C> @param[out] KPDS Array containing pds elements.
    +
    881C> - 1: Id of center
    +
    882C> - 2: Model identi.fication
    +
    883C> - 3: Grid identification.
    +
    884C> - 4: Gds/bms flag.
    +
    885C> - 5: Indicator of. parameter
    +
    886C> - 6: Type of level.
    +
    887C> - 7: Height/pressu.re , etc of level
    +
    888C> - 8: Year (including century).
    +
    889C> - 9: Month of year.
    +
    890C> - 10: Day of month..
    +
    891C> - 11: Hour of day.
    +
    892C> - 12: Minute of hour.
    +
    893C> - 13: Indicator of forecast time unit.
    +
    894C> - 14: Time range 1.
    +
    895C> - 15: Time range 2.
    +
    896C> - 16: Time range flag.
    +
    897C> - 17: Number included in average.
    +
    898C> - 18: Version nr of grib specification.
    +
    899C> - 19: Version nr of parameter table.
    +
    900C> - 20: Total byte count for source message.
    +
    901C> @param[out] KRET Error return.
    +
    902C>
    +
    903C> @note Source pds structure (version 1).
    +
    904C> - 1-3: Length of pds section in bytes.
    +
    905C> - 4: Parameter table version no. for international exchange (crrently no. 1).
    +
    906C> - 5: Center id.
    +
    907C> - 6: Model id.
    +
    908C> - 7: Grid id.
    +
    909C> - 8: Flag for gds/bms.
    +
    910C> - 9: Indicator for parameter.
    +
    911C> - 10: Indicator for type of level.
    +
    912C> - 11-12: Height, pressure of level.
    +
    913C> - 13: Year of century.
    +
    914C> - 14: Month.
    +
    915C> - 15: Day.
    +
    916C> - 16: Hour.
    +
    917C> - 17: Minute.
    +
    918C> - 18: Forecast time unit.
    +
    919C> - 19: P1 - pd of time.
    +
    920C> - 20: P2 - pd of time.
    +
    921C> - 21: Time range indicator.
    +
    922C> - 22-23: Number in average.
    +
    923C> - 24: Number misg from averages.
    +
    924C> - 25: Century.
    +
    925C> - 26: Indicator of parameter in locally re-defined parameter table..
    +
    926C> - 27-28: Units decimal scale factor (d).
    +
    927C> - 29-40: Reserved: need not be present.
    +
    928C> - 41-NN: National use.
    +
    929C> - Error return:
    +
    930C> - = 0 - No errors.
    +
    931C> - = 8 - Temp gds indicated, but no gds.
    +
    932C>
    +
    933C> @author Bill Cavanaugh @date 1988-01-20
    +
    +
    934 SUBROUTINE ai082a(MSGA,KPTR,KPDS,KRET)
    +
    935C
    +
    936C INCOMING MESSAGE HOLDER
    +
    937 CHARACTER*1 MSGA(*)
    +
    938C
    +
    939C ARRAY OF POINTERS AND COUNTERS
    +
    940 INTEGER KPTR(*)
    +
    941C PRODUCT DESCRIPTION SECTION ENTRIES
    +
    942 INTEGER KPDS(*)
    +
    943C
    +
    944 INTEGER KRET
    +
    945C
    +
    946 is = kptr(9)
    +
    947 igribl = 8
    +
    948C -------------------- COLLECT PDS VALUES
    +
    949C KPDS(1) - ID OF CENTER
    +
    950C KPDS(2) - MODEL IDENTIFICATION
    +
    951C KPDS(3) - GRID IDENTIFICATION
    +
    952C KPDS(4) - GDS/BMS FLAG
    +
    953C KPDS(5) - INDICATOR OF PARAMETER
    +
    954C ----------- 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
    +
    964C 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
    +
    970C
    +
    971C ----------- KPDS(8) - YEAR (INCLUDING CENTURY)
    +
    972C
    +
    973 iss = is + igribl + 12
    +
    974 icen = is + igribl + 24
    +
    975C
    +
    976 kpds(8) = mova2i(msga(icen)) * 100 + mova2i(msga(iss))
    +
    977C
    +
    978C KPDS(9) - MONTH OF YEAR
    +
    979C KPDS(10) - DAY OF MONTH
    +
    980C KPDS(11) - HOUR OF DAY
    +
    981C KPDS(12) - MINUTE OF HOUR
    +
    982C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
    +
    983C KPDS(14) - TIME RANGE 1
    +
    984C KPDS(15) - TIME RANGE 2
    +
    985C ----------- KPDS(16) - TIME RANGE FLAG
    +
    986C
    +
    987 iss = is + igribl + 13
    +
    988 DO 400 i = 0, 7
    +
    989 kpds(i+9) = mova2i(msga(i+iss))
    +
    990 400 CONTINUE
    +
    991C ----------- 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
    +
    997C -----------SKIP OVER SOURCE BYTE 28
    +
    998C ----------- 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
    +
    1054C> Extract information on unlisted grid to allow conversion to office note 84 format.
    +
    1055C>
    +
    1056C> Program history log:
    +
    1057C> - Bill Cavanaugh 1988-01-20
    +
    1058C> - Bill Cavanaugh 1989-03-16 Added mercator & lambert conformal processing.
    +
    1059C> - Bill Cavanaugh 1989-07-12 Corrected change entered 89-03-16 reordering
    +
    1060C> processing for lambert conformal and mercator grids.
    +
    1061C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    1062C>
    +
    1063C> @param[in] MSGA Array containing grib message.
    +
    1064C> @param[inout] KPTR Array containing storage for following parameters.
    +
    1065C> - 1): Unused.
    +
    1066C> - 2): Unused.
    +
    1067C> - 3): Length of pds.
    +
    1068C> - 4): Length of gds.
    +
    1069C> - 5): Length of bms.
    +
    1070C> - 6): Length of bds.
    +
    1071C> - 7): Value of current byte.
    +
    1072C> - 8): Unused.
    +
    1073C> - 9): Grib start byte nr.
    +
    1074C> - 0): Grib/grid element count.
    +
    1075C> @param[in] KPDS Array containing pds elements.
    +
    1076C> - 1): Id of center.
    +
    1077C> - 2): Model identification.
    +
    1078C> - 3): Grid identification.
    +
    1079C> - 4): Gds/bms flag.
    +
    1080C> - 5): Indicator of parameter.
    +
    1081C> - 6): Type of level.
    +
    1082C> - 7): Height/pressure , etc of level.
    +
    1083C> - 8): Year of century.
    +
    1084C> - 9): Month of year.
    +
    1085C> - 10: Day of month.
    +
    1086C> - 11: Hour of day.
    +
    1087C> - 12: Minute of hour.
    +
    1088C> - 13: Indicator of forecast time unit.
    +
    1089C> - 14: Time range 1.
    +
    1090C> - 15: Time range 2.
    +
    1091C> - 16: Time range flag.
    +
    1092C> - 17: Number included in average.
    +
    1093C> - 18: Version nr of grib specification.
    +
    1094C> @param[out] KGDS Array containing gds elements..
    +
    1095C> - 1): Data representation type.
    +
    1096C> - Latitude/Longitude grids
    +
    1097C> - 2): N(i) nr points on latitude circle.
    +
    1098C> - 3): N(j) nr points on longitude meridian.
    +
    1099C> - 4): La(1) latitude of origin.
    +
    1100C> - 5): Lo(1) longitude of origin.
    +
    1101C> - 6): Resolution flag.
    +
    1102C> - 7): La(2) latitude of extreme point.
    +
    1103C> - 8): Lo(2) longitude of extreme point.
    +
    1104C> - 9): Di longitudinal direction of increment.
    +
    1105C> - 10: Dj latitudinal direction of increment.
    +
    1106C> - 11: Scanning mode flag.
    +
    1107C> - Polar stereographic grids.
    +
    1108C> - 2): N(i) nr points along lat circle.
    +
    1109C> - 3): N(j) nr points along lon circle.
    +
    1110C> - 4): La(1) latitude of origin.
    +
    1111C> - 5): Lo(1) longitude of origin.
    +
    1112C> - 6): Reserved.
    +
    1113C> - 7): Lov grid orientation.
    +
    1114C> - 8): Dx - x direction increment.
    +
    1115C> - 9): Dy - y direction increment.
    +
    1116C> - 10: Projection center flag.
    +
    1117C> - 11: Scanning mode.
    +
    1118C> - Spherical harmonic coefficients.
    +
    1119C> - 2): J pentagonal resolution parameter.
    +
    1120C> - 3): K pentagonal resolution parameter.
    +
    1121C> - 4): M pentagonal resolution parameter.
    +
    1122C> - 5): Representation type.
    +
    1123C> - 6): Coefficient storage mode.
    +
    1124C> - Mercator grids.
    +
    1125C> - 2): N(i) nr points on latitude circle.
    +
    1126C> - 3): N(j) nr points on longitude meridian.
    +
    1127C> - 4): La(1) latitude of origin.
    +
    1128C> - 5): Lo(1) longitude of origin.
    +
    1129C> - 6): Resolution flag.
    +
    1130C> - 7): La(2) latitude of last grid point.
    +
    1131C> - 8): Lo(2) longitude of last grid point.
    +
    1132C> - 9): Longit dir increment.
    +
    1133C> - 10: Latit dir increment.
    +
    1134C> - 11: Scanning mode flag.
    +
    1135C> - 12: Latitude intersection.
    +
    1136C> - Lambert conformal grids.
    +
    1137C> - 2): Nx nr points along x-axis.
    +
    1138C> - 3): Ny nr points along y-axis.
    +
    1139C> - 4): La1 lat of origin (lower left).
    +
    1140C> - 5): Lo1 lon of origin (lower left).
    +
    1141C> - 6): Reserved.
    +
    1142C> - 7): Lov - orientation of grid.
    +
    1143C> - 8): Dx - x-dir increment.
    +
    1144C> - 9): Dy - y-dir increment.
    +
    1145C> - 10: Projection center flag.
    +
    1146C> - 11: Scanning mode flag.
    +
    1147C> - 12: Latin 1 - first lat from pole of secant cone inter.
    +
    1148C> - 13: Latin 2 - second lat from pole of secant cone inter.
    +
    1149C> @param[out] KRET Error return.
    +
    1150C>
    +
    1151C> @note KRET
    +
    1152C> - = 0
    +
    1153C> - = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
    +
    1154C>
    +
    1155C> @author Bill Cavanaugh @date 1988-01-20
    +
    1156
    +
    +
    1157 SUBROUTINE ai083(MSGA,KPTR,KPDS,KGDS,KRET)
    +
    1158C ************************************************************
    +
    1159C INCOMING MESSAGE HOLDER
    +
    1160 CHARACTER*1 MSGA(*)
    +
    1161C
    +
    1162C ARRAY GDS ELEMENTS
    +
    1163 INTEGER KGDS(*)
    +
    1164C ARRAY OF POINTERS AND COUNTERS
    +
    1165 INTEGER KPTR(*)
    +
    1166C ARRAY OF PDS ELEMENTS
    +
    1167 INTEGER KPDS(*)
    +
    1168C
    +
    1169 INTEGER KRET
    +
    1170C
    +
    1171C DATA MSK80 /Z00000080/
    +
    1172C
    +
    1173 DATA msk80 /128/
    +
    1174C ********************************************************
    +
    1175C IF FLAG IN PDS INDICATE THAT THERE IS NO GDS ,
    +
    1176C RETURN IMMEDIATELY
    +
    1177C ************************************************************
    +
    1178 IF (iand(kpds(4),msk80).EQ.0) GO TO 900
    +
    1179C ------------------- 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
    +
    1187C ------------------- BYTE 4 NUMBER OF UNUSED BITS AT END OF SEC
    +
    1188C ------------------- BYTE 5 RESERVED
    +
    1189C ------------------- BYTE 6 DATA REPRESENTATION TYPE
    +
    1190 kgds(1) = mova2i(msga(iss+5))
    +
    1191C ------------------- 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
    +
    1205C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
    +
    1206 kret = 4
    +
    1207 GO TO 900
    +
    1208 END IF
    +
    1209C
    +
    1210C ------------------- LATITUDE/LONGITUDE GRIDS
    +
    1211C
    +
    1212C ------------------- 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
    +
    1217C ------------------- 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
    +
    1222C ------------------- 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
    +
    1230C ------------------- 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
    +
    1238C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1239 kgds(6) = mova2i(msga(iss+16))
    +
    1240C ------------------- 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
    +
    1248C ------------------- 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
    +
    1256C ------------------- 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
    +
    1261C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
    +
    1262C HAVE LONGIT DIR INCREMENT
    +
    1263C ELSE IF GAUSSIAN GRID
    +
    1264C HAVE NR OF LAT CIRCLES
    +
    1265C 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
    +
    1270C ------------------- BYTE 28 SCANNING MODE FLAGS
    +
    1271 kgds(11) = mova2i(msga(iss+27))
    +
    1272C ------------------- BYTE 29-32 RESERVED
    +
    1273C -------------------
    +
    1274 GO TO 900
    +
    1275C -------------------
    +
    1276C ' POLAR STEREO PROCESSING '
    +
    1277C
    +
    1278C ------------------- 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
    +
    1283C ------------------- 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
    +
    1288C ------------------- 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
    +
    1296C ------------------- 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
    +
    1304C ------------------- BYTE 17 RESERVED
    +
    1305 kgds(6) = mova2i(msga(iss+16))
    +
    1306C ------------------- 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
    +
    1314C ------------------- 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
    +
    1322C ------------------- 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
    +
    1330C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1331 kgds(10) = mova2i(msga(iss+26))
    +
    1332C ------------------- BYTE 28 SCANNING MODE
    +
    1333 kgds(11) = mova2i(msga(iss+27))
    +
    1334C ------------------- BYTE 29-32 RESERVED
    +
    1335C -------------------
    +
    1336 GO TO 900
    +
    1337C
    +
    1338C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
    +
    1339C
    +
    1340C ------------------- 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
    +
    1345C ------------------- 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
    +
    1350C ------------------- 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
    +
    1355C ------------------- BYTE 13 REPRESENTATION TYPE
    +
    1356 kgds(5) = mova2i(msga(iss+12))
    +
    1357C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
    +
    1358 kgds(6) = mova2i(msga(iss+13))
    +
    1359C ------------------- EMPTY FIELDS - BYTES 15 - 32
    +
    1360 kret = 0
    +
    1361 GO TO 900
    +
    1362C ------------------- PROCESS MERCATOR GRIDS
    +
    1363C
    +
    1364C ------------------- 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
    +
    1369C ------------------- 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
    +
    1374C ------------------- 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
    +
    1382C ------------------- 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
    +
    1390C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1391 kgds(6) = mova2i(msga(iss+16))
    +
    1392C ------------------- 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
    +
    1400C ------------------- 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
    +
    1408C ------------------- 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
    +
    1416C ------------------- 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
    +
    1424C ------------------- BYTE 28 SCANNING MODE FLAGS
    +
    1425 kgds(11) = mova2i(msga(iss+27))
    +
    1426C ------------------- 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
    +
    1431C ------------------- BYTE 32 RESERVED
    +
    1432C -------------------
    +
    1433 GO TO 900
    +
    1434C ------------------- PROCESS LAMBERT CONFORMAL
    +
    1435C
    +
    1436C ------------------- 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
    +
    1441C ------------------- 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
    +
    1446C ------------------- 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
    +
    1454C ------------------- 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
    +
    1462C ------------------- BYTE 17 RESERVED
    +
    1463C KGDS(6) =
    +
    1464C ------------------- 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
    +
    1472C ------------------- 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
    +
    1477C ------------------- 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
    +
    1482C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1483 kgds(10) = mova2i(msga(iss+26))
    +
    1484C ------------------- BYTE 28 SCANNING MODE
    +
    1485 kgds(11) = mova2i(msga(iss+27))
    +
    1486C ------------------- 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
    +
    1494C ------------------- 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
    +
    1502C -------------------
    +
    1503 900 CONTINUE
    +
    1504 RETURN
    +
    +
    1505 END
    +
    1506
    +
    1507C> If bit map sec is available in grib message,extract
    +
    1508C> for program use, otherwise generate an appropriate bit map.
    +
    1509C>
    +
    1510C> Program history log:
    +
    1511C> - Bill Cavanaugh 1988-01-20
    +
    1512C> - Bill Cavanaugh 1989-02-24 Increment of position in bit map when bit map was included was handled improperly. corrected this data.
    +
    1513C> - Bill Cavanaugh 1989-07-12 Altered method of calculating nr of bits in a bit map contained in grib message.
    +
    1514C> - Bill Cavanaugh 1990-05-07 Brings all u.s. grids to revised values as of dec 89.
    +
    1515C> - William Bostelman 1990-07-15 Modiifed to test the grib bds byte size to determine what ecmwf grid array size is to be specified.
    +
    1516C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    1517C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    1518C>
    +
    1519C> @param[in] MSGA BUFR message.
    +
    1520C> @param[inout] KPTR Array containing storage for following parameters.
    +
    1521C> - 1: Unused.
    +
    1522C> - 2: Unused.
    +
    1523C> - 3: Length of pds.
    +
    1524C> - 4: Length of gds.
    +
    1525C> - 5: Length of bms.
    +
    1526C> - 6: Length of bds.
    +
    1527C> - 7: Value of current byte.
    +
    1528C> - 8: Unused.
    +
    1529C> - 9: Grib start byte nr.
    +
    1530C> - 10: Grib/grid element count.
    +
    1531C> @param[in] KPDS ARRAY CONTAINING PDS ELEMENTS.
    +
    1532C> - 1: Id of center.
    +
    1533C> - 2: Model identification.
    +
    1534C> - 3: Grid identification.
    +
    1535C> - 4: Gds/bms flag.
    +
    1536C> - 5: Indicator of parameter.
    +
    1537C> - 6: Type of level.
    +
    1538C> - 7: Height/pressure , etc of level.
    +
    1539C> - 8: Year of century.
    +
    1540C> - 9: Month of year.
    +
    1541C> - 10: Day of month.
    +
    1542C> - 11: Hour of day.
    +
    1543C> - 12: Minute of hour.
    +
    1544C> - 13: Indicator of forecast time unit.
    +
    1545C> - 14: Time range 1.
    +
    1546C> - 15: Time range 2.
    +
    1547C> - 16: Time range flag.
    +
    1548C> - 17: Number included in average.
    +
    1549C> - 18: Version nr of grib specification.
    +
    1550C> @param[out] kgds array containing gds elements.
    +
    1551C> - 1: data representation type
    +
    1552C> - Latitude/longitude grids
    +
    1553C> - 2: n(i) nr points on latitude circle
    +
    1554C> - 3: n(j) nr points on longitude meridian
    +
    1555C> - 4: la(1) latitude of origin
    +
    1556C> - 5: lo(1) longitude of origin
    +
    1557C> - 6: resolution flag
    +
    1558C> - 7: la(2) latitude of extreme point
    +
    1559C> - 8: lo(2) longitude of extreme point
    +
    1560C> - 9: di longitudinal direction of increment
    +
    1561C> - 10: dj latitundinal direction of increment
    +
    1562C> - 11: scanning mode flag
    +
    1563C> - Polar stereographic grids
    +
    1564C> - 2: n(i) nr points along lat circle
    +
    1565C> - 3: n(j) nr points along lon circle
    +
    1566C> - 4: la(1) latitude of origin
    +
    1567C> - 5: lo(1) longitude of origin
    +
    1568C> - 6: reserved
    +
    1569C> - 7: lov grid orientation
    +
    1570C> - 8: dx - x direction increment
    +
    1571C> - 9: dy - y direction increment
    +
    1572C> - 10: projection center flag
    +
    1573C> - 11: scanning mode
    +
    1574C> - Spherical harmonic coefficients
    +
    1575C> - 2: j pentagonal resolution parameter
    +
    1576C> - 3: k pentagonal resolution parameter
    +
    1577C> - 4: m pentagonal resolution parameter
    +
    1578C> - 5: representation type
    +
    1579C> - 6: coefficient storage mode
    +
    1580C> - Mercator grids
    +
    1581C> - 2: n(i) nr points on latitude circle
    +
    1582C> - 3: n(j) nr points on longitude meridian
    +
    1583C> - 4: la(1) latitude of origin
    +
    1584C> - 5: lo(1) longitude of origin
    +
    1585C> - 6: resolution flag
    +
    1586C> - 7: la(2) latitude of last grid point
    +
    1587C> - 8: lo(2) longitude of last grid point
    +
    1588C> - 9: longit dir increment
    +
    1589C> - 10: latit dir increment
    +
    1590C> - 11: scanning mode flag
    +
    1591C> - 12: latitude intersection
    +
    1592C> - Lambert conformal grids
    +
    1593C> - 2: nx nr points along x-axis
    +
    1594C> - 3: ny nr points along y-axis
    +
    1595C> - 4: la1 lat of origin (lower left)
    +
    1596C> - 5: lo1 lon of origin (lower left)
    +
    1597C> - 6: reserved
    +
    1598C> - 7: lov - orientation of grid
    +
    1599C> - 8: dx - x-dir increment
    +
    1600C> - 9: dy - y-dir increment
    +
    1601C> - 10: projection center flag
    +
    1602C> - 11: scanning mode flag
    +
    1603C> - 12: latin 1 - first lat from pole of secant cone inter
    +
    1604C> - 13: latin 2 - second lat from pole of secant cone inter
    +
    1605C> @param[out] KBMS Bitmap describing location of output elements..
    +
    1606C> @param[out] KRET Error return.
    +
    1607C>
    +
    1608C> @note KRET
    +
    1609C> - = 0 - No error.
    +
    1610C> - = 5 - Grid not avail for center indicated.
    +
    1611C> - = 10 - Incorrect center indicator.
    +
    1612C>
    +
    1613C> @author Bill Cavanaugh @date 1988-01-20
    +
    +
    1614 SUBROUTINE ai084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    +
    1615C
    +
    1616C INCOMING MESSAGE HOLDER
    +
    1617 CHARACTER*1 MSGA(*)
    +
    1618C
    +
    1619C BIT MAP
    +
    1620 LOGICAL KBMS(*)
    +
    1621C
    +
    1622C ARRAY OF POINTERS AND COUNTERS
    +
    1623 INTEGER KPTR(10)
    +
    1624C ARRAY OF POINTERS AND COUNTERS
    +
    1625 INTEGER KPDS(20)
    +
    1626 INTEGER KGDS(13)
    +
    1627C
    +
    1628 INTEGER KRET
    +
    1629 INTEGER MASK(8)
    +
    1630C ----------------------GRID 21 AND GRID 22 ARE THE SAME
    +
    1631 LOGICAL GRD21( 1369)
    +
    1632C ----------------------GRID 23 AND GRID 24 ARE THE SAME
    +
    1633 LOGICAL GRD23( 1369)
    +
    1634 LOGICAL GRD25( 1368)
    +
    1635 LOGICAL GRD26( 1368)
    +
    1636C ----------------------GRID 27 AND GRID 28 ARE THE SAME
    +
    1637C ----------------------GRID 29 AND GRID 30 ARE THE SAME
    +
    1638C ----------------------GRID 33 AND GRID 34 ARE THE SAME
    +
    1639 LOGICAL GRD50(1188)
    +
    1640C -----------------------GRID 61 AND GRID 62 ARE THE SAME
    +
    1641 LOGICAL GRD61( 4186)
    +
    1642C -----------------------GRID 63 AND GRID 64 ARE THE SAME
    +
    1643 LOGICAL GRD63( 4186)
    +
    1644C
    +
    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/
    +
    1650C LINE 1-4
    +
    1651 & 7*.false.,22*.true.,14*.false.,22*.true.,
    +
    1652 & 14*.false.,22*.true.,14*.false.,22*.true.,7*.false.,
    +
    1653C LINE 5-8
    +
    1654 & 6*.false.,24*.true.,12*.false.,24*.true.,
    +
    1655 & 12*.false.,24*.true.,12*.false.,24*.true.,6*.false.,
    +
    1656C LINE 9-12
    +
    1657 & 5*.false.,26*.true.,10*.false.,26*.true.,
    +
    1658 & 10*.false.,26*.true.,10*.false.,26*.true.,5*.false.,
    +
    1659C LINE 13-16
    +
    1660 & 4*.false.,28*.true., 8*.false.,28*.true.,
    +
    1661 & 8*.false.,28*.true., 8*.false.,28*.true.,4*.false.,
    +
    1662C LINE 17-20
    +
    1663 & 3*.false.,30*.true., 6*.false.,30*.true.,
    +
    1664 & 6*.false.,30*.true., 6*.false.,30*.true.,3*.false.,
    +
    1665C LINE 21-24
    +
    1666 & 2*.false.,32*.true., 4*.false.,32*.true.,
    +
    1667 & 4*.false.,32*.true., 4*.false.,32*.true.,2*.false.,
    +
    1668C LINE 25-28
    +
    1669 & .false.,34*.true., 2*.false.,34*.true.,
    +
    1670 & 2*.false.,34*.true., 2*.false.,34*.true., .false.,
    +
    1671C 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/
    +
    1676C DATA MSK40 /Z00000040/
    +
    1677 DATA msk40 /64/
    +
    1678C
    +
    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
    +
    1686C **********************************************************
    +
    1687C IF THE FLAG IN PDS INDICATES THAT THERE IS NO BMS,
    +
    1688C SET BIT MAP WITH ALL BITS ON
    +
    1689C ELSE
    +
    1690C RECOVER BIT MAP
    +
    1691C THEN RETURN
    +
    1692C **********************************************************
    +
    1693C ---------------- 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
    +
    1702C PRINT *,' NO BIT MAP',MSK40,KPDS(4)
    +
    1703 GO TO 400
    +
    1704 ELSE
    +
    1705 print *,' HAVE A BIT MAP'
    +
    1706 END IF
    +
    1707C ---------------- 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
    +
    1713C GET NUMBER OF UNUSED BITS
    +
    1714 iubits = mova2i(msga(iss+3))
    +
    1715C 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
    +
    1721C ----------------- IF KFLAG = 0 PICK UP NEW BIT MAP
    +
    1722C ELSE
    +
    1723C ------------------ USE PREDEFINED BIT MAP
    +
    1724 maxbyt = kptr(5) - 6
    +
    1725 IF (kflag.EQ.0) THEN
    +
    1726C ------------------ 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
    +
    1744C ---------------------- PREDEFINED BIT MAP IS INDICATED
    +
    1745C IF GRID NUMBER DOES NOT MATCH AN
    +
    1746C EXISTING GRID, SET KRET TO 5 AND
    +
    1747C ---------------------- RETURN.
    +
    1748 400 CONTINUE
    +
    1749 kret = 0
    +
    1750C ---------------------- 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
    +
    1754C*** TEST FOR FULL HEMISPHERIC GRID ****
    +
    1755 IF (kptr(6) .GT. 2158) j= 1369
    +
    1756C*** *** **** *** ***
    +
    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
    +
    1773C ---------------------- 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
    +
    1776C ----- 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
    +
    1784C ----- 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
    +
    1792C ----- 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
    +
    1800C ----- 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
    +
    1808C ----- 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
    +
    1816C ----- 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
    +
    1824C ----- 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
    +
    1835C ---------------------- FNOC NAVY
    +
    1836 ELSE IF (kpds(1).EQ.58) THEN
    +
    1837 print *,' NO STANDARD FNOC GRID AT THIS TIME'
    +
    1838 RETURN
    +
    1839C ---------------------- U.S. GRIDS
    +
    1840 ELSE IF (kpds(1).EQ.7) THEN
    +
    1841 IF (kpds(3).EQ.5) THEN
    +
    1842C ----- 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
    +
    1850C ----- 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
    +
    1858C ----- 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
    +
    1866C ----- 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
    +
    1874C ----- 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
    +
    1882C ----- 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
    +
    1890C ----- 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
    +
    1898C ----- 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
    +
    1906C ----- 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
    +
    1914C ----- 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
    +
    1922C ----- 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
    +
    1930C ----- 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
    +
    1938C ----- 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
    +
    1946C ----- 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
    +
    1954C ----- 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
    +
    1962C ----- 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
    +
    1970C ----- 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
    +
    1978C ----- 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
    +
    2017C> Extract grib data and place into output arry in proper position.
    +
    2018C>
    +
    2019C> Program history log:
    +
    2020C> - Bill Cavanaugh 1988-01-20
    +
    2021C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    2022C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    2023C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    2024C>
    +
    2025C> @param[in] MSGA Array containing grib message.
    +
    2026C> @param[inout] KPTR Array containing storage for following parameters.
    +
    2027C> - 1: Unused.
    +
    2028C> - 2: Unused.
    +
    2029C> - 3: Length of pds.
    +
    2030C> - 4: Length of gds.
    +
    2031C> - 5: Length of bms.
    +
    2032C> - 6: Length of bds.
    +
    2033C> - 7: Value of current byte.
    +
    2034C> - 8: Unused.
    +
    2035C> - 9: Grib start byte nr.
    +
    2036C> - 10: Grib/grid element count.
    +
    2037C> @param[in] KPDS Array containing pds elements.
    +
    2038C> - 1: Id of center.
    +
    2039C> - 2: Model identification.
    +
    2040C> - 3: Grid identification.
    +
    2041C> - 4: Gds/bms flag.
    +
    2042C> - 5: Indicator of parameter.
    +
    2043C> - 6: Type of level.
    +
    2044C> - 7: Height/pressure , etc of level.
    +
    2045C> - 8: Year of century.
    +
    2046C> - 9: Month of year.
    +
    2047C> - 10: Day of month.
    +
    2048C> - 11: Hour of day.
    +
    2049C> - 12: Minute of hour.
    +
    2050C> - 13: Indicator of forecast time unit.
    +
    2051C> - 14: Time range 1.
    +
    2052C> - 15: Time range 2.
    +
    2053C> - 16: Time range flag.
    +
    2054C> - 17: Number included in average.
    +
    2055C> - 18: Version nr of grib specification.
    +
    2056C> @param[in] KBMS Bitmap describing location of output elements.
    +
    2057C> @param[out] DATA Real array of gridded elements in grib message.
    +
    2058C> @param[out] KRET Error return.
    +
    2059C>
    +
    2060C> @note Error return.
    +
    2061C> - 3 = Unpacked field is larger than 32768.
    +
    2062C> - 6 = Does not match nr of entries for this grib/grid.
    +
    2063C> - 7 = Number of bits in fill too large.
    +
    2064C>
    +
    2065C> @author Bill Cavanaugh @date 1988-01-20
    +
    +
    2066 SUBROUTINE ai085(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
    +
    2067C *************************************************************
    +
    2068 CHARACTER*1 MSGA(*)
    +
    2069 CHARACTER*1 KREF(8)
    +
    2070 CHARACTER*1 KK(8)
    +
    2071C
    +
    2072 LOGICAL KBMS(*)
    +
    2073C
    +
    2074 INTEGER KPDS(*)
    +
    2075 INTEGER KPTR(*)
    +
    2076 INTEGER NRBITS
    +
    2077 INTEGER KSAVE(105000)
    +
    2078 INTEGER KSCALE
    +
    2079C
    +
    2080 REAL DATA(*)
    +
    2081 REAL REFNCE
    +
    2082 REAL SCALE
    +
    2083 REAL REALKK
    +
    2084C
    +
    2085 LOGICAL IBM370
    +
    2086C
    +
    2087 equivalence(refnce,kref(1),iref)
    +
    2088 equivalence(kk(1),realkk,ikk)
    +
    2089C
    +
    2090C DATA MSK0F /Z0000000F/
    +
    2091C DATA MSK80 /Z00000080/
    +
    2092C DATA MSK40 /Z00000040/
    +
    2093C
    +
    2094 DATA msk0f /15/
    +
    2095 DATA msk80 /128/
    +
    2096 DATA msk40 /64/
    +
    2097C
    +
    2098C *************************************************************
    +
    2099 kret = 0
    +
    2100 is = kptr(9)
    +
    2101 iss = is + kptr(3) + kptr(4) + kptr(5) + 4
    +
    2102C BYTE 4
    +
    2103 kspl = mova2i(msga(iss+3))
    +
    2104C POINT TO BYTE 5 OF BDS
    +
    2105C
    +
    2106C ------------- GET SCALE FACTOR
    +
    2107C
    +
    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
    +
    2116C
    +
    2117C ------------ GET REFERENCE VALUE
    +
    2118C
    +
    2119 iref = 0
    +
    2120 DO 200 i = 0, 3
    +
    2121 kref(i+1) = msga(i+iss+6)
    +
    2122 200 CONTINUE
    +
    2123C
    +
    2124C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
    +
    2125C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
    +
    2126C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
    +
    2127C NUMBER OF YOUR MACHINE TYPE.
    +
    2128C
    +
    2129 ibm370 = .false.
    +
    2130C
    +
    2131 IF (.NOT.ibm370) THEN
    +
    2132 koff = 0
    +
    2133C GET 1 BIT SIGN
    +
    2134 CALL gbyte(iref,isgn,0,1)
    +
    2135C GET 7 BIT EXPONENT
    +
    2136 CALL gbyte(iref,iexp,1,7)
    +
    2137C 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
    +
    2146C
    +
    2147C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    +
    2148C
    +
    2149 kbits = mova2i(msga(iss+10))
    +
    2150 kentry = kptr(10)
    +
    2151C
    +
    2152C ------------- MAX SIZE CHECK
    +
    2153C
    +
    2154 IF (kentry.GT.105000) THEN
    +
    2155 kret = 3
    +
    2156 RETURN
    +
    2157 END IF
    +
    2158 IF (kbits.EQ.0) THEN
    +
    2159C
    +
    2160C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
    +
    2161C
    +
    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
    +
    2170C
    +
    2171C --------------------
    +
    2172C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    +
    2173C ENTRIES.
    +
    2174C
    +
    2175C ------------- UNUSED BITS IN DATA AREA
    +
    2176C
    +
    2177 lessbt = iand(kspl,msk0f)
    +
    2178C
    +
    2179C ------------- NUMBER OF BYTES IN DATA AREA
    +
    2180C
    +
    2181 nrbyte = kptr(6) - 11
    +
    2182C
    +
    2183C ------------- TOTAL NR OF USABLE BITS
    +
    2184C
    +
    2185 nrbits = nrbyte * 8 - lessbt
    +
    2186C
    +
    2187C ------------- TOTAL NR OF ENTRIES
    +
    2188C
    +
    2189 kentry = nrbits / kbits
    +
    2190C
    +
    2191C ------------- MAX SIZE CHECK
    +
    2192C
    +
    2193 IF (kentry.GT.105000) THEN
    +
    2194 kret = 3
    +
    2195 RETURN
    +
    2196 END IF
    +
    2197C
    +
    2198 ibms = iand(kpds(4),msk40)
    +
    2199C
    +
    2200C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
    +
    2201C IF YES,
    +
    2202C GO AND PROCESS AS SUCH
    +
    2203C ELSE
    +
    2204C CONTINUE PROCESSING
    +
    2205C
    +
    2206 IF (iand(kspl,msk80).EQ.0) THEN
    +
    2207C
    +
    2208C ------------- SET POINTERS
    +
    2209C
    +
    2210C XMOVEX MOVES THE DATA TO MAKE SURE IT IS ON A INTEGER WORD
    +
    2211C BOUNDARY, ON SOME COMPUTERS THIS DOES NOT HAVE TO BE DONE.
    +
    2212C (IBM PC, VAX)
    +
    2213C
    +
    2214C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
    +
    2215C ------------- UNPACK ALL FIELDS
    +
    2216 koff = 0
    +
    2217C
    +
    2218C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
    +
    2219C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
    +
    2220C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
    +
    2221C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
    +
    2222C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
    +
    2223C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
    +
    2224C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
    +
    2225C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
    +
    2226C IN FORTRAN AN ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
    +
    2227C COMPUTERS. THEY ALSO HAVE A C VERSION.
    +
    2228C
    +
    2229C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2230C
    +
    2231C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2232C INTEGER WORD BOUNDARY
    +
    2233C
    +
    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)
    +
    2238C
    +
    2239C ------------- CORRECTLY PLACE ALL ENTRIES
    +
    2240C
    +
    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
    +
    2253C
    +
    2254C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
    +
    2255C
    +
    2256 ikk = 0
    +
    2257 DO 5500 i = 0, 3
    +
    2258 kk(i+1) = msga(i+iss+11)
    +
    2259 5500 CONTINUE
    +
    2260C
    +
    2261 IF (.NOT.ibm370) THEN
    +
    2262 koff = 0
    +
    2263C GET 1 BIT SIGN
    +
    2264 CALL gbyte(ikk,isgn,0,1)
    +
    2265C GET 7 BIT EXPONENT
    +
    2266 CALL gbyte(ikk,iexp,1,7)
    +
    2267C 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
    +
    2276C
    +
    2277 DATA(1) = realkk
    +
    2278 koff = 0
    +
    2279C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
    +
    2280C ------------- UNPACK ALL FIELDS
    +
    2281C
    +
    2282C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2283C
    +
    2284C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2285C INTEGER WORD BOUNDARY
    +
    2286C
    +
    2287 lll = mod(iss+14,8)
    +
    2288 nnn = 15 - lll
    +
    2289 koff = lll * 8
    +
    2290C
    +
    2291 CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2292C
    +
    2293C --------------
    +
    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
    +
    2302C> Extract grib data (version 1) and place into proper position in output array.
    +
    2303C>
    +
    2304C> Program history log:
    +
    2305C> - Bill Cavanaugh 1989-11-20
    +
    2306C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    2307C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    2308C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    2309C>
    +
    2310C> @param[in] MSGA Array containing grib message.
    +
    2311C> @param[inout] KPTR Array containing storage for following parameters.
    +
    2312C> - 1:Unused.
    +
    2313C> - 2:Unused.
    +
    2314C> - 3:Length of pds.
    +
    2315C> - 4:Length of gds.
    +
    2316C> - 5:Length of bms.
    +
    2317C> - 6:Length of bds.
    +
    2318C> - 7:Value of current byte.
    +
    2319C> - 8:Unused.
    +
    2320C> - 9:Grib start byte nr.
    +
    2321C> - 10:Grib/grid element count.
    +
    2322C> @param[in] KPDS Array containing pds elements. (version 1)
    +
    2323C> - 1: Id of center.
    +
    2324C> - 2: Model identification.
    +
    2325C> - 3: Grid identification.
    +
    2326C> - 4: Gds/bms flag.
    +
    2327C> - 5: Indicator of parameter.
    +
    2328C> - 6: Type of level.
    +
    2329C> - 7: Height/pressure , etc of level.
    +
    2330C> - 8: Year including century.
    +
    2331C> - 9: Month of year.
    +
    2332C> - 10: Day of month.
    +
    2333C> - 11: Hour of day.
    +
    2334C> - 12: Minute of hour.
    +
    2335C> - 13: Indicator of forecast time unit.
    +
    2336C> - 14: Time range 1.
    +
    2337C> - 15: Time range 2.
    +
    2338C> - 16: Time range flag.
    +
    2339C> - 17: Number included in average.
    +
    2340C> - 18: Version nr of grib specification.
    +
    2341C> - 19: Version nr of parameter table.
    +
    2342C> - 20: Total length of grib message (including section 0).
    +
    2343C> @param[in] KBMS Bitmap describing location of output elements.
    +
    2344C> @param[out] DATA Real array of gridded elements in grib message.
    +
    2345C> @param[out] KRET Error return.
    +
    2346C>
    +
    2347C> @note Structure of binary data section (version 1)
    +
    2348C> - 1-3: LENGTH OF SECTION
    +
    2349C> - 4: PACKING FLAGS
    +
    2350C> - 5-6: SCALE FACTOR
    +
    2351C> - 7-10: REFERENCE VALUE
    +
    2352C> - 11: NUMBER OF BIT FOR EACH VALUE
    +
    2353C> - 12s-N: DATA
    +
    2354C>
    +
    2355C> @note Error return:
    +
    2356C> - 3 = Unpacked field is larger than 32768.
    +
    2357C> - 6 = Does not match nr of entries for this grib/grid.
    +
    2358C> - 7 = Number of bits in fill too large.
    +
    2359C>
    +
    2360C> @author Bill Cavanaugh @date 1989-11-20
    +
    +
    2361 SUBROUTINE ai085a(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
    +
    2362C *************************************************************
    +
    2363 CHARACTER*1 MSGA(*)
    +
    2364 CHARACTER*1 KREF(8)
    +
    2365 CHARACTER*1 KK(8)
    +
    2366C
    +
    2367 LOGICAL KBMS(*)
    +
    2368C
    +
    2369 INTEGER KPDS(*)
    +
    2370 INTEGER KPTR(*)
    +
    2371 INTEGER NRBITS
    +
    2372 INTEGER KSAVE(105000)
    +
    2373 INTEGER KSCALE
    +
    2374C
    +
    2375 REAL DATA(*)
    +
    2376 REAL REFNCE
    +
    2377 REAL SCALE
    +
    2378 REAL REALKK
    +
    2379C
    +
    2380 LOGICAL IBM370
    +
    2381C
    +
    2382 equivalence(refnce,kref(1),iref)
    +
    2383 equivalence(kk(1),realkk,ikk)
    +
    2384C
    +
    2385C DATA MSK0F /Z0000000F/
    +
    2386C DATA MSK40 /Z00000040/
    +
    2387C DATA MSK80 /Z00000080/
    +
    2388C
    +
    2389 DATA msk0f /15/
    +
    2390 DATA msk40 /64/
    +
    2391 DATA msk80 /128/
    +
    2392C
    +
    2393C *************************************************************
    +
    2394C
    +
    2395 kret = 0
    +
    2396 is = kptr(9)
    +
    2397 igribl = 8
    +
    2398 iss = is + kptr(3) + kptr(4) + kptr(5) + igribl
    +
    2399C BYTE 4
    +
    2400 kspl = mova2i(msga(iss+3))
    +
    2401C
    +
    2402C ------------- POINT TO BYTE 5 OF BDS
    +
    2403C
    +
    2404C ------------- GET SCALE FACTOR
    +
    2405C
    +
    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
    +
    2414C
    +
    2415C -------------------- DECIMAL SCALE EXPONENT
    +
    2416C
    +
    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
    +
    2422C 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
    +
    2427C
    +
    2428C ------------ GET REFERENCE VALUE
    +
    2429C
    +
    2430 iref = 0
    +
    2431 DO 200 i = 0, 3
    +
    2432 kref(i+1) = msga(i+iss+6)
    +
    2433 200 CONTINUE
    +
    2434C
    +
    2435C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
    +
    2436C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
    +
    2437C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
    +
    2438C NUMBER OF YOUR MACHINE TYPE.
    +
    2439C
    +
    2440 ibm370 = .false.
    +
    2441C
    +
    2442 IF (.NOT.ibm370) THEN
    +
    2443 koff = 0
    +
    2444C GET 1 BIT SIGN
    +
    2445 CALL gbyte(iref,isgn,0,1)
    +
    2446C GET 7 BIT EXPONENT
    +
    2447 CALL gbyte(iref,iexp,1,7)
    +
    2448C 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
    +
    2457C
    +
    2458C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    +
    2459C
    +
    2460 kbits = mova2i(msga(iss+10))
    +
    2461 kentry = kptr(10)
    +
    2462C
    +
    2463C ------------- MAX SIZE CHECK
    +
    2464C
    +
    2465 IF (kentry.GT.105000) THEN
    +
    2466 kret = 3
    +
    2467 RETURN
    +
    2468 END IF
    +
    2469C
    +
    2470 IF (kbits.EQ.0) THEN
    +
    2471C
    +
    2472C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
    +
    2473C
    +
    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
    +
    2482C
    +
    2483C --------------------
    +
    2484C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    +
    2485C ENTRIES.
    +
    2486C
    +
    2487C ------------- UNUSED BITS IN DATA AREA
    +
    2488C
    +
    2489 lessbt = iand(kspl,msk0f)
    +
    2490C
    +
    2491C ------------- NUMBER OF BYTES IN DATA AREA
    +
    2492C
    +
    2493 nrbyte = kptr(6) - 11
    +
    2494C
    +
    2495C ------------- TOTAL NR OF USABLE BITS
    +
    2496C
    +
    2497 nrbits = nrbyte * 8 - lessbt
    +
    2498C
    +
    2499C ------------- TOTAL NR OF ENTRIES
    +
    2500C
    +
    2501 kentry = nrbits / kbits
    +
    2502C
    +
    2503C ------------- MAX SIZE CHECK
    +
    2504C
    +
    2505 IF (kentry.GT.105000) THEN
    +
    2506 kret = 3
    +
    2507 RETURN
    +
    2508 END IF
    +
    2509 ibms = iand(kpds(4),msk40)
    +
    2510C
    +
    2511C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
    +
    2512C IF YES,
    +
    2513C GO AND PROCESS AS SUCH
    +
    2514C ELSE
    +
    2515C CONTINUE PROCESSING
    +
    2516 IF (iand(kspl,msk80).EQ.0) THEN
    +
    2517C
    +
    2518C ------------- SET POINTERS
    +
    2519C
    +
    2520C REPLACE XMOVEX AND W3AI41 WITH GBYTES
    +
    2521C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
    +
    2522C
    +
    2523C ------------- UNPACK ALL FIELDS
    +
    2524C
    +
    2525 koff = 0
    +
    2526C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2527C
    +
    2528C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
    +
    2529C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
    +
    2530C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
    +
    2531C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
    +
    2532C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
    +
    2533C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
    +
    2534C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
    +
    2535C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
    +
    2536C IN FORTRAN AND ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
    +
    2537C COMPUTERS. THEY ALSO HAVE A C VERSION.
    +
    2538C
    +
    2539C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2540C INTEGER WORD BOUNDARY
    +
    2541C
    +
    2542 lll = mod(iss+10,8)
    +
    2543 nnn = 11 - lll
    +
    2544 koff = lll * 8
    +
    2545C
    +
    2546 CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2547C
    +
    2548C ------------- CORRECTLY PLACE ALL ENTRIES
    +
    2549C
    +
    2550 ii = 1
    +
    2551 kentry = kptr(10)
    +
    2552 DO 500 i = 1, kentry
    +
    2553 IF (kbms(i)) THEN
    +
    2554C 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
    +
    2563C
    +
    2564C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
    +
    2565C
    +
    2566 ikk = 0
    +
    2567 DO 5500 i = 0, 3
    +
    2568 kk(i+1) = msga(i+iss+11)
    +
    2569 5500 CONTINUE
    +
    2570C
    +
    2571 IF (.NOT.ibm370) THEN
    +
    2572 koff = 0
    +
    2573C GET 1 BIT SIGN
    +
    2574 CALL gbyte(ikk,isgn,0,1)
    +
    2575C GET 7 BIT EXPONENT
    +
    2576 CALL gbyte(ikk,iexp,1,7)
    +
    2577C 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
    +
    2586C
    +
    2587 DATA(1) = realkk
    +
    2588 koff = 0
    +
    2589C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
    +
    2590C
    +
    2591C ------------- UNPACK ALL FIELDS
    +
    2592C
    +
    2593C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2594C --------------
    +
    2595C
    +
    2596C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2597C INTEGER WORD BOUNDARY
    +
    2598C
    +
    2599 lll = mod(iss+14,8)
    +
    2600 nnn = 15 - lll
    +
    2601 koff = lll * 8
    +
    2602C
    +
    2603 CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2604C
    +
    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
    +
    2612C> To test when gds is available to see if size mismatch
    +
    2613C> on existing grids (by center) is indicated.
    +
    2614C>
    +
    2615C> Program history log:
    +
    2616C> - Bill Cavanaugh 1988-02-08
    +
    2617C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    2618C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    2619C>
    +
    2620C> @param[in] J Size for indicated grid.
    +
    2621C> @param[in] KPDS
    +
    2622C> @param[in] KGDS
    +
    2623C> @param[out] KRET Error return.
    +
    2624C>
    +
    2625C> @note KRET = 9 - GDS indicates size mismatch with std grid.
    +
    2626C>
    +
    2627C> @author Bill Cavanaugh @date 1988-02-08
    +
    2628C$$$
    +
    +
    2629 SUBROUTINE ai087(*,J,KPDS,KGDS,KRET)
    +
    2630 INTEGER KPDS(20)
    +
    2631 INTEGER KGDS(13)
    +
    2632 INTEGER J
    +
    2633 INTEGER I
    +
    2634C ---------------------------------------
    +
    2635C ---------------------------------------
    +
    2636C IF GDS NOT INDICATED, RETURN
    +
    2637C ----------------------------------------
    +
    2638 IF (iand(kpds(4),128).EQ.0) RETURN
    +
    2639C ---------------------------------------
    +
    2640C GDS IS INDICATED, PROCEED WITH TESTING
    +
    2641C ---------------------------------------
    +
    2642 i = kgds(2) * kgds(3)
    +
    2643C ---------------------------------------
    +
    2644C TEST ECMWF CONTENT
    +
    2645C ---------------------------------------
    +
    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
    +
    2656C ---------------------------------------
    +
    2657C U.K. MET OFFICE, BRACKNELL
    +
    2658C ---------------------------------------
    +
    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
    +
    2681C ---------------------------------------
    +
    2682C NAVY - FNOC
    +
    2683C ---------------------------------------
    +
    2684 ELSE IF (kpds(1).EQ.58) THEN
    +
    2685 print *,' NO CURRENT LISTING OF NAVY GRIDS'
    +
    2686 RETURN 1
    +
    2687C ---------------------------------------
    +
    2688C U.S. GRIDS
    +
    2689C ---------------------------------------
    +
    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
    +
    2764C ------------------------------------
    +
    2765C NORMAL EXIT
    +
    2766C ------------------------------------
    +
    2767 kret = 0
    +
    2768 RETURN
    +
    +
    2769 END
    +
    gbyte
    subroutine gbyte(ipackd, iunpkd, noff, nbits)
    This is the fortran version of gbyte.
    Definition gbyte.f:27
    +
    gbytes
    subroutine gbytes(ipackd, iunpkd, noff, nbits, iskip, iter)
    Program history log:
    Definition gbytes.f:26
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition mova2i.f:25
    +
    ai081
    subroutine ai081(msga, kptr, kpds, kret)
    Find 'grib; characters and set pointers to the next byte following 'grib'.
    Definition w3ai08.f:569
    +
    ai082a
    subroutine ai082a(msga, kptr, kpds, kret)
    Extract information from the product description section (version 1).
    Definition w3ai08.f:935
    +
    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
    +
    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
    +
    ai085
    subroutine ai085(msga, kptr, kpds, kbms, data, kret)
    Extract grib data and place into output arry in proper position.
    Definition w3ai08.f:2067
    +
    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
    +
    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
    +
    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
    +
    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
    diff --git a/w3ai15_8f.html b/w3ai15_8f.html index 1ac7e96f..65e065b3 100644 --- a/w3ai15_8f.html +++ b/w3ai15_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai15.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai15.f File Reference
    +
    w3ai15.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ai15 (nbufa, nbufb, n1, n2, minus)
     Converts a set of binary numbers to an equivalent set of ascii number fields in core.
     

    Detailed Description

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

    @@ -107,8 +113,8 @@

    Definition in file w3ai15.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai15()

    + +

    ◆ w3ai15()

    @@ -117,31 +123,31 @@

    subroutine w3ai15 ( integer, dimension(*)  - NBUFA, + nbufa, integer, dimension(*)  - NBUFB, + nbufb,   - N1, + n1,   - N2, + n2, character*1  - MINUS  + minus  @@ -189,7 +195,7 @@

    diff --git a/w3ai15_8f.js b/w3ai15_8f.js index 93c3356f..5f7a045a 100644 --- a/w3ai15_8f.js +++ b/w3ai15_8f.js @@ -1,4 +1,4 @@ var w3ai15_8f = [ - [ "w3ai15", "w3ai15_8f.html#acb162c72ac381b1874762eff242118d5", null ] + [ "w3ai15", "w3ai15_8f.html#a87103805250f46624e11c6ca8c68b288", null ] ]; \ No newline at end of file diff --git a/w3ai15_8f_source.html b/w3ai15_8f_source.html index cb1c1b2e..9e017ee3 100644 --- a/w3ai15_8f_source.html +++ b/w3ai15_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai15.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,142 +81,150 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ai15.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Converts a set of binary numbers to an equivalent set
    +
    3C> of ascii number fields in core.
    +
    4C> @author R. Allard @date 1974-01
    +
    5
    +
    6C> Converts a set of binary numbers to an equivalent set
    +
    7C> of ascii number fields in core. This is an alternate procedure
    +
    8C> to the use of the 360/195 version of encode.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - R. Allard 1974-01-15
    +
    12C> - Ralph Jones 1989-02-06 Change from assembler to fortran
    +
    13C> this subroutine should be rewritten in intel 8088 assembly language.
    +
    14C> - Ralph Jones 1990-08-13 Change to cray cft77 fortran.
    +
    15C> - Boi Vuong 2012-11-05 Change variable zero fill for little-endian.
    +
    16C>
    +
    17C> @param[in] NBUFA Input array (integer*4).
    +
    18C> @param[in] N1 Number of integers in nbufa to be converted.
    +
    19C> @param[in] N2 Desired character width of ascii number field.
    +
    20C> @param[in] MINUS Character to be inserted in the high order position
    +
    21C> of a negative number field.
    +
    22C> @param[out] NBUFB Output array (integer*4).
    +
    23C>
    +
    24C> @note If n2 is greater than 4, allow two words (eight characters)
    +
    25C> in the nbufb array for each ascii number field. A number field
    +
    26C> is left adjusted with blank fill to the right if needed.
    +
    27C> Likewise, if n2 is less than 4, the result is left adjusted
    +
    28C> with blank fill to the right.
    +
    29C>
    +
    30C> @note N2 can be specified in the range 1-8. An eight digit positive
    +
    31C> integer can be converted or a seven digit negative integer
    +
    32C> and a sign. Zero fill is used for high order positions in a
    +
    33C> number field. The user should be aware that w3ai15 does not
    +
    34C> verify that the value of n2 is in the correct range.
    +
    35C>
    +
    36C> @note The minus sign can be inserted as a literal in the call
    +
    37C> sequence or defined in a data statement. 1h- and 1h+ are the
    +
    38C> two most likely negative signs. Unfortunately the ascii plus
    +
    39C> character is the negative sign required in most transmissions.
    +
    40C> The minus sign will always be in the high order position of a
    +
    41C> negative number field.
    +
    42C>
    +
    43C> @note If a number contains more digits than the n2 specification
    +
    44C> allows, the excess high order digits are lost.
    +
    45C>
    +
    46C> @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)
    +
    55C
    +
    56 CHARACTER*1 BLANK
    +
    57 CHARACTER*1 JTEMP(8)
    +
    58 CHARACTER*1 MINUS
    +
    59 CHARACTER*1 NUM(0:9)
    +
    60C
    +
    61 LOGICAL ISIGN
    +
    62C
    +
    63 equivalence(btemp,jtemp(1))
    +
    64C
    +
    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'/
    +
    68C 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
    +
    74C FOR BIG_ENDIAN
    +
    75c DATA ZERO /Z'3020202020202020',Z'3030202020202020',
    +
    76c & Z'3030302020202020',Z'3030303020202020',
    +
    77c & Z'3030303030202020',Z'3030303030302020',
    +
    78c & Z'3030303030303020',Z'3030303030303030'/
    +
    79C
    +
    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
    +
    113C
    +
    114 nbufb(i) = btemp
    +
    115C
    +
    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/w3ai18_8f.html b/w3ai18_8f.html index ed526b6f..afd491aa 100644 --- a/w3ai18_8f.html +++ b/w3ai18_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai18.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai18.f File Reference
    +
    w3ai18.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ai18 (item, i1, i2, line, l, k, n)
     Build a line of information composed of user specified character strings.
     

    Detailed Description

    Line builder subroutine.

    @@ -107,8 +113,8 @@

    Definition in file w3ai18.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai18()

    + +

    ◆ w3ai18()

    @@ -117,43 +123,43 @@

    subroutine w3ai18 ( character * (*)  - ITEM, + item,   - I1, + i1,   - I2, + i2, character * (*)  - LINE, + line,   - L, + l,   - K, + k,   - N  + n  @@ -204,7 +210,7 @@

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

    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...
     
    subroutine w3ai19 (line, l, nblk, n, next)
     Fills a record block with logical records or lines of information.
     

    Detailed Description

    Blocker Subroutine.

    @@ -107,8 +113,8 @@

    Definition in file w3ai19.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai19()

    + +

    ◆ w3ai19()

    @@ -117,31 +123,31 @@

    subroutine w3ai19 ( character * 1, dimension(*)  - LINE, + line, integer  - L, + l, character * 1, dimension(*)  - NBLK, + nblk, integer  - N, + n, integer  - NEXT  + next  @@ -189,7 +195,7 @@

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

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai24.f File Reference
    +
    w3ai24.f File Reference
    @@ -94,11 +100,11 @@

    Go to the source code of this file.

    - - - - + + +

    +

    Functions/Subroutines

    logical function w3ai24 (STRING1, STRING2, LENGTH)
     Test two strings. More...
     
    logical function w3ai24 (string1, string2, length)
     Test two strings.
     

    Detailed Description

    Test for match of two strings.

    @@ -107,8 +113,8 @@

    Definition in file w3ai24.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai24()

    + +

    ◆ w3ai24()

    @@ -117,19 +123,19 @@

    logical function w3ai24 ( character*1, dimension(*)  - STRING1, + string1, character*1, dimension(*)  - STRING2, + string2, integer*4  - LENGTH  + length  @@ -166,7 +172,7 @@

    diff --git a/w3ai24_8f.js b/w3ai24_8f.js index cdb47d76..75cf9354 100644 --- a/w3ai24_8f.js +++ b/w3ai24_8f.js @@ -1,4 +1,4 @@ var w3ai24_8f = [ - [ "w3ai24", "w3ai24_8f.html#a425d9890956ae872557a04b715deb3f2", null ] + [ "w3ai24", "w3ai24_8f.html#a2468984a80b3966028f29391a091a5f2", null ] ]; \ No newline at end of file diff --git a/w3ai24_8f_source.html b/w3ai24_8f_source.html index 54f79b1e..343d6cf7 100644 --- a/w3ai24_8f_source.html +++ b/w3ai24_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai24.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,59 +81,67 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ai24.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Test for match of two strings.
    +
    3C> @author Luke Lin @date 1994-08-31
    +
    4
    +
    5C> Test two strings. If all equal; Otherwise .false.
    +
    6C>
    +
    7C> Program history log:
    +
    8C> - Luke Lin 1994-08-31
    +
    9C>
    +
    10C> @param[in] STRING1 Character array to match with string2
    +
    11C> @param[in] STRING2 Character array to match with string1
    +
    12C> @param[in] LENGTH Integer length of string1 and string2
    +
    13C> @return W3AI24 Logical .true. if s1 and s2 match on all char.,
    +
    14C> logical .false. if not match on any char.
    +
    15C>
    +
    16C> @author Luke Lin @date 1994-08-31
    +
    +
    17 LOGICAL FUNCTION w3ai24(STRING1, STRING2,LENGTH)
    +
    18C
    +
    19 CHARACTER*1 string1(*)
    +
    20 CHARACTER*1 string2(*)
    +
    21 INTEGER*4 length
    +
    22C
    +
    23 w3ai24 = .true.
    +
    24C
    +
    25 DO 10 i = 1,length
    +
    26 IF (string1(i).NE.string2(i)) GO TO 40
    +
    27 10 CONTINUE
    +
    28C
    +
    29 RETURN
    +
    30C
    +
    31 40 CONTINUE
    +
    32 w3ai24 = .false.
    +
    33 RETURN
    +
    34C
    +
    +
    35 END
    +
    w3ai24
    logical function w3ai24(string1, string2, length)
    Test two strings.
    Definition w3ai24.f:18
    diff --git a/w3ai38_8f.html b/w3ai38_8f.html index 49dbf438..3e2720b5 100644 --- a/w3ai38_8f.html +++ b/w3ai38_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai38.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai38.f File Reference
    +
    w3ai38.f File Reference
    @@ -94,11 +100,11 @@

    Go to the source code of this file.

    - - - - + + +

    +

    Functions/Subroutines

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

    Detailed Description

    EBCDIC to ASCII.

    @@ -107,8 +113,8 @@

    Definition in file w3ai38.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai38()

    + +

    ◆ w3ai38()

    @@ -117,13 +123,13 @@

    subroutine w3ai38 ( character*1, dimension(*)  - IE, + ie,   - NC  + nc  @@ -164,7 +170,7 @@

    diff --git a/w3ai38_8f.js b/w3ai38_8f.js index ee2ec90e..565a553f 100644 --- a/w3ai38_8f.js +++ b/w3ai38_8f.js @@ -1,4 +1,4 @@ var w3ai38_8f = [ - [ "w3ai38", "w3ai38_8f.html#a65ce63976c2011a17a8f44e0d20e074f", null ] + [ "w3ai38", "w3ai38_8f.html#a8c31fa8b048696a5616b55d753eaa193", null ] ]; \ No newline at end of file diff --git a/w3ai38_8f_source.html b/w3ai38_8f_source.html index 01c83bf0..235a08f5 100644 --- a/w3ai38_8f_source.html +++ b/w3ai38_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai38.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,99 +81,107 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ai38.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief EBCDIC to ASCII
    +
    3C> @author Armand Desmarais @date 1982-11-29
    +
    4
    +
    5C> Convert EBCDIC to ASCII by character.
    +
    6C> This subroutine can be replaced by cray utility subroutine
    +
    7C> uscctc. See manual sr-2079 page 3-15. cray utility tr
    +
    8C> can also be used for ASCII, EBCDIC conversion. See manual sr-2079
    +
    9C> page 9-35.
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - Armand Desmarais 1982-11-29
    +
    13C> - Ralph Jones 1988-03-31 Change logic so it works like a
    +
    14C> ibm370 translate instruction.
    +
    15C> - Ralph Jones 1988-08-22 Changes for microsoft fortran 4.10.
    +
    16C> - Ralph Jones 1988-09-04 Change tables to 128 character set.
    +
    17C> - Ralph Jones 1990-01-31 Convert to cray cft77 fortran
    +
    18C> cray does not allow char*1 to be set to hex.
    +
    19C> - Stephen Gilbert 98-12-21 Replaced Function ICHAR with mova2i.
    +
    20C>
    +
    21C> @param[inout] IE (in) Character*1 array of EBCDIC data (out) ASCII data
    +
    22C> @param[in] NC Integer, contains character count to convert.
    +
    23C>
    +
    24C> @note Software version of ibm370 translate instruction, by
    +
    25C> changing the two tables we could do a 64, 96, 128 ASCII
    +
    26C> character set, change lower case to upper, etc.
    +
    27C> aea converts data at a rate of 1.5 million characters per sec.
    +
    28C> cray utility usccti convert ASCII to IBM EBCDIC
    +
    29C> cray utility uscctc convert IBM EBCDIC to ASCII
    +
    30C> they convert data at a rate of 2.1 million characters per sec.
    +
    31C> cray utility tr will also do a ASCII, EBCDIC conversion.
    +
    32C> tr convert data at a rate of 5.4 million characters per sec.
    +
    33C> tr is in library /usr/lib/libcos.a add to segldr card.
    +
    34C>
    +
    35C> @author Armand Desmarais @date 1982-11-29
    +
    +
    36 SUBROUTINE w3ai38 (IE, NC )
    +
    37C
    +
    38 INTEGER(8) IASCII(32)
    +
    39C
    +
    40 CHARACTER*1 IE(*)
    +
    41 CHARACTER*1 ASCII(0:255)
    +
    42C
    +
    43 equivalence(iascii(1),ascii(0))
    +
    44C
    +
    45C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029
    +
    46C
    +
    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'/
    +
    64C
    +
    65 IF (nc .LE. 0) RETURN
    +
    66C
    +
    67C*** CONVERT STRING ... EBCDIC TO ASCII, NC CHARACTERS
    +
    68C
    +
    69 DO 20 j = 1, nc
    +
    70 ie(j) = ascii(mova2i(ie(j)))
    +
    71 20 CONTINUE
    +
    72C
    +
    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/w3ai39_8f.html b/w3ai39_8f.html index 68a8ef6e..44b6f929 100644 --- a/w3ai39_8f.html +++ b/w3ai39_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ai39.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai39.f File Reference
    +
    w3ai39.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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).
     

    Detailed Description

    Translate 'ASCII' field to 'EBCDIC'.

    @@ -107,8 +113,8 @@

    Definition in file w3ai39.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai39()

    + +

    ◆ w3ai39()

    @@ -117,13 +123,13 @@

    subroutine w3ai39 ( character*1, dimension(*)  - NFLD, + nfld,   - N  + n  @@ -161,7 +167,7 @@

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

    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...
     
    subroutine w3ai40 (kfld, kout, klen, knum, koff)
     Packs constant size binary strings into an array.
     

    Detailed Description

    Constant size binary string packer.

    @@ -107,8 +113,8 @@

    Definition in file w3ai40.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai40()

    + +

    ◆ w3ai40()

    @@ -117,31 +123,31 @@

    subroutine w3ai40 ( integer, dimension(*)  - KFLD, + kfld, integer, dimension(*)  - KOUT, + kout,   - KLEN, + klen,   - KNUM, + knum,   - KOFF  + koff  @@ -185,7 +191,7 @@

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

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ai41.f File Reference
    +
    w3ai41.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Constant size binary string unpacker.

    @@ -107,8 +113,8 @@

    Definition in file w3ai41.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ai41()

    + +

    ◆ w3ai41()

    @@ -117,31 +123,31 @@

    subroutine w3ai41 ( integer, dimension(*)  - KFLD, + kfld, integer, dimension(*)  - KOUT, + kout,   - KLEN, + klen,   - KNUM, + knum,   - KOFF  + koff  @@ -171,7 +177,7 @@

    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.
    +
    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
    @@ -185,7 +191,7 @@

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

    Go to the source code of this file.

    - - - + +

    +

    Functions/Subroutines

    subroutine w3aq15 (ITIME, QDESCR)
     
    subroutine w3aq15 (itime, qdescr)
     

    Detailed Description

    GMT time packer.

    @@ -106,8 +112,8 @@

    Definition in file w3aq15.f.

    Function/Subroutine Documentation

    - -

    ◆ w3aq15()

    + +

    ◆ w3aq15()

    @@ -116,13 +122,13 @@

    subroutine w3aq15 ( integer  - ITIME, + itime, character * 80  - QDESCR  + qdescr  @@ -158,7 +164,7 @@

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

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3as00.f File Reference
    +
    w3as00.f File Reference
    @@ -94,16 +100,14 @@

    Go to the source code of this file.

    - - + - + - - + +

    +

    Functions/Subroutines

    -integer function lastch (str)
    integer function lastch (str)
     
    -integer function notrail (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...
    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.
     

    Detailed Description

    @@ -113,8 +117,48 @@

    Definition in file w3as00.f.

    Function/Subroutine Documentation

    - -

    ◆ w3as00()

    + +

    ◆ lastch()

    + +
    +
    + + + + + + + + +
    integer function lastch (character*(*) str)
    +
    + +

    Definition at line 208 of file w3as00.f.

    + +
    +
    + +

    ◆ notrail()

    + +
    +
    + + + + + + + + +
    integer function notrail (character*(*) str)
    +
    + +

    Definition at line 237 of file w3as00.f.

    + +
    +
    + +

    ◆ w3as00()

    @@ -190,7 +234,7 @@

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

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ctzdat.f File Reference
    +
    w3ctzdat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    subroutine w3ctzdat (ntz, idat, jdat)
     THis subprogram converts an ncep absolute date and time to another time zone.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3ctzdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ctzdat()

    + +

    ◆ w3ctzdat()

    @@ -164,7 +170,7 @@

    diff --git a/w3ctzdat_8f_source.html b/w3ctzdat_8f_source.html index 32b0f4ac..5f56fe30 100644 --- a/w3ctzdat_8f_source.html +++ b/w3ctzdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ctzdat.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,57 +81,65 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ctzdat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    w3ctzdat
    subroutine w3ctzdat(ntz, idat, jdat)
    THis subprogram converts an ncep absolute date and time to another time zone.
    Definition: w3ctzdat.f:21
    -
    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
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    w3ctzdat
    subroutine w3ctzdat(ntz, idat, jdat)
    THis subprogram converts an ncep absolute date and time to another time zone.
    Definition w3ctzdat.f:21
    +
    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
    diff --git a/w3difdat_8f.html b/w3difdat_8f.html index 73124d91..5cdc8057 100644 --- a/w3difdat_8f.html +++ b/w3difdat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3difdat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3difdat.f File Reference
    +
    w3difdat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    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.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3difdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3difdat()

    + +

    ◆ w3difdat()

    @@ -172,7 +178,7 @@

    diff --git a/w3difdat_8f_source.html b/w3difdat_8f_source.html index 722af76c..be59d196 100644 --- a/w3difdat_8f_source.html +++ b/w3difdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3difdat.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,39 +81,47 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3difdat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    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
    -
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    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
    +
    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/w3doxdat_8f.html b/w3doxdat_8f.html index 4c39e86e..cd7db4ed 100644 --- a/w3doxdat_8f.html +++ b/w3doxdat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3doxdat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3doxdat.f File Reference
    +
    w3doxdat.f File Reference
    @@ -94,10 +100,10 @@

    Go to the source code of this file.

    - - - + +

    +

    Functions/Subroutines

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

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3doxdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3doxdat()

    + +

    ◆ w3doxdat()

    @@ -171,7 +177,7 @@

    diff --git a/w3doxdat_8f_source.html b/w3doxdat_8f_source.html index b7e06780..7a113fd8 100644 --- a/w3doxdat_8f_source.html +++ b/w3doxdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3doxdat.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,34 +81,42 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3doxdat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    w3doxdat
    subroutine w3doxdat(idat, jdow, jdoy, jday)
    Program history log:
    Definition: w3doxdat.f:17
    -
    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
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    w3doxdat
    subroutine w3doxdat(idat, jdow, jdoy, jday)
    Program history log:
    Definition w3doxdat.f:17
    +
    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/w3fa01_8f.html b/w3fa01_8f.html index 8555f270..fe6c6266 100644 --- a/w3fa01_8f.html +++ b/w3fa01_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa01.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa01.f File Reference
    +
    w3fa01.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Compute lifting condendsation level.

    @@ -107,8 +113,8 @@

    Definition in file w3fa01.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa01()

    + +

    ◆ w3fa01()

    @@ -117,37 +123,37 @@

    subroutine w3fa01 (   - P, + p,   - T, + t,   - RH, + rh,   - TD, + td,   - PLCL, + plcl,   - TLCL  + tlcl  @@ -190,7 +196,7 @@

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

    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...
     
    subroutine w3fa03 (press, height, temp, theta)
     Computes the standard height, temperature, and potential temperature given the pressure in millibars ( > 8.68 mb ).
     

    Detailed Description

    Compute standard height, temp, and pot temp.

    @@ -107,8 +113,8 @@

    Definition in file w3fa03.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa03()

    + +

    ◆ w3fa03()

    @@ -117,25 +123,25 @@

    subroutine w3fa03 (   - PRESS, + press,   - HEIGHT, + height,   - TEMP, + temp,   - THETA  + theta  @@ -175,7 +181,7 @@

    diff --git a/w3fa03_8f.js b/w3fa03_8f.js index 98353cbe..8958d562 100644 --- a/w3fa03_8f.js +++ b/w3fa03_8f.js @@ -1,4 +1,4 @@ var w3fa03_8f = [ - [ "w3fa03", "w3fa03_8f.html#a682b3b6383a8cf898b6f57ce304501e3", null ] + [ "w3fa03", "w3fa03_8f.html#a7805169d794ed38e57ba685e6241100b", null ] ]; \ No newline at end of file diff --git a/w3fa03_8f_source.html b/w3fa03_8f_source.html index eb7bf252..ea9002b5 100644 --- a/w3fa03_8f_source.html +++ b/w3fa03_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa03.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,92 +81,100 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa03.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Compute standard height, temp, and pot temp.
    +
    3C> @author James McDonell @date 1974-06-01
    +
    4
    +
    5C> Computes the standard height, temperature, and potential
    +
    6C> temperature given the pressure in millibars ( > 8.68 mb ). For
    +
    7C> height and temperature the results duplicate the values in the
    +
    8C> U.S. standard atmosphere (l962), which is the icao standard
    +
    9C> atmosphere to 54.7487 mb (20 km) and the proposed extension to
    +
    10C> 8.68 mb (32 km). For potential temperature a value of 2/7 is
    +
    11C> used for rd/cp.
    +
    12C>
    +
    13C> Program history log:
    +
    14C> - James McDonell 1974-06-01
    +
    15C> - Ralph Jones 1984-06-01 Change to ibm vs fortran.
    +
    16C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    17C>
    +
    18C> @param[in] PRESS Pressure in millibars.
    +
    19C> @param[out] HEIGHT Height in meters.
    +
    20C> @param[out] TEMP Temperature in degrees kelvin.
    +
    21C> @param[out] THETA Potential temperature in degrees kelvin.
    +
    22C>
    +
    23C> @note Not valid for pressures less than 8.68 millibars, declare
    +
    24C> all parameters as type real.
    +
    25C>
    +
    26C> @author James McDonell @date 1974-06-01
    +
    +
    27 SUBROUTINE w3fa03(PRESS,HEIGHT,TEMP,THETA)
    +
    28C
    +
    29 REAL M0
    +
    30C
    +
    31 SAVE
    +
    32C
    +
    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/
    +
    36C
    +
    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
    +
    45C
    +
    46C COMPUTE ISOTHERMAL CASES
    +
    47C
    +
    48 height = 11000.0 + (fkt * alog(ptrop/press))
    +
    49 temp = tstr
    +
    50 GO TO 300
    +
    51C
    +
    52C COMPUTE LAPSE RATE = -.0010 CASES
    +
    53C
    +
    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
    +
    60C
    +
    61 200 CONTINUE
    +
    62 height = (t0/(pp0 * alp)) * (pp0 - (press ** ar))
    +
    63 temp = t0 - (height * alp)
    +
    64C
    +
    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/w3fa03v_8f.html b/w3fa03v_8f.html index e84dc5ec..164afb90 100644 --- a/w3fa03v_8f.html +++ b/w3fa03v_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa03v.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa03v.f File Reference
    +
    w3fa03v.f File Reference
    @@ -94,17 +100,65 @@

    Go to the source code of this file.

    - - - + + +

    +

    Functions/Subroutines

    -subroutine w3fa03v (PRESS, HEIGHT, TEMP, THETA, N)
     
    subroutine w3fa03v (press, height, temp, theta, n)
     Computes the standard height, temperature, and potential temperature given the pressure in millibars (>8.68 mb).
     

    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.

    +
    Date
    1974-06-01
    + +

    Definition in file w3fa03v.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa03v()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fa03v (real, dimension(*) press,
    real, dimension(*) height,
    real, dimension(*) temp,
    real, dimension(*) theta,
     n 
    )
    +
    + +

    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.
      • @@ -127,14 +181,17 @@
      Author
      James McDonell
      Date
      1974-06-01
      -

      Definition in file w3fa03v.f.

      -
    +

    Definition at line 32 of file w3fa03v.f.

    + +
    +
    +
    diff --git a/w3fa03v_8f.js b/w3fa03v_8f.js index caaa28c8..87d0bdf4 100644 --- a/w3fa03v_8f.js +++ b/w3fa03v_8f.js @@ -1,4 +1,4 @@ var w3fa03v_8f = [ - [ "w3fa03v", "w3fa03v_8f.html#a0e7dfe3a41d6a2022f45cadb7c78231c", null ] + [ "w3fa03v", "w3fa03v_8f.html#a1d2407e31446d6ad82bd4e2cb61fd5d7", null ] ]; \ No newline at end of file diff --git a/w3fa03v_8f_source.html b/w3fa03v_8f_source.html index d73ce231..68cecc5f 100644 --- a/w3fa03v_8f_source.html +++ b/w3fa03v_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa03v.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,104 +81,113 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa03v.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Compute standard height, temp, and pot temp.
    +
    3C> @author James McDonell @date 1974-06-01
    +
    4
    +
    5C> Computes the standard height, temperature, and potential
    +
    6C> temperature given the pressure in millibars (>8.68 mb). For
    +
    7C> height and temperature the results duplicate the values in the
    +
    8C> U.S. standard atmosphere (l962), which is the icao standard
    +
    9C> atmosphere to 54.7487 mb (20 km) and the proposed extension to
    +
    10C> 8.68 mb (32 km). For potential temperature a value of 2/7 is
    +
    11C> used for rd/cp.
    +
    12C>
    +
    13C> Program history log:
    +
    14C> - James McDonell 1974-06-01
    +
    15C> - Ralph Jones 1984-06-01 Change to ibm vs fortran.
    +
    16C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    17C> - Ralph Jones 1994-09-13 Vectorized version to do array instead of one word.
    +
    18C>
    +
    19C> @param[in] PRESS Pressure array in millibars.
    +
    20C> @param[out] HEIGHT Height array in meters.
    +
    21C> @param[out] TEMP Temperature array in degrees kelvin.
    +
    22C> @param[out] THETA Potential temperature array in degrees kelvin.
    +
    23C> @param[out] N Number of points in array press.
    +
    24C>
    +
    25C> @note Not valid for pressures less than 8.68 millibars, declare
    +
    26C> all parameters as type real.
    +
    27C>
    +
    28C> @note Height, temp, theta are now all arrays, you must
    +
    29C> have arrays of size n or you will wipe out memory.
    +
    30C>
    +
    31C> @author James McDonell @date 1974-06-01
    +
    +
    32 SUBROUTINE w3fa03v(PRESS,HEIGHT,TEMP,THETA,N)
    +
    33C
    +
    34 REAL M0
    +
    35 REAL HEIGHT(*)
    +
    36 REAL PRESS(*)
    +
    37 REAL TEMP(*)
    +
    38 REAL THETA(*)
    +
    39C
    +
    40 SAVE
    +
    41C
    +
    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/
    +
    45C
    +
    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
    +
    54C
    +
    55 DO j = 1,n
    +
    56 IF (press(j).LT.piso) THEN
    +
    57C
    +
    58C COMPUTE LAPSE RATE = -.0010 CASES
    +
    59C
    +
    60 height(j) = ((tstr/(pp01 * salp )) * (pp01-(press(j) ** ar1)))
    +
    61 & + ziso
    +
    62 temp(j) = tstr - ((height(j) - ziso) * salp)
    +
    63C
    +
    64 ELSE IF (press(j).GT.ptrop) THEN
    +
    65C
    +
    66 height(j) = (t0/(pp0 * alp)) * (pp0 - (press(j) ** ar))
    +
    67 temp(j) = t0 - (height(j) * alp)
    +
    68C
    +
    69 ELSE
    +
    70C
    +
    71C COMPUTE ISOTHERMAL CASES
    +
    72C
    +
    73 height(j) = 11000.0 + (fkt * alog(ptrop/press(j)))
    +
    74 temp(j) = tstr
    +
    75C
    +
    76 END IF
    +
    77 theta(j) = temp(j) * ((1000./press(j))**rovcp)
    +
    78 END DO
    +
    79C
    +
    80 RETURN
    +
    +
    81 END
    +
    w3fa03v
    subroutine w3fa03v(press, height, temp, theta, n)
    Computes the standard height, temperature, and potential temperature given the pressure in millibars ...
    Definition w3fa03v.f:33
    diff --git a/w3fa04_8f.html b/w3fa04_8f.html index 72756408..15f5edb4 100644 --- a/w3fa04_8f.html +++ b/w3fa04_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa04.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa04.f File Reference
    +
    w3fa04.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fa04 (height, press, temp, theta)
     Computes the standard pressure, temperature, and poten- tial temperature given the height in meters (<32 km).
     

    Detailed Description

    Compute standard pressure, temp, pot temp.

    @@ -107,8 +113,8 @@

    Definition in file w3fa04.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa04()

    + +

    ◆ w3fa04()

    @@ -117,25 +123,25 @@

    subroutine w3fa04 (   - HEIGHT, + height,   - PRESS, + press,   - TEMP, + temp,   - THETA  + theta  @@ -175,7 +181,7 @@

    diff --git a/w3fa04_8f.js b/w3fa04_8f.js index b7c6d893..67483219 100644 --- a/w3fa04_8f.js +++ b/w3fa04_8f.js @@ -1,4 +1,4 @@ var w3fa04_8f = [ - [ "w3fa04", "w3fa04_8f.html#a5f4b61c8c65ffd2662ca4918d08c8fc6", null ] + [ "w3fa04", "w3fa04_8f.html#a4a761802c7bab00ea502026e7863696a", null ] ]; \ No newline at end of file diff --git a/w3fa04_8f_source.html b/w3fa04_8f_source.html index 04076e5b..cd857ebd 100644 --- a/w3fa04_8f_source.html +++ b/w3fa04_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa04.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,98 +81,106 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa04.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Compute standard pressure, temp, pot temp.
    +
    3C> @author James McDonell @date 1974-06-01
    +
    4
    +
    5C> Computes the standard pressure, temperature, and poten-
    +
    6C> tial temperature given the height in meters (<32 km). For
    +
    7C> the pressure and temperature the results duplicate the values in
    +
    8C> the U.S. standard atmosphere (1962), which is the icao standard
    +
    9C> atmosphere to 54.7487 mb (20 km) and the proposed extension to
    +
    10C> 8.68 mb (32 km). For potential temperature a value of 2/7 is
    +
    11C> used for rd/cp.
    +
    12C>
    +
    13C> Program history log:
    +
    14C> - James McDonell 1974-06-01
    +
    15C> - Ralph Jones 1984-07-05 Change to ibm vs fortran.
    +
    16C> - Ralph Jones 1990-04-27 Change to cray cft77 fortran.
    +
    17C>
    +
    18C> @param[in] HEIGHT Height in meters.
    +
    19C> @param[out] PRESS Standard pressure in millibars.
    +
    20C> @param[out] TEMP Temperature in degrees kelvin.
    +
    21C> @param[out] THETA Potential temperature in degrees kelvin.
    +
    22C>
    +
    23C> @note Not valid for heights greater than 32 km. declare all parameters
    +
    24C> as type real*4.
    +
    25C>
    +
    26C> @author James McDonell @date 1974-06-01
    +
    27
    +
    +
    28 SUBROUTINE w3fa04(HEIGHT,PRESS,TEMP,THETA)
    +
    29C
    +
    30 REAL M0
    +
    31C
    +
    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/
    +
    44C
    +
    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
    +
    49C
    +
    50C COMPUTE IN TROPOSPHERE
    +
    51C
    +
    52 temp = t0 - height * alp
    +
    53 press = pzero * ((1.0 - ((alp/t0) * height)) ** (g/(alp * r)))
    +
    54 GO TO 300
    +
    55C
    +
    56C COMPUTE LAPSE RATE = -.0010 CASES
    +
    57C
    +
    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
    +
    63C
    +
    64C COMPUTE ISOTHERMAL CASES
    +
    65C
    +
    66 200 CONTINUE
    +
    67 d = exp((height - 11000.0) / ((r / g) * tstr))
    +
    68 press = ptrop / d
    +
    69 temp = tstr
    +
    70C
    +
    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/w3fa06_8f.html b/w3fa06_8f.html index 9430fce0..55b964dc 100644 --- a/w3fa06_8f.html +++ b/w3fa06_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa06.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa06.f File Reference
    +
    w3fa06.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Calculation of the lifted index.

    @@ -107,8 +113,8 @@

    Definition in file w3fa06.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa06()

    + +

    ◆ w3fa06()

    @@ -117,31 +123,31 @@

    subroutine w3fa06 (   - P, + p,   - T, + t,   - RH, + rh,   - T5, + t5,   - TLI  + tli  @@ -184,7 +190,7 @@

    diff --git a/w3fa06_8f.js b/w3fa06_8f.js index 03474762..e390695e 100644 --- a/w3fa06_8f.js +++ b/w3fa06_8f.js @@ -1,4 +1,4 @@ var w3fa06_8f = [ - [ "w3fa06", "w3fa06_8f.html#a232d431173943399677b1eb13275bb05", null ] + [ "w3fa06", "w3fa06_8f.html#aa82de1d1f83eb4bb981a5d00b3af13d9", null ] ]; \ No newline at end of file diff --git a/w3fa06_8f_source.html b/w3fa06_8f_source.html index 0201aded..06cde713 100644 --- a/w3fa06_8f_source.html +++ b/w3fa06_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa06.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,130 +81,138 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa06.f
    +
    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
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Calculation of the lifted index.
    +
    3C> @author James Howcroft @date 1978-07-01
    +
    4
    +
    5C> Given the pressure,temperature and relative humidity of
    +
    6C> an air parcel at some point in the atmosphere, calculate the
    +
    7C> lifted index of the parcel. Lifted index is defined as the
    +
    8C> temperature difference between the observed 500mb temperature and
    +
    9C> the supposed temperature that the parcel would obtain if it were
    +
    10C> lifted dry-adiabatically to saturation and then moved moist
    +
    11C> adiabatically to the 500mb level.
    +
    12C>
    +
    13C> Program history log:
    +
    14C> - James Howcroft 1978-07-01
    +
    15C> - Ralph Jones 1989-01-24 Change to microsoft fortran 4.10.
    +
    16C> - Ralph Jones 1990-06-08 Change to sun fortran 1.3.
    +
    17C> - Ralph Jones 1991-03-29 Convert to silicongraphics fortran.
    +
    18C> - Ralph Jones 1993-03-29 Add save statement.
    +
    19C> - Ralph Jones 1995-09-25 Put in w3 library on cray.
    +
    20C>
    +
    21C> @param[in] P Parcel pressure in millibars.
    +
    22C> @param[in] T Parcel temperataure in degrees celsius.
    +
    23C> @param[in] RH Parcel relative humidity in percent.
    +
    24C> @param[in] T5 Temperature at the 500mb level in deg. celsius.
    +
    25C> @param[out] TLI Lifted index in degrees celsius
    +
    26C> tli = 9.9999 iteration diverges; return to user program.
    +
    27C>
    +
    28C> @author James Howcroft @date 1978-07-01
    +
    +
    29 SUBROUTINE w3fa06 (P,T,RH,T5,TLI)
    +
    30C
    +
    31 SAVE
    +
    32C
    +
    33 DATA eps /0.5/
    +
    34 DATA kout / 6/
    +
    35C
    +
    36 300 FORMAT (' *** ITERATION NOT CONVERGING IN W3FA06 ***')
    +
    37 350 FORMAT (' INPUT PARAMS ARE:',4f15.8,/
    +
    38 1 ' CALCULATIONS ARE',7e15.8)
    +
    39C
    +
    40 potemp(t,p) = (t+273.16)*((1000./p)**0.2857)
    +
    41C
    +
    42 eep(t,p,es) = exp((596.73-0.601*t)*((0.622*es)/(p-es))
    +
    43 1 / (0.24*(t+273.16)))
    +
    44C
    +
    45 unpot(te,p) = (((p/1000.)**0.2857)*te)-273.16
    +
    46C
    +
    47 vapres(t) = 6.11*exp(17.2694*t/(t+237.3))
    +
    48C
    +
    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
    +
    55C LCL IS ABOVE THE 500MB LVL
    +
    56 tli = t5 - unpot((potemp(tlcl,plcl)),500.)
    +
    57 GO TO 80
    +
    58 30 CONTINUE
    +
    59C USE STACKPOLE ALGORITHM (JAM VOL 6/1967 PP 464-7) TO FIND TGES
    +
    60C 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)
    +
    64C THETA IS THE PSEUDO-EQUIV POTENTIAL TEMP THRU (PLCL,TLCL).
    +
    65C NOW FIND TEMP WHERE THETA INTERSECTS 500MB SFC.
    +
    66C INITIALIZE FOR STACKPOLIAN ITERATION
    +
    67 tges = t5
    +
    68 dtt = 10.
    +
    69 piin = 1./(0.5**0.2857)
    +
    70 a = 0.
    +
    71 istp = 0
    +
    72C 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
    +
    86C 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
    +
    92C
    +
    93 50 CONTINUE
    +
    94C 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
    +
    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
    +
    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
    diff --git a/w3fa09_8f.html b/w3fa09_8f.html index 1ac07fae..56f8e994 100644 --- a/w3fa09_8f.html +++ b/w3fa09_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa09.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa09.f File Reference
    +
    w3fa09.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    real function w3fa09 (tk)
     Computes saturation vapor pressure in kilopascals given temperataure in kelvins.
     

    Detailed Description

    Temperature to saturation vapor pressure.

    @@ -107,8 +113,8 @@

    Definition in file w3fa09.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa09()

    + +

    ◆ w3fa09()

    @@ -117,7 +123,7 @@

    real function w3fa09 (   - TK) + tk) @@ -154,7 +160,7 @@

    diff --git a/w3fa09_8f.js b/w3fa09_8f.js index 2583a382..f79a09e2 100644 --- a/w3fa09_8f.js +++ b/w3fa09_8f.js @@ -1,4 +1,4 @@ var w3fa09_8f = [ - [ "w3fa09", "w3fa09_8f.html#a97cb87ce42a1cba4c96dd80fefb9eafe", null ] + [ "w3fa09", "w3fa09_8f.html#ad48026b7570d6ac92635a6719c9ef7fc", null ] ]; \ No newline at end of file diff --git a/w3fa09_8f_source.html b/w3fa09_8f_source.html index b85351b6..8a2eb921 100644 --- a/w3fa09_8f_source.html +++ b/w3fa09_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa09.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,79 +81,87 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa09.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Temperature to saturation vapor pressure.
    +
    3C> @author P. Chase @date 1978-10-01
    +
    4
    +
    5C> Computes saturation vapor pressure in kilopascals given temperataure in kelvins.
    +
    6C>
    +
    7C> Program history log:
    +
    8C> - P. Chase 1978-10-01 P.CHASE
    +
    9C> - Ralph Jones 1984-06-26 Change to ibm vs fortran.
    +
    10C> - Ralph Jones 1984-06-26 Change to microsoft fortran 4.10.
    +
    11C> - Ralph Jones 1990-06-08 Change to sun fortran 1.3.
    +
    12C> - Ralph Jones 1991-03-29 Convert to silicongraphic fortran.
    +
    13C> - Ralph Jones 1993-03-29 Add save statement.
    +
    14C> - Ralph Jones 1995-09-25 Change tk to cray 64 bit real, change double.
    +
    15C> precision to cray 64 bit real.
    +
    16C>
    +
    17C> @param[in] TK REAL*8 Temperature in kelvins. if tk < 223.16, the value
    +
    18C> 223.16 will be used. if tk > 323.16, the value 323.16
    +
    19C> will be used as the argument. 'tk' itself is unchanged.
    +
    20C> @return VP Saturation vapor pressure in kilopascals 0.0063558 < VP < 12.3395.
    +
    21C>
    +
    22C> @note W3FA09 may be declared real*8 so that a real*8 value is
    +
    23C> returned, but no increase in accuracy is implied.
    +
    24C>
    +
    25C> @author P. Chase @date 1978-10-01
    +
    +
    26 REAL function w3fa09 (tk)
    +
    27C
    +
    28C THE CHEBYSHEV COEFFICIENTS ARE IN ARRAY C, LOW-ORDER TERM FIRST.
    +
    29C
    +
    30 REAL c(9)
    +
    31 REAL arg,h0,h1,h2
    +
    32C
    +
    33 SAVE
    +
    34C
    +
    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/
    +
    39C
    +
    40C SCALE TK TO RANGE -2, +2 FOR SERIES EVALUATION. INITIALIZE TERMS.
    +
    41C
    +
    42 arg = -1.09264e1+4.0e-2*amax1(223.16,amin1(323.16,tk))
    +
    43 h0 = 0.0
    +
    44 h1 = 0.0
    +
    45C
    +
    46C EVALUATE CHEBYSHEV POLYNOMIAL
    +
    47C
    +
    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/w3fa11_8f.html b/w3fa11_8f.html index 4c6cd8c6..4a0195a0 100644 --- a/w3fa11_8f.html +++ b/w3fa11_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa11.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa11.f File Reference
    +
    w3fa11.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fa11 (eps, jcap)
     Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
     

    Detailed Description

    Computes coefficients for use in w3fa12.

    @@ -107,8 +113,8 @@

    Definition in file w3fa11.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa11()

    + +

    ◆ w3fa11()

    @@ -117,13 +123,13 @@

    subroutine w3fa11 ( real, dimension(*)  - EPS, + eps,   - JCAP  + jcap  @@ -160,7 +166,7 @@

    diff --git a/w3fa11_8f.js b/w3fa11_8f.js index dfa3bbed..5a70f888 100644 --- a/w3fa11_8f.js +++ b/w3fa11_8f.js @@ -1,4 +1,4 @@ var w3fa11_8f = [ - [ "w3fa11", "w3fa11_8f.html#ad62a05c9654e2a4aa35667a814dee8a2", null ] + [ "w3fa11", "w3fa11_8f.html#ac97049f63913eb3d3af50c42ea29e5c8", null ] ]; \ No newline at end of file diff --git a/w3fa11_8f_source.html b/w3fa11_8f_source.html index bb03d5ea..65aef131 100644 --- a/w3fa11_8f_source.html +++ b/w3fa11_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa11.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,70 +81,78 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa11.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes coefficients for use in w3fa12.
    +
    3C> @author Joe Sela @date 1980-10-28
    +
    4
    +
    5C> Subroutine computes double precision coefficients
    +
    6C> used in generating legendre polynomials in subr. w3fa12.
    +
    7C> on a cray double precision is changed to real, dsqrt to sqrt.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Joe Sela 1980-10-28
    +
    11C> - Ralph Jones 1984-06-01 0change to ibm vs fortran.
    +
    12C> - Ralph Jones 1993-04-12 0changes for cray, double precision to real.
    +
    13C>
    +
    14C> @param[out] EPS Real coefficients used in computing legendre polynomials.
    +
    15C> dimension of eps is (jcap+2)*(jcap+1)
    +
    16C> @param[in] JCAP Zonal wave number thirty, etc.
    +
    17C>
    +
    18C> @author Joe Sela @date 1980-10-28
    +
    19
    +
    +
    20 SUBROUTINE w3fa11 (EPS,JCAP)
    +
    21C
    +
    22 REAL EPS(*)
    +
    23 REAL A
    +
    24C
    +
    25 SAVE
    +
    26C
    +
    27 jcap1 = jcap + 1
    +
    28 jcap2 = jcap + 2
    +
    29C
    +
    30 DO 100 ll = 1,jcap1
    +
    31 l = ll - 1
    +
    32 jle = (ll-1) * jcap2
    +
    33C
    +
    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
    +
    39C
    +
    40 DO 200 ll = 1,jcap1
    +
    41 jle = (ll-1) * jcap2
    +
    42 eps(jle+1) = 0.0
    +
    43 200 CONTINUE
    +
    44C
    +
    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/w3fa12_8f.html b/w3fa12_8f.html index 5bae720d..734b6f1a 100644 --- a/w3fa12_8f.html +++ b/w3fa12_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa12.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa12.f File Reference
    +
    w3fa12.f File Reference
    @@ -94,17 +100,58 @@

    Go to the source code of this file.

    - - - + + +

    +

    Functions/Subroutines

    -subroutine w3fa12 (PLN, COLRAD, JCAP, EPS)
     
    subroutine w3fa12 (pln, colrad, jcap, eps)
     Subroutine computes legendre polynomials at a given latitude.
     

    Detailed Description

    Computes legendre polynomials at a given latitude.

    Author
    Joe Sela
    -
    Date
    1980-10-28
    -

    Subroutine computes legendre polynomials at a given latitude.

    +
    Date
    1980-10-28
    + +

    Definition in file w3fa12.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa12()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fa12 (real, dimension(*) pln,
    real colrad,
     jcap,
    real, dimension(*) eps 
    )
    +
    + +

    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.
      • @@ -122,14 +169,17 @@
      Author
      Joe Sela
      Date
      1980-10-28
      -

      Definition in file w3fa12.f.

      -
    +

    Definition at line 20 of file w3fa12.f.

    + +
    +
    +

    diff --git a/w3fa12_8f.js b/w3fa12_8f.js index bcb461b6..b0b06a3d 100644 --- a/w3fa12_8f.js +++ b/w3fa12_8f.js @@ -1,4 +1,4 @@ var w3fa12_8f = [ - [ "w3fa12", "w3fa12_8f.html#af8c0b914691cd0a708ca37b26be47c25", null ] + [ "w3fa12", "w3fa12_8f.html#a74541e2949ce81754b1e8a4a3e5d946f", null ] ]; \ No newline at end of file diff --git a/w3fa12_8f_source.html b/w3fa12_8f_source.html index eee328f3..848c364d 100644 --- a/w3fa12_8f_source.html +++ b/w3fa12_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa12.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,91 +81,100 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa12.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes legendre polynomials at a given latitude.
    +
    3C> @author Joe Sela @date 1980-10-28
    +
    4
    +
    5C> Subroutine computes legendre polynomials at a given latitude.
    +
    6C>
    +
    7C> Program history log:
    +
    8C> - Joe Sela 1980-10-20
    +
    9C> - Ralph Jones 1984-06-01 Change to ibm vs fortran.
    +
    10C> - Ralph Jones 1993-04-12 Changes for cray, double precision to real.
    +
    11C>
    +
    12C> @param[out] PLN Real locations contain legendre
    +
    13C> polynomials, size is (jcap+2)*(jcap+1)
    +
    14C> @param[in] COLRAD Colatitude in radians of desired point.
    +
    15C> @param[in] JCAP For rhomboiadal truncation of zonal wave
    +
    16C> @param[in] EPS Coeff. used in recursion equation.
    +
    17C> Dimension of eps is (jcap+2)*(jcap+1)
    +
    18C>
    +
    19C> @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(*)
    +
    33C
    +
    34 SAVE
    +
    35C
    +
    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
    +
    43C
    +
    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
    +
    57C
    +
    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
    +
    64200 CONTINUE
    +
    65300 CONTINUE
    +
    66 RETURN
    +
    67C
    +
    +
    68 END
    +
    w3fa12
    subroutine w3fa12(pln, colrad, jcap, eps)
    Subroutine computes legendre polynomials at a given latitude.
    Definition w3fa12.f:21
    diff --git a/w3fa13_8f.html b/w3fa13_8f.html index 8ab42e60..a3929842 100644 --- a/w3fa13_8f.html +++ b/w3fa13_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa13.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fa13.f File Reference
    +
    w3fa13.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fa13 (trigs, rcos)
     Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
     

    Detailed Description

    Computes Trig Functions.

    @@ -107,8 +113,8 @@

    Definition in file w3fa13.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fa13()

    + +

    ◆ w3fa13()

    @@ -117,13 +123,13 @@

    subroutine w3fa13 ( real, dimension(*)  - TRIGS, + trigs, real, dimension(*)  - RCOS  + rcos  @@ -134,15 +140,15 @@

    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().

    +

    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()
    [out]TRIGS216 trig values, used by subroutine w3fa12().
    [out]RCOS37 colatitudes used by subroutines w3ft09() ,w3ft11()
    @@ -159,7 +165,7 @@

    diff --git a/w3fa13_8f.js b/w3fa13_8f.js index 91be60aa..f369d153 100644 --- a/w3fa13_8f.js +++ b/w3fa13_8f.js @@ -1,4 +1,4 @@ var w3fa13_8f = [ - [ "w3fa13", "w3fa13_8f.html#ae3485639e68c6074ead756064096216a", null ] + [ "w3fa13", "w3fa13_8f.html#a79f0efdd8bbc53bd8c9bc9aa7ca41811", null ] ]; \ No newline at end of file diff --git a/w3fa13_8f_source.html b/w3fa13_8f_source.html index 1c9cdb27..57c2f2d4 100644 --- a/w3fa13_8f_source.html +++ b/w3fa13_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fa13.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,98 +81,106 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fa13.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes Trig Functions
    +
    3C> @author Joe Sela @date 1980-11-21
    +
    4
    +
    5C> Computes trig functions used in 2.5 by 2.5 lat,lon
    +
    6C> mapping routines. w3fa13() must be called at least once before
    +
    7C> calls to w3ft08(), w3ft09(), w3ft10(), w3ft11().
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Joe Sela 1980-11-21
    +
    11C> - Ralph Jones 1984-06-01 Change to vs fortran
    +
    12C>
    +
    13C> @param[out] TRIGS 216 trig values, used by subroutine w3fa12().
    +
    14C> @param[out] RCOS 37 colatitudes used by subroutines w3ft09() ,w3ft11()
    +
    15C>
    +
    16C> @author Joe Sela @date 1980-11-21
    +
    +
    17 SUBROUTINE w3fa13(TRIGS,RCOS)
    +
    18C
    +
    19 REAL RCOS(*)
    +
    20 REAL TRIGS(*)
    +
    21C
    +
    22 SAVE
    +
    23C
    +
    24 DATA pi /3.14159265358979323846/
    +
    25C
    +
    26 n = 144
    +
    27 mode = 3
    +
    28 drad = 2.5*pi/180.
    +
    29C
    +
    30 DO 100 lat = 2,37
    +
    31 arg = (lat-1)*drad
    +
    32 rcos(lat) = 1./sin(arg)
    +
    33 100 CONTINUE
    +
    34C
    +
    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
    +
    42C
    +
    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
    +
    48C
    +
    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
    +
    56C
    +
    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
    +
    62C
    +
    63 IF (imode.LE.3) RETURN
    +
    64 del = 0.5*del
    +
    65 angle = del
    +
    66 la = la+nn
    +
    67C
    +
    68 DO 400 i = 2,nn
    +
    69 trigs(la+i) = 2.0*sin(angle)
    +
    70 angle = angle+del
    +
    71 400 CONTINUE
    +
    72C
    +
    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/w3fb00_8f.html b/w3fb00_8f.html index 20e12087..1cf8a402 100644 --- a/w3fb00_8f.html +++ b/w3fb00_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb00.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb00.f File Reference
    +
    w3fb00.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Convert latitude, longitude to i,j.

    @@ -107,8 +113,8 @@

    Definition in file w3fb00.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb00()

    + +

    ◆ w3fb00()

    @@ -117,31 +123,31 @@

    subroutine w3fb00 (   - ALAT, + alat,   - ALONG, + along,   - XMESHL, + xmeshl,   - XI, + xi,   - XJ  + xj  @@ -152,7 +158,7 @@

    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().

    +

    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
      • @@ -181,7 +187,7 @@

    diff --git a/w3fb00_8f.js b/w3fb00_8f.js index fd074c56..d814fd50 100644 --- a/w3fb00_8f.js +++ b/w3fb00_8f.js @@ -1,4 +1,4 @@ var w3fb00_8f = [ - [ "w3fb00", "w3fb00_8f.html#a007817ca2f1dd94a58abdb00f54aab28", null ] + [ "w3fb00", "w3fb00_8f.html#a6581d211e674bcbe0b47b2d65e9aa671", null ] ]; \ No newline at end of file diff --git a/w3fb00_8f_source.html b/w3fb00_8f_source.html index 6e73d53b..e70a2b25 100644 --- a/w3fb00_8f_source.html +++ b/w3fb00_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb00.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,68 +81,76 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb00.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert latitude, longitude to i,j
    +
    3C> @author A. Heermann @date 1969-08-01
    +
    4
    +
    5C> Converts the coordinates of a location on earth from the
    +
    6C> natural coordinate system of latitude/longitude to the grid (i,j)
    +
    7C> coordinate system overlaid on the polar stereographic map pro-
    +
    8C> jection true at 60 n. a preferable, more flexible subroutine to
    +
    9C> use is w3fb04(). w3fb00() is the reverse of w3fb01().
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - A. Heermann 1969-08-01
    +
    13C> - Ralph Jones 1990-08-31 Convert to cray cft77 fortran
    +
    14C>
    +
    15C> @param[in] ALAT Latitude in deg. (-20.0 (s. hemis)) alat) 90.0).
    +
    16C> @param[in] ALONG West longitude in degrees.
    +
    17C> @param[in] XMESHL Mesh length of grid in kilometers at 60n.
    +
    18C> @param[out] XI I of the point relative to north pole.
    +
    19C> @param[out] XJ J of the point relative to north pole.
    +
    20C>
    +
    21C> @note The grid used in this subroutine has its origin (i=0,j=0)
    +
    22C> at the north pole, so if the user's grid has its origin at a
    +
    23C> point other than the north pole, a translation is required to
    +
    24C> get i and j. The subroutine grid is oriented so that longitude
    +
    25C> 80w is parallel to the gridlines of i=constant. The radius of
    +
    26C> the earth is taken to be 6371.2 km. All parameters in the call statement
    +
    27C> must be real this code will not vectorize on a cray. You will have put
    +
    28C> it line to vectorize it.
    +
    29C>
    +
    30C> @author A. Heermann @date 1969-08-01
    +
    +
    31 SUBROUTINE w3fb00(ALAT,ALONG,XMESHL,XI,XJ)
    +
    32C
    +
    33 DATA radpd /.01745329/
    +
    34 DATA earthr/6371.2/
    +
    35C
    +
    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/w3fb01_8f.html b/w3fb01_8f.html index 2eb32846..7fed1e88 100644 --- a/w3fb01_8f.html +++ b/w3fb01_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb01.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb01.f File Reference
    +
    w3fb01.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    I,J TO LATITUDE, LONGITUDE.

    @@ -107,8 +113,8 @@

    Definition in file w3fb01.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb01()

    + +

    ◆ w3fb01()

    @@ -117,31 +123,31 @@

    subroutine w3fb01 (   - XI, + xi,   - XJ, + xj,   - XMESHL, + xmeshl,   - ALAT, + alat,   - ALONG  + along  @@ -152,7 +158,7 @@

    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().

    +

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

    PROGRAM HISTORY LOG:

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

    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...
     
    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.
     

    Detailed Description

    COnvert s.

    @@ -107,8 +113,8 @@

    Definition in file w3fb02.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb02()

    + +

    ◆ w3fb02()

    @@ -117,31 +123,31 @@

    subroutine w3fb02 (   - ALAT, + alat,   - ALONG, + along,   - XMESHL, + xmeshl,   - XI, + xi,   - XJ  + xj  @@ -179,7 +185,7 @@

    diff --git a/w3fb02_8f.js b/w3fb02_8f.js index 016663bd..afb49486 100644 --- a/w3fb02_8f.js +++ b/w3fb02_8f.js @@ -1,4 +1,4 @@ var w3fb02_8f = [ - [ "w3fb02", "w3fb02_8f.html#a86b57ee57a85c801ccca67cc7e6ef2a9", null ] + [ "w3fb02", "w3fb02_8f.html#aac12d4245442631655101f5a4b27aee2", null ] ]; \ No newline at end of file diff --git a/w3fb02_8f_source.html b/w3fb02_8f_source.html index ddf4b113..5dda62bb 100644 --- a/w3fb02_8f_source.html +++ b/w3fb02_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb02.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,81 +81,89 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb02.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief COnvert s. hemisphere lat/lon to i and j.
    +
    3C> @author Ralph Jones @date 1985-09-13
    +
    4
    +
    5C> Computes i and j coordinates for a latitude/longitude
    +
    6C> point on the southern hemisphere polar stereographic map
    +
    7C> projection.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Ralph Jones 1985-09-13 Convert to fortran 77.
    +
    11C> - Ralph Jones 1990-08-31 Convert to cray cft77 fortran.
    +
    12C>
    +
    13C> @param[in] ALAT Real*4 latitude (s.h. latitudes are negative)
    +
    14C> @param[in] ALONG Real*4 west longitude.
    +
    15C> @param[in] XMESHL Real*4 grid interval in km.
    +
    16C> @param[out] XI Real*4 i coordinate.
    +
    17C> @param[out] XJ Real*4 j coordinate.
    +
    18C>
    +
    19C> @author Ralph Jones @date 1985-09-13
    +
    +
    20 SUBROUTINE w3fb02(ALAT, ALONG, XMESHL, XI, XJ)
    +
    21C
    +
    22C ...GIVEN ... ALAT SRN HEMI LATS ARE NEGATIVE VALUED
    +
    23C ALONG IN DEGREES WEST LONGITUDE
    +
    24C XMESHL= GRID INTERVAL IN KM, E.G., 381.0 KM
    +
    25C ...TO COMPUTE XI,XJ FOR A PT ON THE SRN HEMI POLAR STEREOGRAPHIC
    +
    26C ... PROJECTION, WITH 80W LONGITUDE VERTICAL AT THE TOP OF MAP,
    +
    27C ... AND 100E LONGITUDE VERTICAL AT THE BOTTOM OF THE MAP.
    +
    28C ...THE RESULTING XI AND XJ ARE RELATIVE TO (0,0) AT SOUTH POLE.
    +
    29C
    +
    30 DATA addlng/80.0/
    +
    31C
    +
    32C ...WHICH IS DIFFERENCE BETWEEN 180 DEGREES AND VERTICAL MERIDIAN.
    +
    33C ... THE VERTICAL BEING 100 WEST AFTER CHANGING THE SENSE
    +
    34C
    +
    35 DATA tiny /0.00001/
    +
    36 DATA earthr/6371.2/
    +
    37 DATA convt /0.017453293/
    +
    38C
    +
    39C ...WHICH CONVERTS DEGREES TO RADIANS
    +
    40C
    +
    41 re = (earthr * 1.86603) / xmeshl
    +
    42C
    +
    43C ...WHICH IS DISTANCE IN GRID INTERVALS FROM POLE TO EQUATOR
    +
    44C
    +
    45 xlat = -alat * convt
    +
    46C
    +
    47C ...WHERE NEGATIVE ALATS WERE GIVEN FOR SRN HEMI
    +
    48C
    +
    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/w3fb03_8f.html b/w3fb03_8f.html index 8d87eca8..638d8f41 100644 --- a/w3fb03_8f.html +++ b/w3fb03_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb03.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb03.f File Reference
    +
    w3fb03.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Convert i,j grid coordinates to lat/lon.

    @@ -107,8 +113,8 @@

    Definition in file w3fb03.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb03()

    + +

    ◆ w3fb03()

    @@ -117,31 +123,31 @@

    subroutine w3fb03 (   - XI, + xi,   - XJ, + xj,   - XMESHL, + xmeshl,   - TLAT, + tlat,   - TLONG  + tlong  @@ -179,7 +185,7 @@

    diff --git a/w3fb03_8f.js b/w3fb03_8f.js index 69951590..4dd42ce1 100644 --- a/w3fb03_8f.js +++ b/w3fb03_8f.js @@ -1,4 +1,4 @@ var w3fb03_8f = [ - [ "w3fb03", "w3fb03_8f.html#a0b68e4622016d2c2fe409ac880d66a3f", null ] + [ "w3fb03", "w3fb03_8f.html#ac1d9e9f45629c503bd63fc3e79c9892f", null ] ]; \ No newline at end of file diff --git a/w3fb03_8f_source.html b/w3fb03_8f_source.html index 865d40ae..30571bbe 100644 --- a/w3fb03_8f_source.html +++ b/w3fb03_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb03.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,78 +81,86 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb03.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert i,j grid coordinates to lat/lon.
    +
    3C> @author Ralph Jones @date 1986-07-17
    +
    4
    +
    5C> Converts i,j grid coordinates to the corresponding
    +
    6C> latitude/longitude on a southern hemisphere polar stereographic
    +
    7C> map projection.
    +
    8C>
    +
    9C> Program history log.
    +
    10C> - Ralph Jones 1986-07-17 Convert to fortran 77.
    +
    11C> - Ralph Jones 1990-08-31 Convert to cray cft77 fortran.
    +
    12C>
    +
    13C> @param[in] XI Real i coordinate.
    +
    14C> @param[in] XJ Real j coordinate.
    +
    15C> @param[in] XMESHL Real grid interval in km.
    +
    16C> @param[out] TLAT Real s.h. latitude.
    +
    17C> @param[out] TLONG Real longitude.
    +
    18C>
    +
    19C> @author Ralph Jones @date 1986-07-17
    +
    +
    20 SUBROUTINE w3fb03(XI, XJ, XMESHL, TLAT, TLONG)
    +
    21C
    +
    22C ...GIVEN ... XI/XJ GRID COORDINATES OF A POINT RELATIVE
    +
    23C ... TO (0,0) AT SOUTH POLE
    +
    24C ...TO COMPUTE TLAT,TLONG ON THE SRN HEMI POLAR STEREO PROJECTION
    +
    25C ...WITH 80W VERTICAL AT TOP OF THE MAP
    +
    26C
    +
    27 DATA degprd/57.2957795/
    +
    28 DATA earthr/6371.2/
    +
    29C
    +
    30 re = (earthr * 1.86603) / xmeshl
    +
    31 gi2 = re * re
    +
    32C
    +
    33C ...WHERE GI2 IS THE SQUARE OF DISTANCE IN GRID INTERVALS
    +
    34C ... FROM POLE TO EQUATOR...
    +
    35C
    +
    36 r2 = xi * xi + xj * xj
    +
    37 IF (r2 .NE. 0.0) THEN
    +
    38C
    +
    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
    +
    44C
    +
    45 ELSE
    +
    46 tlat = -90.0
    +
    47C
    +
    48C ...FOR SOUTH POLE...
    +
    49C
    +
    50 tlong = 0.0
    +
    51 ENDIF
    +
    52C
    +
    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/w3fb04_8f.html b/w3fb04_8f.html index 931fe9f9..5c4f9168 100644 --- a/w3fb04_8f.html +++ b/w3fb04_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb04.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb04.f File Reference
    +
    w3fb04.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Latitude, longitude to grid coordinates.

    @@ -107,8 +113,8 @@

    Definition in file w3fb04.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb04()

    + +

    ◆ w3fb04()

    @@ -117,37 +123,37 @@

    subroutine w3fb04 (   - ALAT, + alat,   - ALONG, + along,   - XMESHL, + xmeshl,   - ORIENT, + orient,   - XI, + xi,   - XJ  + xj  @@ -158,7 +164,7 @@

    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().

    +

    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.
      • @@ -191,7 +197,7 @@

    diff --git a/w3fb04_8f.js b/w3fb04_8f.js index 87321bb7..88d85268 100644 --- a/w3fb04_8f.js +++ b/w3fb04_8f.js @@ -1,4 +1,4 @@ var w3fb04_8f = [ - [ "w3fb04", "w3fb04_8f.html#a239793420ab239a1a96df658749018ff", null ] + [ "w3fb04", "w3fb04_8f.html#a3b860b612d62a311ec6364ed3ecd1ca4", null ] ]; \ No newline at end of file diff --git a/w3fb04_8f_source.html b/w3fb04_8f_source.html index 1bdda093..d1c5ba25 100644 --- a/w3fb04_8f_source.html +++ b/w3fb04_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb04.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,86 +81,94 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb04.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Latitude, longitude to grid coordinates.
    +
    3C> @author James McDonell @date 1986-07-17
    +
    4
    +
    5C> Converts the coordinates of a location on earth from the
    +
    6C> natural coordinate system of latitude/longitude to the grid (i,j)
    +
    7C> coordinate system overlaid on a polar stereographic map pro-
    +
    8C> jection true at 60 degrees n or s latitude. w3fb04() is the reverse
    +
    9C> of w3fb05().
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - James McDonell 1986-07-17
    +
    13C> - Ralph Jones 1988-06-07 Clean up code, take out goto, use then, else.
    +
    14C> - Ralph Jones 1989-11-02 Change to cray cft77 fortran.
    +
    15C>
    +
    16C> @param[in] ALAT Latitude in degrees (<0 if sh).
    +
    17C> @param[in] ALONG West longitude in degrees.
    +
    18C> @param[in] XMESHL Mesh length of grid in km at 60 deg lat(<0 if sh)
    +
    19C> (190.5 lfm grid, 381.0 nh pe grid,-381.0 sh pe grid).
    +
    20C> @param[in] ORIENT Orientation west longitude of the grid
    +
    21C> (105.0 lfm grid, 80.0 nh pe grid, 260.0 sh pe grid).
    +
    22C> @param[out] XI I of the point relative to north or south pole.
    +
    23C> @param[out] XJ J of the point relative to north or south pole.
    +
    24C>
    +
    25C> @note All parameters in the calling statement must be
    +
    26c> real. the range of allowable latitudes is from a pole to
    +
    27c> 30 degrees into the opposite hemisphere.
    +
    28c> The grid used in this subroutine has its origin (i=0,j=0)
    +
    29c> at the pole in either hemisphere, so if the user's grid has its
    +
    30c> origin at a point other than the pole, a translation is needed
    +
    31c> to get i and j. The gridlines of i=constant are parallel to a
    +
    32c> longitude designated by the user. the earth's radius is taken
    +
    33c> to be 6371.2 km.
    +
    34C>
    +
    35C> @note This code is not vectorized. To vectorize take it and the
    +
    36C> subroutine it calls and put them in line.
    +
    37C>
    +
    38C> @author James McDonell @date 1986-07-17
    +
    +
    39 SUBROUTINE w3fb04(ALAT,ALONG,XMESHL,ORIENT,XI,XJ)
    +
    40C
    +
    41 DATA radpd /.01745329/
    +
    42 DATA earthr/6371.2/
    +
    43C
    +
    44 re = (earthr * 1.86603) / xmeshl
    +
    45 xlat = alat * radpd
    +
    46C
    +
    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
    +
    60C
    +
    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/w3fb05_8f.html b/w3fb05_8f.html index f711ae51..1de7107f 100644 --- a/w3fb05_8f.html +++ b/w3fb05_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb05.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb05.f File Reference
    +
    w3fb05.f File Reference
    @@ -94,17 +100,71 @@

    Go to the source code of this file.

    - - - + + +

    +

    Functions/Subroutines

    -subroutine w3fb05 (XI, XJ, XMESHL, ORIENT, ALAT, ALONG)
     
    subroutine w3fb05 (xi, xj, xmeshl, orient, alat, along)
     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.
     

    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().

    +
    Date
    1986-07-17
    + +

    Definition in file w3fb05.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb05()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb05 ( xi,
     xj,
     xmeshl,
     orient,
     alat,
     along 
    )
    +
    + +

    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.
      • @@ -120,20 +180,23 @@ -
      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.
      +
      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.
      +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.

      -
    +

    Definition at line 39 of file w3fb05.f.

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

    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...
     
    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.
     

    Detailed Description

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

    @@ -107,8 +113,8 @@

    Definition in file w3fb06.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb06()

    + +

    ◆ w3fb06()

    @@ -117,49 +123,49 @@

    subroutine w3fb06 (   - ALAT, + alat,   - ALON, + alon,   - ALAT1, + alat1,   - ALON1, + alon1,   - DX, + dx,   - ALONV, + alonv,   - XI, + xi,   - XJ  + xj  @@ -170,7 +176,7 @@

    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

    +

    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.
      • @@ -202,7 +208,7 @@

    diff --git a/w3fb06_8f.js b/w3fb06_8f.js index a24b7070..7d067b86 100644 --- a/w3fb06_8f.js +++ b/w3fb06_8f.js @@ -1,4 +1,4 @@ var w3fb06_8f = [ - [ "w3fb06", "w3fb06_8f.html#a04de76d1aea61cb48ebcd1470101bca9", null ] + [ "w3fb06", "w3fb06_8f.html#a3b5622b466f3ab1d3c93b8c3606ca27e", null ] ]; \ No newline at end of file diff --git a/w3fb06_8f_source.html b/w3fb06_8f_source.html index 21f3a35d..5e9a0a2a 100644 --- a/w3fb06_8f_source.html +++ b/w3fb06_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb06.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,113 +81,121 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb06.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Lat/lon to pola (i,j) for grib.
    +
    3C> @author John Stackpole @date 1988-01-01
    +
    4
    +
    5C> Converts the coordinates of a location on earth given in
    +
    6C> the natural coordinate system of latitude/longitude to a grid
    +
    7C> coordinate system overlaid on a polar stereographic map pro-
    +
    8C> jection true at 60 degrees n or s latitude. w3fb06() is the reverse
    +
    9C> of w3fb07(). uses grib specification of the location of the grid
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - John Stackpole 1988-01-01
    +
    13C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    14C>
    +
    15C> @param[in] ALAT Latitude in degrees (negative in southern hemis)
    +
    16C> @param[in] ALON East longitude in degrees, real*4
    +
    17C> @param[in] ALAT1 Latitude of lower left point of grid (point (1,1))
    +
    18C> @param[in] ALON1 Longitude of lower left point of grid (point (1,1))
    +
    19C> all real*4
    +
    20C> @param[in] DX Mesh length of grid in meters at 60 deg lat
    +
    21C> must be set negative if using
    +
    22C> southern hemisphere projection.
    +
    23C> 190500.0 lfm grid,
    +
    24C> 381000.0 nh pe grid, -381000.0 sh pe grid, etc.
    +
    25C> @param[in] ALONV The orientation of the grid. i.e.,
    +
    26C> the east longitude value of the vertical meridian
    +
    27C> which is parallel to the y-axis (or columns of
    +
    28C> of the grid)along which latitude increases as
    +
    29C> the y-coordinate increases. real*4
    +
    30C> for example:
    +
    31C> 255.0 for lfm grid,
    +
    32C> 280.0 nh pe grid, 100.0 sh pe grid, etc.
    +
    33C> @param[out] XI I Coordinate of the point specified by alat, alon.
    +
    34C> @param[out] XJ J Coordinate of the point; both real*4.
    +
    35C>
    +
    36C> @note Formulae and notation loosely based on hoke, hayes,
    +
    37C> and renninger's "map projections and grid systems...", march 1981
    +
    38C> afgwc/tn-79/003
    +
    39C>
    +
    40C> @author John Stackpole @date 1988-01-01
    +
    +
    41 SUBROUTINE w3fb06(ALAT,ALON,ALAT1,ALON1,DX,ALONV,XI,XJ)
    +
    42C
    +
    43 DATA rerth /6.3712e+6/, pi/3.1416/
    +
    44 DATA ss60 /1.86603/
    +
    45C
    +
    46C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    47C
    +
    48C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    49C
    +
    50C REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE
    +
    51C DRAWN THROUGH THE POLE AND TO THE RIGHT LIES
    +
    52C ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE
    +
    53C DIFFERENTLY IN EACH HEMISPHERE
    +
    54C
    +
    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
    +
    64C
    +
    65 radpd = pi / 180.0
    +
    66 rebydx = rerth/dxl
    +
    67C
    +
    68C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    69C
    +
    70 ala1 = alat1 * radpd
    +
    71 rmll = rebydx * cos(ala1) * ss60/(1. + h * sin(ala1))
    +
    72C
    +
    73C USE LL POINT INFO TO LOCATE POLE POINT
    +
    74C
    +
    75 alo1 = (alon1 - reflon) * radpd
    +
    76 polei = 1. - rmll * cos(alo1)
    +
    77 polej = 1. - h * rmll * sin(alo1)
    +
    78C
    +
    79C RADIUS TO DESIRED POINT AND THE I J TOO
    +
    80C
    +
    81 ala = alat * radpd
    +
    82 rm = rebydx * cos(ala) * ss60/(1. + h * sin(ala))
    +
    83C
    +
    84 alo = (alon - reflon) * radpd
    +
    85 xi = polei + rm * cos(alo)
    +
    86 xj = polej + h * rm * sin(alo)
    +
    87C
    +
    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/w3fb07_8f.html b/w3fb07_8f.html index 52615013..39b4cf9a 100644 --- a/w3fb07_8f.html +++ b/w3fb07_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb07.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb07.f File Reference
    +
    w3fb07.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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().
     

    Detailed Description

    Grid coords to lat/lon for grib.

    @@ -107,8 +113,8 @@

    Definition in file w3fb07.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb07()

    + +

    ◆ w3fb07()

    @@ -117,49 +123,49 @@

    subroutine w3fb07 (   - XI, + xi,   - XJ, + xj,   - ALAT1, + alat1,   - ALON1, + alon1,   - DX, + dx,   - ALONV, + alonv,   - ALAT, + alat,   - ALON  + alon  @@ -169,7 +175,7 @@

    -

    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().

    +

    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
      • @@ -202,7 +208,7 @@

    diff --git a/w3fb07_8f.js b/w3fb07_8f.js index 2fc218d1..88b2d874 100644 --- a/w3fb07_8f.js +++ b/w3fb07_8f.js @@ -1,4 +1,4 @@ var w3fb07_8f = [ - [ "w3fb07", "w3fb07_8f.html#a2c8196faf8798dbc2b7593e0a1ec5b68", null ] + [ "w3fb07", "w3fb07_8f.html#ade62d0dff4cb419a076b295780e1c72d", null ] ]; \ No newline at end of file diff --git a/w3fb07_8f_source.html b/w3fb07_8f_source.html index 217b8874..a76f8417 100644 --- a/w3fb07_8f_source.html +++ b/w3fb07_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb07.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,130 +81,138 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb07.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Grid coords to lat/lon for grib.
    +
    3C> @author John Stackpole @date 1988-01-01
    +
    4
    +
    5C> Converts the coordinates of a location on earth given in a
    +
    6C> grid coordinate system overlaid on a polar stereographic map pro-
    +
    7C> jection true at 60 degrees n or s latitude to the
    +
    8C> natural coordinate system of latitude/longitude
    +
    9C> w3fb07() is the reverse of w3fb06().
    +
    10C> uses grib specification of the location of the grid
    +
    11C>
    +
    12C> Program history log:
    +
    13C> - John Stackpole 1988-01-01
    +
    14C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    15C>
    +
    16C> @param[in] XI I coordinate of the point real*4.
    +
    17C> @param[in] XJ J coordinate of the point real*4.
    +
    18C> @param[in] ALAT1 Latitude of lower left point of grid (point 1,1)
    +
    19C> latitude <0 for southern hemisphere; real*4.
    +
    20C> @param[in] ALON1 Longitude of lower left point of grid (point 1,1)
    +
    21C> east longitude used throughout; real*4.
    +
    22C> @param[in] DX Mesh length of grid in meters at 60 deg lat
    +
    23C> must be set negative if using
    +
    24C> southern hemisphere projection; real*4
    +
    25C> 190500.0 lfm grid,
    +
    26C> 381000.0 nh pe grid, -381000.0 sh pe grid, etc.
    +
    27C> @param[in] ALONV The orientation of the grid. i.e.,
    +
    28C> the east longitude value of the vertical meridian
    +
    29C> which is parallel to the y-axis (or columns of
    +
    30C> the grid) along which latitude increases as
    +
    31C> the y-coordinate increases. real*4
    +
    32C> for example:
    +
    33C> 255.0 for lfm grid,
    +
    34C> 280.0 nh pe grid, 100.0 sh pe grid, etc.
    +
    35C> @param[out] ALAT Latitude in degrees (negative in southern hemi.).
    +
    36C> @param[out] ALON East longitude in degrees, real*4.
    +
    37C>
    +
    38C> @note Formulae and notation loosely based on hoke, hayes,
    +
    39C> and renninger's "map projections and grid systems...", march 1981
    +
    40C> afgwc/tn-79/003
    +
    41C>
    +
    42C> @author John Stackpole @date 1988-01-01
    +
    +
    43 SUBROUTINE w3fb07(XI,XJ,ALAT1,ALON1,DX,ALONV,ALAT,ALON)
    +
    44C
    +
    45 DATA rerth /6.3712e+6/,pi/3.1416/
    +
    46 DATA ss60 /1.86603/
    +
    47C
    +
    48C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    49C
    +
    50C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    51C
    +
    52C REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE
    +
    53C DRAWN THROUGH THE POLE AND TO THE RIGHT LIES
    +
    54C ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE
    +
    55C DIFFERENTLY IN EACH HEMISPHERE
    +
    56C
    +
    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
    +
    66C
    +
    67 radpd = pi / 180.0
    +
    68 degprd = 180.0 / pi
    +
    69 rebydx = rerth / dxl
    +
    70C
    +
    71C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    72C
    +
    73 ala1 = alat1 * radpd
    +
    74 rmll = rebydx * cos(ala1) * ss60/(1. + h * sin(ala1))
    +
    75C
    +
    76C USE LL POINT INFO TO LOCATE POLE POINT
    +
    77C
    +
    78 alo1 = (alon1 - reflon) * radpd
    +
    79 polei = 1. - rmll * cos(alo1)
    +
    80 polej = 1. - h * rmll * sin(alo1)
    +
    81C
    +
    82C RADIUS TO THE I,J POINT (IN GRID UNITS)
    +
    83C
    +
    84 xx = xi - polei
    +
    85 yy = (xj - polej) * h
    +
    86 r2 = xx**2 + yy**2
    +
    87C
    +
    88C NOW THE MAGIC FORMULAE
    +
    89C
    +
    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.
    +
    104C
    +
    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/w3fb08_8f.html b/w3fb08_8f.html index a9d3ec7c..ce4adbeb 100644 --- a/w3fb08_8f.html +++ b/w3fb08_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb08.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb08.f File Reference
    +
    w3fb08.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

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

    @@ -107,8 +113,8 @@

    Definition in file w3fb08.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb08()

    + +

    ◆ w3fb08()

    @@ -117,49 +123,49 @@

    subroutine w3fb08 (   - ALAT, + alat,   - ALON, + alon,   - ALAT1, + alat1,   - ALON1, + alon1,   - ALATIN, + alatin,   - DX, + dx,   - XI, + xi,   - XJ  + xj  @@ -169,7 +175,7 @@

    -

    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.

    +

    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.
      • @@ -201,7 +207,7 @@

    diff --git a/w3fb08_8f.js b/w3fb08_8f.js index 74c61040..78001ac2 100644 --- a/w3fb08_8f.js +++ b/w3fb08_8f.js @@ -1,4 +1,4 @@ var w3fb08_8f = [ - [ "w3fb08", "w3fb08_8f.html#ad3b516b61a4b4b53e680c775f3e92a5b", null ] + [ "w3fb08", "w3fb08_8f.html#a404c4d79a1162f49baeebe63f6a48174", null ] ]; \ No newline at end of file diff --git a/w3fb08_8f_source.html b/w3fb08_8f_source.html index 50b31ea2..92b272f4 100644 --- a/w3fb08_8f_source.html +++ b/w3fb08_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb08.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,80 +81,88 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb08.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Lat/lon to merc (i,j) for grib.
    +
    3C> @author John Stackpole @date 1988-03-01
    +
    4
    +
    5C> Converts a location on earth given in
    +
    6C> the coordinate system of latitude/longitude to an (i,j)
    +
    7C> coordinate system overlaid on a mercator map projection
    +
    8C> w3fb08() is the reverse of w3fb09()
    +
    9C> uses grib specification of the location of the grid.
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - John Stackpole 1988-03-01
    +
    13C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    14C>
    +
    15C> @param[in] ALAT Latitude in degrees (negative in southern hemis).
    +
    16C> @param[in] ALON East longitude in degrees, real*4.
    +
    17C> @param[in] ALAT1 Latitude of lower left corner of grid (point (1,1)).
    +
    18C> @param[in] ALON1 Longitude of lower left corner of grid (point (1,1))
    +
    19C> all real*4.
    +
    20C> @param[in] ALATIN The latitude at which the mercator cylinder
    +
    21C> intersects the earth.
    +
    22C> @param[in] DX Mesh length of grid in meters at alatin.
    +
    23C> @param[out] XI I coordinate of the point specified by alat, alon.
    +
    24C> @param[out] XJ J coordinate of the point; both real*4.
    +
    25C>
    +
    26C> @note Formulae and notation loosely based on hoke, hayes,
    +
    27C> and renninger's "map projections and grid systems...", march 1981
    +
    28C> afgwc/tn-79/003
    +
    29C>
    +
    30C> @author John Stackpole @date 1988-03-01
    +
    +
    31 SUBROUTINE w3fb08(ALAT,ALON,ALAT1,ALON1,ALATIN,DX,XI,XJ)
    +
    32C
    +
    33 DATA rerth /6.3712e+6/, pi/3.1416/
    +
    34C
    +
    35C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    36C
    +
    37 radpd = pi / 180.0
    +
    38 degpr = 180.0 / pi
    +
    39 clain = cos(radpd*alatin)
    +
    40 dellon = dx / (rerth*clain)
    +
    41C
    +
    42C GET DISTANCE FROM EQUATOR TO ORIGIN ALAT1
    +
    43C
    +
    44 djeo = 0.
    +
    45 IF (alat1.NE.0.)
    +
    46 & djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    47C
    +
    48C NOW THE I AND J COORDINATES
    +
    49C
    +
    50 xi = 1. + ((alon - alon1)/(dellon*degpr))
    +
    51 xj = 1. + (alog(tan(0.5*((alat + 90.) * radpd))))/
    +
    52 & dellon
    +
    53 & - djeo
    +
    54C
    +
    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/w3fb09_8f.html b/w3fb09_8f.html index 54939566..e916a5cb 100644 --- a/w3fb09_8f.html +++ b/w3fb09_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb09.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb09.f File Reference
    +
    w3fb09.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Merc (i,j) to lat/lon for grib.

    @@ -107,8 +113,8 @@

    Definition in file w3fb09.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb09()

    + +

    ◆ w3fb09()

    @@ -117,49 +123,49 @@

    subroutine w3fb09 (   - XI, + xi,   - XJ, + xj,   - ALAT1, + alat1,   - ALON1, + alon1,   - ALATIN, + alatin,   - DX, + dx,   - ALAT, + alat,   - ALON  + alon  @@ -169,7 +175,7 @@

    -

    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.

    +

    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.
      • @@ -201,7 +207,7 @@

    diff --git a/w3fb09_8f.js b/w3fb09_8f.js index e2027fbc..e02c9f86 100644 --- a/w3fb09_8f.js +++ b/w3fb09_8f.js @@ -1,4 +1,4 @@ var w3fb09_8f = [ - [ "w3fb09", "w3fb09_8f.html#a44a5c4c417459876b5cbc4aaab8e4a25", null ] + [ "w3fb09", "w3fb09_8f.html#a97d39b7d805646bba7510a3fb06f44ea", null ] ]; \ No newline at end of file diff --git a/w3fb09_8f_source.html b/w3fb09_8f_source.html index e8d2ca81..2a8c257f 100644 --- a/w3fb09_8f_source.html +++ b/w3fb09_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb09.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,79 +81,87 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb09.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Merc (i,j) to lat/lon for grib
    +
    3C> @author John Stackpole @date 1988-03-01
    +
    4
    +
    5C> Converts a location on Earth given in
    +
    6C> an i,j coordinate system overlaid on a mercator map projection
    +
    7C> to the coordinate system of latitude/longitude
    +
    8C> w3fb09() is the reverse of w3fb08()
    +
    9C> uses grib specification of the location of the grid.
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - John Stackpole 1988-03-01
    +
    13C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    14C>
    +
    15C> @param[in] XI I coordinate of the point.
    +
    16C> @param[in] XJ J coordinate of the point; both real*4.
    +
    17C> @param[in] ALAT1 Latitude of lower left corner of grid (point (1,1)).
    +
    18C> @param[in] ALON1 Longitude of lower left corner of grid (point (1,1))
    +
    19C> all real*4.
    +
    20C> @param[in] ALATIN The latitude at which the mercator cylinder
    +
    21C> intersects the Earth.
    +
    22C> @param[in] DX Mesh length of grid in meters at alatin.
    +
    23C> @param[out] ALAT Latitude in degrees (negative in southern hemis).
    +
    24C> @param[out] ALON East longitude in degrees, real*4
    +
    25C> of the point specified by (i,j).
    +
    26C>
    +
    27C> @note Formulae and notation loosely based on hoke, hayes,
    +
    28C> and renninger's "map projections and grid systems...", march 1981
    +
    29C> afgwc/tn-79/003
    +
    30C>
    +
    31C> @author John Stackpole @date 1988-03-01
    +
    +
    32 SUBROUTINE w3fb09(XI,XJ,ALAT1,ALON1,ALATIN,DX,ALAT,ALON)
    +
    33C
    +
    34 DATA rerth /6.3712e+6/, pi/3.1416/
    +
    35C
    +
    36C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    37C
    +
    38 radpd = pi / 180.0
    +
    39 degpr = 180.0 / pi
    +
    40 clain = cos(radpd*alatin)
    +
    41 dellon = dx / (rerth*clain)
    +
    42C
    +
    43C GET DISTANCE FROM EQUATOR TO ORIGIN ALAT1
    +
    44C
    +
    45 djeo = 0.
    +
    46 IF (alat1.NE.0.)
    +
    47 & djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    48C
    +
    49C NOW THE LAT AND LON
    +
    50C
    +
    51 alat = 2.0*atan(exp(dellon*(djeo + xj-1.)))*degpr - 90.0
    +
    52 alon = (xi-1.) * dellon * degpr + alon1
    +
    53C
    +
    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/w3fb10_8f.html b/w3fb10_8f.html index f935744e..668097fd 100644 --- a/w3fb10_8f.html +++ b/w3fb10_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb10.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb10.f File Reference
    +
    w3fb10.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Lat/long pair to compass bearing, gcd.

    @@ -107,8 +113,8 @@

    Definition in file w3fb10.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb10()

    + +

    ◆ w3fb10()

    @@ -117,37 +123,37 @@

    subroutine w3fb10 ( real  - DLAT1, + dlat1, real  - DLON1, + dlon1, real  - DLAT2, + dlat2, real  - DLON2, + dlon2, real  - BEARD, + beard, real  - GCDKM  + gcdkm  @@ -157,7 +163,7 @@

    -

    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.

    +

    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
      • @@ -196,7 +202,7 @@

    diff --git a/w3fb10_8f.js b/w3fb10_8f.js index 82127e2a..256b54f9 100644 --- a/w3fb10_8f.js +++ b/w3fb10_8f.js @@ -1,4 +1,4 @@ var w3fb10_8f = [ - [ "w3fb10", "w3fb10_8f.html#a5f021ccf55ac42f4034f0fd60e612911", null ] + [ "w3fb10", "w3fb10_8f.html#aa7f39f82090c39b8550d19c26fd6e88c", null ] ]; \ No newline at end of file diff --git a/w3fb10_8f_source.html b/w3fb10_8f_source.html index c11d55aa..74dfbf32 100644 --- a/w3fb10_8f_source.html +++ b/w3fb10_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb10.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,252 +81,260 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb10.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Lat/long pair to compass bearing, gcd.
    +
    3C> @author Peter Chase @date 1988-08-29
    +
    4
    +
    5C> Given a pair of points (1) and (2) given by latitude and
    +
    6C> longitude, w3fb10() computes the bearing and great circle distance
    +
    7C> from point (1) to point (2) assuming a spherical Earth. The
    +
    8C> north and south poles are special cases. If latitude of point
    +
    9C> (1) is within 1e-10 degrees of the north pole, bearing is the
    +
    10C> negative longitude of point (2) by convention. If latitude of
    +
    11C> point (1) is within 1e-10 degrees of the south pole, bearing is
    +
    12C> the longitude of point (2) by convention. If point (2) is within
    +
    13C> 1e-6 radians of the antipode of point (1), the bearing will be
    +
    14C> set to zero. If point (1) and point (2) are within 1e-10 radians
    +
    15C> of each other, both bearing and distance will be set to zero.
    +
    16C>
    +
    17C> Program history log:
    +
    18C> - Peter Chase 1988-08-29
    +
    19C> - Peter Chase 1988-09-23 Fix dumb south pole error.
    +
    20C> - Peter Chase 1988-10-05 Fix bearing ambiguity.
    +
    21C> - Ralph Jones 1990-04-12 Convert to cft77 fortran.
    +
    22C>
    +
    23C> @param[in] DLAT1 REAL Latitude of point (1) in degrees north.
    +
    24C> @param[in] DLON1 REAL Longitude of point (1) in degrees east.
    +
    25C> @param[in] DLAT2 REAL Latitude of point (2) in degrees north.
    +
    26C> @param[in] DLON2 REAL Longitude of point (2) in degrees east.
    +
    27C> @param[out] BEARD REAL Bearing of point (2) from point (1) in
    +
    28C> compass degrees with north = 0.0, values from
    +
    29C> -180.0 to +180.0 degrees.
    +
    30C> @param[out] GCDKM REAL Great circle distance from point (1) to
    +
    31C> point (2) in kilometers.
    +
    32C>
    +
    33C> @note According to the nmc handbook, the Earth's radius is
    +
    34C> 6371.2 kilometers. This is what we use, even though the value
    +
    35C> recommended by the smithsonian meteorological handbook is
    +
    36C> 6371.221 km. (I wouldn't want you to think that I didn't know
    +
    37C> what the correct value was.)
    +
    38C>
    +
    39C> @note Method: The poles are special cases, and handled separately.
    +
    40C> otherwise, from spherical trigonometry, the law of cosines is used
    +
    41C> to calculate the third side of the spherical triangle having
    +
    42C> sides from the pole to points (1) and (2) (the colatitudes).
    +
    43C> then the law of sines is used to calculate the angle at point
    +
    44C> (1). A test is applied to see whether the arcsine result may be
    +
    45C> be used as such, giving an acute angle as the bearing, or whether
    +
    46C> the arcsine result should be subtracted from pi, giving an obtuse
    +
    47C> angle as the bearing. This test is derived by constructing a
    +
    48C> right spherical triangle using the pole, point (2), and the
    +
    49C> meridian through point(1). The latitude of the right-angled
    +
    50C> vertex then provides a test--if latitude (1) is greater than this
    +
    51C> latitude, the bearing angle must be obtuse, otherwise acute.
    +
    52C> If the two points are within 1e-6 radians of each other
    +
    53C> a flat Earth is assumed, and the four-quadrant arctangent
    +
    54C> function is used to find the bearing. The y-displacement is
    +
    55C> the difference in latitude and the x-displacement is the
    +
    56C> difference in longitude times cosine latitude, both in radians.
    +
    57C> distance is then the diagonal.
    +
    58C>
    +
    59C> @note Fundamental trigonometric identities are used freely, such
    +
    60C> as that cos(x) = sin(pi/2 - x), etc. See almost any mathematical
    +
    61C> handbook, such as the c.r.c. standard math tables under 'relations
    +
    62C> in any spherical triangle', or the national bureau of standards
    +
    63C> 'handbook of mathematical functions' under section 4.3.149,
    +
    64C> formulas for solution of spherical triangles.
    +
    65C>
    +
    66C> @note Double precision is used internally because of the wide
    +
    67C> range of geographic values that may be used.
    +
    68C>
    +
    69C> @author Peter Chase @date 1988-08-29
    +
    +
    70 SUBROUTINE w3fb10(DLAT1, DLON1, DLAT2, DLON2, BEARD, GCDKM)
    +
    71C
    +
    72C *** IMPLICIT TYPE DEFAULTS.....
    +
    73C
    +
    74 IMPLICIT REAL (A-H,O-Z)
    +
    75C
    +
    76C *** CONSTANTS......
    +
    77C
    +
    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
    +
    85C
    +
    86C *** VARIABLES......
    +
    87C
    +
    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
    +
    92C
    +
    93C *** CONVERT LATITUDES AND LONGITUDE DIFFERENCE TO RADIANS.
    +
    94C
    +
    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
    +
    111C
    +
    112C *** FIRST WE ATTACK THE CASES WHERE POINT 1 IS VERY CLOSE TO THE
    +
    113C *** NORTH OR SOUTH POLES.
    +
    114C *** HERE WE USE CONVENTIONAL VALUE FOR BEARING.. - LONG (2) AT THE
    +
    115C *** NORTH POLE, AND + LONG (2) AT THE SOUTH POLE.
    +
    116C
    +
    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
    +
    139C
    +
    140C *** NEXT WE ATTACK THE CASES WHERE POINT 2 IS VERY CLOSE TO THE
    +
    141C *** NORTH OR SOUTH POLES.
    +
    142C *** HERE BEARING IS SIMPLY 0 OR 180 DEGREES.
    +
    143C
    +
    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
    +
    150C
    +
    151C *** THE CASE REMAINS THAT NEITHER POINT IS AT EITHER POLE.
    +
    152C *** FIND COSINE AND SINE OF LATITUDES AND LONGITUDE DIFFERENCE
    +
    153C *** SINCE THEY ARE USED IN MORE THAN ONE FORMULA.
    +
    154C
    +
    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)
    +
    162C
    +
    163C *** FOLLOWING IS FORMULA FOR GREAT CIRCLE SUBTENDED ANGLE BETWEEN
    +
    164C *** POINTS IN RADIAN MEASURE.
    +
    165C
    +
    166 sangg = acos(sinla1*sinla2 + cosla1*cosla2*coslo)
    +
    167C
    +
    168C *** IF THE GREAT CIRCLE SUBTENDED ANGLE IS VERY SMALL, FORCE BOTH
    +
    169C *** BEARING AND DISTANCE TO BE ZERO.
    +
    170C
    +
    171 IF (abs(sangg) .LT. trad) THEN
    +
    172 dbang = 0.0
    +
    173 sangg = 0.0
    +
    174C
    +
    175C *** IF THE GREAT CIRCLE SUBTENDED ANGLE IS JUST SMALL, ASSUME A
    +
    176C *** FLAT EARTH AND CALCULATE Y- AND X-DISPLACEMENTS. THEN FIND
    +
    177C *** BEARING USING THE ARCTANGENT FUNCTION AND DISTANCE USING THE
    +
    178C *** SQUARE ROOT.
    +
    179C
    +
    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)
    +
    186C
    +
    187C *** IF THE ANGLE IS RATHER CLOSE TO PI RADIANS, FORCE BEARING TO
    +
    188C *** BE ZERO AND DISTANCE TO BE PI.
    +
    189C *** THE TEST FOR 'CLOSE TO PI' IS MORE RELAXED THAN THE TEST FOR
    +
    190C *** 'CLOSE TO ZERO' TO ALLOW FOR GREATER RELATIVE ERROR.
    +
    191C
    +
    192 ELSE IF (abs(sangg-pi) .LT. tpod) THEN
    +
    193 dbang = 0.0
    +
    194 sangg = pi
    +
    195C
    +
    196C *** OTHERWISE COMPUTE THE PRINCIPAL VALUE OF THE BEARING ANGLE
    +
    197C *** USING THE LAW OF SINES. THE DIVISION BY THE SINE FORCES US TO
    +
    198C *** LIMIT THE DOMAIN OF THE ARCSINE TO (-1,1).
    +
    199C
    +
    200 ELSE
    +
    201 abear = asin(amax1(-1.0,amin1(+1.0,cosla2*sinlo/
    +
    202 & sin(sangg))))
    +
    203C
    +
    204C *** IF THE LONGITUDE DIFFERENCE IS LESS THAN PI/2 IT IS NECESSARY
    +
    205C *** TO CHECK WHETHER THE BEARING ANGLE IS ACUTE OR OBTUSE BY
    +
    206C *** COMPARING LATITUDE (1) WITH THE LATITUDE OF THE GREAT CIRCLE
    +
    207C *** THROUGH POINT (2) NORMAL TO MERIDIAN OF LONGITUDE (1). IF
    +
    208C *** LATITUDE (1) IS GREATER, BEARING IS OBTUSE AND THE ACTUAL
    +
    209C *** BEARING ANGLE IS THE SUPPLEMENT OF THE ANGLE CALCULATED ABOVE.
    +
    210C
    +
    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
    +
    218C
    +
    219C *** THIS FINISHES THE CASE WHERE POINTS ARE NOT AT THE POLES.
    +
    220C *** NOW CONVERT BEARING TO DEGREES IN RANGE -180 TO +180 AND FIND
    +
    221C *** GREAT CIRCLE DISTANCE IN KILOMETERS.
    +
    222C
    +
    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/w3fb11_8f.html b/w3fb11_8f.html index 09c9434d..d72894bf 100644 --- a/w3fb11_8f.html +++ b/w3fb11_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb11.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb11.f File Reference
    +
    w3fb11.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

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

    @@ -107,8 +113,8 @@

    Definition in file w3fb11.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb11()

    + +

    ◆ w3fb11()

    @@ -117,55 +123,55 @@

    subroutine w3fb11 (   - ALAT, + alat,   - ELON, + elon,   - ALAT1, + alat1,   - ELON1, + elon1,   - DX, + dx,   - ELONV, + elonv,   - ALATAN, + alatan,   - XI, + xi,   - XJ  + xj  @@ -176,7 +182,7 @@

    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

    +

    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.
      • @@ -210,7 +216,7 @@

    diff --git a/w3fb11_8f.js b/w3fb11_8f.js index c4f4e8e9..c6eaf257 100644 --- a/w3fb11_8f.js +++ b/w3fb11_8f.js @@ -1,4 +1,4 @@ var w3fb11_8f = [ - [ "w3fb11", "w3fb11_8f.html#a28b19a1336d3f885a04a97831726a3c0", null ] + [ "w3fb11", "w3fb11_8f.html#a44ef8585ec761cc4360677a4043ae836", null ] ]; \ No newline at end of file diff --git a/w3fb11_8f_source.html b/w3fb11_8f_source.html index 6bbfa898..ce4d66bd 100644 --- a/w3fb11_8f_source.html +++ b/w3fb11_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb11.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,136 +81,144 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb11.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Lat/lon to lambert(i,j) for grib.
    +
    3C> @author John Stackpole @date 1988-11-25
    +
    4
    +
    5C> Converts the coordinates of a location on Earth given in
    +
    6C> the natural coordinate system of latitude/longitude to a grid
    +
    7C> coordinate system overlaid on a lambert conformal tangent cone
    +
    8C> projection true at a given n or s latitude. w3fb11() is the reverse
    +
    9C> of w3fb12(). uses grib specification of the location of the grid
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - John Stackpole 1988-11-25
    +
    13C> - Ralph Jones 1990-04-12 Convert to cft77 fortran.
    +
    14C> - Ralph Jones 1994-04-28 Add save statement.
    +
    15C>
    +
    16C> @param[in] ALAT Latitude in degrees (negative in southern hemis).
    +
    17C> @param[in] ELON East longitude in degrees, real*4.
    +
    18C> @param[in] ALAT1 Latitude of lower left point of grid (point (1,1)).
    +
    19C> @param[in] ELON1 Longitude of lower left point of grid (point (1,1))
    +
    20C> all real*4.
    +
    21C> @param[in] DX Mesh length of grid in meters at tangent latitude.
    +
    22C> @param[in] ELONV The orientation of the grid. i.e.,
    +
    23C> the east longitude value of the vertical meridian
    +
    24C> which is parallel to the y-axis (or columns of
    +
    25C> of the grid) along which latitude increases as
    +
    26C> the y-coordinate increases. real*4
    +
    27C> this is also the meridian (on the back side of the
    +
    28C> tangent cone) along which the cut is made to lay
    +
    29C> the cone flat.
    +
    30C> @param[in] ALATAN The latitude at which the lambert cone is tangent to
    +
    31C> (touching) the spherical Earth. Set negative to indicate a
    +
    32C> southern hemisphere projection.
    +
    33C> @param[out] XI I coordinate of the point specified by alat, elon
    +
    34C> @param[out] XJ J coordinate of the point; both real*4
    +
    35C>
    +
    36C> @note Formulae and notation loosely based on hoke, hayes,
    +
    37C> and renninger's "map projections and grid systems...", march 1981
    +
    38C> afgwc/tn-79/003.
    +
    39C>
    +
    40C> @author John Stackpole @date 1988-11-25
    +
    +
    41 SUBROUTINE w3fb11(ALAT,ELON,ALAT1,ELON1,DX,ELONV,ALATAN,XI,XJ)
    +
    42C
    +
    43 SAVE
    +
    44C
    +
    45 DATA rerth /6.3712e+6/, pi/3.14159/
    +
    46C
    +
    47C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    48C
    +
    49C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    50C
    +
    51 IF (alatan.GT.0) THEN
    +
    52 h = 1.
    +
    53 ELSE
    +
    54 h = -1.
    +
    55 ENDIF
    +
    56C
    +
    57 radpd = pi / 180.0
    +
    58 rebydx = rerth / dx
    +
    59 alatn1 = alatan * radpd
    +
    60 an = h * sin(alatn1)
    +
    61 cosltn = cos(alatn1)
    +
    62C
    +
    63C MAKE SURE THAT INPUT LONGITUDES DO NOT PASS THROUGH
    +
    64C THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP
    +
    65C AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE.
    +
    66C
    +
    67 elon1l = elon1
    +
    68 IF ((elon1 - elonv).GT.180.)
    +
    69 & elon1l = elon1 - 360.
    +
    70 IF ((elon1 - elonv).LT.(-180.))
    +
    71 & elon1l = elon1 + 360.
    +
    72C
    +
    73 elonl = elon
    +
    74 IF ((elon - elonv).GT.180.)
    +
    75 & elonl = elon - 360.
    +
    76 IF ((elon - elonv).LT.(-180.))
    +
    77 & elonl = elon + 360.
    +
    78C
    +
    79 elonvr = elonv * radpd
    +
    80C
    +
    81C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    82C
    +
    83 ala1 = alat1 * radpd
    +
    84 rmll = rebydx * (((cosltn)**(1.-an))*(1.+an)**an) *
    +
    85 & (((cos(ala1))/(1.+h*sin(ala1)))**an)/an
    +
    86C
    +
    87C USE LL POINT INFO TO LOCATE POLE POINT
    +
    88C
    +
    89 elo1 = elon1l * radpd
    +
    90 arg = an * (elo1-elonvr)
    +
    91 polei = 1. - h * rmll * sin(arg)
    +
    92 polej = 1. + rmll * cos(arg)
    +
    93C
    +
    94C RADIUS TO DESIRED POINT AND THE I J TOO
    +
    95C
    +
    96 ala = alat * radpd
    +
    97 rm = rebydx * ((cosltn**(1.-an))*(1.+an)**an) *
    +
    98 & (((cos(ala))/(1.+h*sin(ala)))**an)/an
    +
    99C
    +
    100 elo = elonl * radpd
    +
    101 arg = an*(elo-elonvr)
    +
    102 xi = polei + h * rm * sin(arg)
    +
    103 xj = polej - rm * cos(arg)
    +
    104C
    +
    105C IF COORDINATE LESS THAN 1
    +
    106C COMPENSATE FOR ORIGIN AT (1,1)
    +
    107C
    +
    108 IF (xi.LT.1.) xi = xi - 1.
    +
    109 IF (xj.LT.1.) xj = xj - 1.
    +
    110C
    +
    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/w3fb12_8f.html b/w3fb12_8f.html index 559c4670..0172227f 100644 --- a/w3fb12_8f.html +++ b/w3fb12_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb12.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fb12.f File Reference
    +
    w3fb12.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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().
     

    Detailed Description

    Lambert(i,j) to lat/lon for grib.

    @@ -107,8 +113,8 @@

    Definition in file w3fb12.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fb12()

    + +

    ◆ w3fb12()

    @@ -117,61 +123,61 @@

    subroutine w3fb12 (   - XI, + xi,   - XJ, + xj,   - ALAT1, + alat1,   - ELON1, + elon1,   - DX, + dx,   - ELONV, + elonv,   - ALATAN, + alatan,   - ALAT, + alat,   - ELON, + elon,   - IERR  + ierr  @@ -181,7 +187,7 @@

    -

    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().

    +

    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
      • @@ -222,7 +228,7 @@

    diff --git a/w3fb12_8f.js b/w3fb12_8f.js index 702c7593..51afb1ed 100644 --- a/w3fb12_8f.js +++ b/w3fb12_8f.js @@ -1,4 +1,4 @@ var w3fb12_8f = [ - [ "w3fb12", "w3fb12_8f.html#ae5e7ad09f49bf57227336e663c180ee2", null ] + [ "w3fb12", "w3fb12_8f.html#a8bf51dda5c2baf121134274723c79837", null ] ]; \ No newline at end of file diff --git a/w3fb12_8f_source.html b/w3fb12_8f_source.html index 3e94ce69..9811756f 100644 --- a/w3fb12_8f_source.html +++ b/w3fb12_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fb12.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,190 +81,198 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fb12.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Lambert(i,j) to lat/lon for grib.
    +
    3C> @author John Stackpole @date 1988-11-25
    +
    4
    +
    5C> Converts the coordinates of a location on Earth given in a
    +
    6C> grid coordinate system overlaid on a lambert conformal tangent
    +
    7C> cone projection true at a given N or S latitude to the
    +
    8C> natural coordinate system of latitude/longitude
    +
    9C> w3fb12() is the reverse of w3fb11().
    +
    10C> Uses grib specification of the location of the grid
    +
    11C>
    +
    12C> PROGRAM HISTORY LOG:
    +
    13C> - John Stackpole 1988-11-25
    +
    14C> - Ralph Jones 1990-04-12 Convert to cft77 fortran.
    +
    15C> - Ralph Jones 1994-04-28 Add save statement.
    +
    16C>
    +
    17C> @param[in] XI I coordinate of the point real*4
    +
    18C> @param[in] XJ J coordinate of the point real*4
    +
    19C> @param[in] ALAT1 Latitude of lower left point of grid (point 1,1)
    +
    20C> latitude <0 for southern hemisphere; real*4
    +
    21C> @param[in] ELON1 Longitude of lower left point of grid (point 1,1)
    +
    22C> east longitude used throughout; real*4
    +
    23C> @param[in] DX Mesh length of grid in meters at tangent latitude
    +
    24C> @param[in] ELONV The orientation of the grid. i.e.,
    +
    25C> the east longitude value of the vertical meridian
    +
    26C> which is parallel to the y-axis (or columns of
    +
    27C> the grid) along which latitude increases as
    +
    28C> the y-coordinate increases. real*4
    +
    29C> this is also the meridian (on the other side of the
    +
    30C> tangent cone) along which the cut is made to lay
    +
    31C> the cone flat.
    +
    32C> @param[in] ALATAN The latitude at which the lambert cone is tangent to
    +
    33C> (touches or osculates) the spherical Earth.
    +
    34C> set negative to indicate a
    +
    35C> southern hemisphere projection; real*4
    +
    36C>
    +
    37C> @param[out] ALAT Latitude in degrees (negative in southern hemi.)
    +
    38C> @param[out] ELON East longitude in degrees, real*4
    +
    39C> @param[out] IERR
    +
    40C> - .eq. 0 if no problem
    +
    41C> - .ge. 1 if the requested xi,xj point is in the
    +
    42C> forbidden zone, i.e. off the lambert map
    +
    43C> in the open space where the cone is cut.
    +
    44C> - if ierr.ge.1 then alat=999. and elon=999.
    +
    45C>
    +
    46C> @note Formulae and notation loosely based on hoke, hayes,
    +
    47C> and renninger's "map projections and grid systems...", march 1981
    +
    48C> afgwc/tn-79/003
    +
    49C>
    +
    50C> @author John Stackpole @date 1988-11-25
    +
    +
    51 SUBROUTINE w3fb12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT,ELON,
    +
    52 & IERR)
    +
    53C
    +
    54 LOGICAL NEWMAP
    +
    55C
    +
    56 SAVE
    +
    57C
    +
    58 DATA rerth /6.3712e+6/, pi/3.14159/, oldrml/99999./
    +
    59C
    +
    60C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    61C
    +
    62C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    63C
    +
    64 IF (alatan.GT.0) THEN
    +
    65 h = 1.
    +
    66 ELSE
    +
    67 h = -1.
    +
    68 ENDIF
    +
    69C
    +
    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)
    +
    77C
    +
    78C MAKE SURE THAT INPUT LONGITUDE DOES NOT PASS THROUGH
    +
    79C THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP
    +
    80C AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE
    +
    81C
    +
    82 elon1l = elon1
    +
    83 IF ((elon1-elonv).GT.180.)
    +
    84 & elon1l = elon1 - 360.
    +
    85 IF ((elon1-elonv).LT.(-180.))
    +
    86 & elon1l = elon1 + 360.
    +
    87C
    +
    88 elonvr = elonv * radpd
    +
    89C
    +
    90C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    91C
    +
    92 ala1 = alat1 * radpd
    +
    93 rmll = rebydx * ((cosltn**(1.-an))*(1.+an)**an) *
    +
    94 & (((cos(ala1))/(1.+h*sin(ala1)))**an)/an
    +
    95C
    +
    96C USE RMLL TO TEST IF MAP AND GRID UNCHANGED FROM PREVIOUS
    +
    97C CALL TO THIS CODE. THUS AVOID UNNEEDED RECOMPUTATIONS.
    +
    98C
    +
    99 IF (rmll.EQ.oldrml) THEN
    +
    100 newmap = .false.
    +
    101 ELSE
    +
    102 newmap = .true.
    +
    103 oldrml = rmll
    +
    104C
    +
    105C USE LL POINT INFO TO LOCATE POLE POINT
    +
    106C
    +
    107 elo1 = elon1l * radpd
    +
    108 arg = an * (elo1-elonvr)
    +
    109 polei = 1. - h * rmll * sin(arg)
    +
    110 polej = 1. + rmll * cos(arg)
    +
    111 ENDIF
    +
    112C
    +
    113C RADIUS TO THE I,J POINT (IN GRID UNITS)
    +
    114C YY REVERSED SO POSITIVE IS DOWN
    +
    115C
    +
    116 xx = xi - polei
    +
    117 yy = polej - xj
    +
    118 r2 = xx**2 + yy**2
    +
    119C
    +
    120C CHECK THAT THE REQUESTED I,J IS NOT IN THE FORBIDDEN ZONE
    +
    121C YY MUST BE POSITIVE UP FOR THIS TEST
    +
    122C
    +
    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
    +
    132C
    +
    133C NOW THE MAGIC FORMULAE
    +
    134C
    +
    135 IF (r2.EQ.0) THEN
    +
    136 alat = h * 90.0
    +
    137 elon = elonv
    +
    138 ELSE
    +
    139C
    +
    140C FIRST THE LONGITUDE
    +
    141C
    +
    142 elon = elonv + degprd * atan2(h*xx,yy)/an
    +
    143 elon = amod(elon+360., 360.)
    +
    144C
    +
    145C NOW THE LATITUDE
    +
    146C RECALCULATE THE THING ONLY IF MAP IS NEW SINCE LAST TIME
    +
    147C
    +
    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
    +
    156C
    +
    157C FOLLOWING TO ASSURE ERROR VALUES IF FIRST TIME THRU
    +
    158C IS OFF THE MAP
    +
    159C
    +
    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/w3fc02_8f.html b/w3fc02_8f.html index 65a31bef..292ba34f 100644 --- a/w3fc02_8f.html +++ b/w3fc02_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc02.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fc02.f File Reference
    +
    w3fc02.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Grid U,V wind comps.

    @@ -107,8 +113,8 @@

    Definition in file w3fc02.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fc02()

    + +

    ◆ w3fc02()

    @@ -117,37 +123,37 @@

    subroutine w3fc02 (   - FFID, + ffid,   - FFJD, + ffjd,   - FGU, + fgu,   - FGV, + fgv,   - DIR, + dir,   - SPD  + spd  @@ -192,7 +198,7 @@

    diff --git a/w3fc02_8f.js b/w3fc02_8f.js index e6c50c6e..34f1681a 100644 --- a/w3fc02_8f.js +++ b/w3fc02_8f.js @@ -1,4 +1,4 @@ var w3fc02_8f = [ - [ "w3fc02", "w3fc02_8f.html#a2572657557b50b4f9580f1cf204d7aaf", null ] + [ "w3fc02", "w3fc02_8f.html#aa7ac60b61ee09def3c2e5e2005575cec", null ] ]; \ No newline at end of file diff --git a/w3fc02_8f_source.html b/w3fc02_8f_source.html index 8f5aef45..c5be04ee 100644 --- a/w3fc02_8f_source.html +++ b/w3fc02_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc02.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,84 +81,92 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fc02.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Grid U,V wind comps. to dir. and speed.
    +
    3C> @author John Stackpole @date 1981-12-30
    +
    4
    +
    5C> Given the grid-oriented wind components on a northern
    +
    6C> hemisphere polar stereographic grid point, compute the direction
    +
    7C> and speed of the wind at that point. Input winds at the north
    +
    8C> pole point are assumed to have their components follow the wmo
    +
    9C> standards for reporting winds at the north pole.
    +
    10C> (see office note 241 for wmo definition). Output direction
    +
    11C> will follow wmo convention.
    +
    12C>
    +
    13C> Program history log:
    +
    14C> - John Stackpole 1981-12-30
    +
    15C> - Ralph Jones 1989-01-20 Convert to microsoft fortran 4.10.
    +
    16C> - Ralph Jones 1990-06-11 Convert to sun fortran 1.3.
    +
    17C> - Ralph Jones 1991-03-30 Convert to silicongraphics fortran.
    +
    18C> - Ralph Jones 1993-03-29 Add save statement.
    +
    19C> - Ralph Jones 1995-08-09 Compile on cray.
    +
    20C>
    +
    21C> @param[in] FFID REAL*4 I(north pole) - i(point).
    +
    22C> @param[in] FFJD REAL*4 J(north pole) - j(point).
    +
    23C> @param[in] FGU REAL*4 Grid-oriented u-component.
    +
    24C> @param[in] FGV REAL*4 Grid-oriented v-component.
    +
    25C>
    +
    26C> @param[out] DIR REAL*4 Wind direction, degrees.
    +
    27C> @param[out] SPD REAL*4 Wind speed.
    +
    28C>
    +
    29C> @note This job will not vectorize on a cray.
    +
    30C>
    +
    31C> @author John Stackpole @date 1981-12-30
    +
    +
    32 SUBROUTINE w3fc02(FFID,FFJD,FGU,FGV,DIR,SPD)
    +
    33C
    +
    34 SAVE
    +
    35C
    +
    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/w3fc05_8f.html b/w3fc05_8f.html index 5971fa3e..1087d575 100644 --- a/w3fc05_8f.html +++ b/w3fc05_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc05.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fc05.f File Reference
    +
    w3fc05.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fc05 (u, v, dir, spd)
     Given the true (Earth oriented) wind components compute the wind direction and speed.
     

    Detailed Description

    Earth U,V wind components to dir and spd.

    @@ -107,8 +113,8 @@

    Definition in file w3fc05.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fc05()

    + +

    ◆ w3fc05()

    @@ -117,25 +123,25 @@

    subroutine w3fc05 ( real  - U, + u, real  - V, + v, real  - DIR, + dir, real  - SPD  + spd  @@ -176,7 +182,7 @@

    diff --git a/w3fc05_8f.js b/w3fc05_8f.js index 09bb400a..2ea66bd7 100644 --- a/w3fc05_8f.js +++ b/w3fc05_8f.js @@ -1,4 +1,4 @@ var w3fc05_8f = [ - [ "w3fc05", "w3fc05_8f.html#ae77a21f468d05a34fa3a201c89b30530", null ] + [ "w3fc05", "w3fc05_8f.html#a2a855302ae772a201af2e93a43fa8fa9", null ] ]; \ No newline at end of file diff --git a/w3fc05_8f_source.html b/w3fc05_8f_source.html index ea1b4d15..4a1fe42e 100644 --- a/w3fc05_8f_source.html +++ b/w3fc05_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc05.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,72 +81,80 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fc05.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Earth U,V wind components to dir and spd.
    +
    3C> @author John Stackpole @date 1981-12-30
    +
    4
    +
    5C> Given the true (Earth oriented) wind components
    +
    6C> compute the wind direction and speed.
    +
    7C> Input winds at the pole are assumed to follow the WMO
    +
    8C> conventions, with the output direction computed in accordance
    +
    9C> with WMO standards for reporting winds at the pole.
    +
    10C> (see office note 241 for WMO definition.)
    +
    11C>
    +
    12C> Program history log:
    +
    13C> - John Stackpole 1981-12-30
    +
    14C> - P. Chase 1988-10-19 Allow output values to overlay input
    +
    15C> - Ralph Jones 1991-03-05 Changes for cray cft77 fortran
    +
    16C> - Dennis Keyser 1992-10-21 Added 1.e-3 to direction to allow truncation
    +
    17C> to nearest whole degree to be correct (keeps agreement between cray & nas versions)
    +
    18C>
    +
    19C> @param[in] U REAL Earth-oriented U-component.
    +
    20C> @param[in] V REAL Earth-oriented V-component.
    +
    21C> @param[out] DIR REAL Wind direction, degrees. Values will
    +
    22C> be from 0 to 360 inclusive.
    +
    23C> @param[out] SPD REAL Wind speed in same units as input.
    +
    24C>
    +
    25C> @note If speed is less than 1e-10 then direction will be set to zero.
    +
    26C>
    +
    27C> @author John Stackpole @date 1981-12-30
    +
    +
    28 SUBROUTINE w3fc05(U, V, DIR, SPD) 11700000
    +
    29C
    +
    30C VARIABLES.....
    +
    31C
    +
    32 REAL U, V, DIR, SPD, XSPD
    +
    33C
    +
    34C CONSTANTS.....
    +
    35C
    +
    36 DATA spdtst/1.0e-10/
    +
    37 DATA rtod /57.2957795/
    +
    38 DATA dchalf/180.0/
    +
    39C
    +
    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/w3fc06_8f.html b/w3fc06_8f.html index 46d497b9..395f1393 100644 --- a/w3fc06_8f.html +++ b/w3fc06_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc06.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fc06.f File Reference
    +
    w3fc06.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fc06 (dir, spd, u, v)
     Given the wind direction and speed, compute Earth-oriented (true) wind components.
     

    Detailed Description

    Wind dir and spd to Earth U,V components.

    @@ -107,8 +113,8 @@

    Definition in file w3fc06.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fc06()

    + +

    ◆ w3fc06()

    @@ -117,25 +123,25 @@

    subroutine w3fc06 (   - DIR, + dir,   - SPD, + spd,   - U, + u,   - V  + v  @@ -174,7 +180,7 @@

    diff --git a/w3fc06_8f.js b/w3fc06_8f.js index b0b8fe53..e160275d 100644 --- a/w3fc06_8f.js +++ b/w3fc06_8f.js @@ -1,4 +1,4 @@ var w3fc06_8f = [ - [ "w3fc06", "w3fc06_8f.html#a586eff5e859341d86f5ab00dbcca2169", null ] + [ "w3fc06", "w3fc06_8f.html#a4b85830235c80e0c007cba0d9e2ad7e8", null ] ]; \ No newline at end of file diff --git a/w3fc06_8f_source.html b/w3fc06_8f_source.html index 0ea588e6..6e5ebd5c 100644 --- a/w3fc06_8f_source.html +++ b/w3fc06_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc06.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,58 +81,66 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fc06.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Wind dir and spd to Earth U,V components.
    +
    3C> @author John Stackpole @date 1981-12-30
    +
    4
    +
    5C> Given the wind direction and speed,
    +
    6C> compute Earth-oriented (true) wind components.
    +
    7C> Input direction at the pole point
    +
    8C> must be consistent with WMO conventions, and output components
    +
    9C> will follow those conventions.
    +
    10C> (See office note 241 for WMO definition.)
    +
    11C>
    +
    12C> Program history log:
    +
    13C> - John Stackpole 1981-12-30
    +
    14C> - Ralph Jones 1991-03-06 Change to cray cft77 fortran.
    +
    15C>
    +
    16C> @param[in] DIR REAL*4 Wind direction, degrees
    +
    17C> @param[in] SPD REAL*4 Wind speed, any units
    +
    18C> @param[out] U REAL*4 Earth-oriented U-component.
    +
    19C> @param[out] V REAL*4 Earth-oriented V-component.
    +
    20C>
    +
    21C> @note This code will not vectorize on cray, you could
    +
    22C> put the four lines in your code with a couple of
    +
    23C> do loops.
    +
    24C>
    +
    25C> @author John Stackpole @date 1981-12-30
    +
    +
    26 SUBROUTINE w3fc06(DIR,SPD,U,V)
    +
    27C
    +
    28 xspd = -spd
    +
    29 dirl = 0.0174533 * dir
    +
    30 u = xspd * sin(dirl)
    +
    31 v = xspd * cos(dirl)
    +
    32C
    +
    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/w3fc07_8f.html b/w3fc07_8f.html index 5faf2e34..c2800c4c 100644 --- a/w3fc07_8f.html +++ b/w3fc07_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc07.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fc07.f File Reference
    +
    w3fc07.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Grid U-V to Earth U-V in north hem.

    @@ -107,8 +113,8 @@

    Definition in file w3fc07.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fc07()

    + +

    ◆ w3fc07()

    @@ -117,37 +123,37 @@

    subroutine w3fc07 (   - FFID, + ffid,   - FFJD, + ffjd,   - FGU, + fgu,   - FGV, + fgv,   - FU, + fu,   - FV  + fv  @@ -189,7 +195,7 @@

    diff --git a/w3fc07_8f.js b/w3fc07_8f.js index 00a51eae..10e8678a 100644 --- a/w3fc07_8f.js +++ b/w3fc07_8f.js @@ -1,4 +1,4 @@ var w3fc07_8f = [ - [ "w3fc07", "w3fc07_8f.html#a84dac72c47bb275c7c251c620052b54d", null ] + [ "w3fc07", "w3fc07_8f.html#aa2d422861395fb930f4a8a235beb5735", null ] ]; \ No newline at end of file diff --git a/w3fc07_8f_source.html b/w3fc07_8f_source.html index 8feb814d..a51fb7bd 100644 --- a/w3fc07_8f_source.html +++ b/w3fc07_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc07.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,78 +81,86 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fc07.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Grid U-V to Earth U-V in north hem.
    +
    3C> @author John Stackpole @date 1981-12-30
    +
    4
    +
    5C> Given the grid-oriented wind components on a northern
    +
    6C> hemisphere polar stereographic grid point, compute the Earth-
    +
    7C> oriented wind components at that point. If the input winds
    +
    8C> are at the north pole, the output components will be made
    +
    9C> consistent with the WMO standards for reporting winds at the
    +
    10C> north pole. (see office note 241 for WMO definition.)
    +
    11C>
    +
    12C> Program history log:
    +
    13C> - John Stackpole 1981-12-30
    +
    14C> - P. Chase 1988-10-13 Allow input and output to be the same
    +
    15C> - Ralph Jones 1991-03-06 Change to cray cft77 fortran
    +
    16C>
    +
    17C> @param[in] FFID REAL I-displacement from point to north pole
    +
    18C> @param[in] FFJD REAL J-displacement from point to north pole
    +
    19C> @param[in] FGV REAL Grid-oriented V-component
    +
    20C> @param[in] FGU REAL Grid-oriented U-component
    +
    21C> @param[out] FU REAL Earth-oriented U-component, positive from west
    +
    22C> may reference the same location as FGU.
    +
    23C> @param[out] FV REAL Earth-oriented V-component, positive from south
    +
    24C> may reference the same location as FGV.
    +
    25C>
    +
    26C> @note Calculate FFID and FFJD as follows...
    +
    27C> FFID = real(ip - i)
    +
    28C> FFJD = real(jp - j)
    +
    29C> where (ip,jp) is the grid coordinates of the north pole and
    +
    30C> (i,j) is the grid coordinates of the point where FGU and FGV
    +
    31C> occur. See w3fc11 for a southern hemisphere companion subroutine.
    +
    32C>
    +
    33C> @author John Stackpole @date 1981-12-30
    +
    +
    34 SUBROUTINE w3fc07(FFID, FFJD, FGU, FGV, FU, FV)
    +
    35C
    +
    36 SAVE
    +
    37C
    +
    38 DATA cos80 / 0.1736482 /
    +
    39 DATA sin80 / 0.9848078 /
    +
    40
    +
    41C COS80 AND SIN80 ARE FOR WIND AT POLE
    +
    42C (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/w3fc08_8f.html b/w3fc08_8f.html index 1e0a0eb0..ba79dca8 100644 --- a/w3fc08_8f.html +++ b/w3fc08_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc08.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fc08.f File Reference
    +
    w3fc08.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    U-V Comps from Earth to north hem grid.

    @@ -107,8 +113,8 @@

    Definition in file w3fc08.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fc08()

    + +

    ◆ w3fc08()

    @@ -117,37 +123,37 @@

    subroutine w3fc08 (   - FFID, + ffid,   - FFJD, + ffjd,   - FU, + fu,   - FV, + fv,   - FGU, + fgu,   - FGV  + fgv  @@ -189,7 +195,7 @@

    diff --git a/w3fc08_8f.js b/w3fc08_8f.js index 46d4f162..8ae5a43a 100644 --- a/w3fc08_8f.js +++ b/w3fc08_8f.js @@ -1,4 +1,4 @@ var w3fc08_8f = [ - [ "w3fc08", "w3fc08_8f.html#ac768b413af58dd51c57c6bf6d2d48a84", null ] + [ "w3fc08", "w3fc08_8f.html#ab866267da1ef5f8208ffe29f38590b6c", null ] ]; \ No newline at end of file diff --git a/w3fc08_8f_source.html b/w3fc08_8f_source.html index 2589e026..746ecd7c 100644 --- a/w3fc08_8f_source.html +++ b/w3fc08_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fc08.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,80 +81,88 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fc08.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief U-V Comps from Earth to north hem grid.
    +
    3C> @author John Stackpole @date 1981-12-30
    +
    4
    +
    5C> Given the Earth-oriented wind components on a northern
    +
    6C> hemisphere polar stereographic grid point, compute the grid-
    +
    7C> oriented components at that point. Input wind components at the
    +
    8C> north pole point are assumed to conform to
    +
    9C> the 'WMO' standards for reporting winds at the north pole, with
    +
    10C> the output components computed relative to the X-Y axes on the
    +
    11C> grid. (see office note 241 for WMO definition.)
    +
    12C>
    +
    13C> Program history log:
    +
    14C> - John Stackpole 1981-12-30
    +
    15C> - P. Chase 1988-10-18 Let output variables overlay input.
    +
    16C> - Ralph Jones 1991-03-06 Change to cray cft77 fortran.
    +
    17C>
    +
    18C> @param[in] FFID REAL I-displacement from point to north pole in
    +
    19C> grid units.
    +
    20C> @param[in] FFJD REAL J-displacement from point to north pole in
    +
    21C> grid units.
    +
    22C> @param[in] FU REAL Earth-oriented u-component, positive from west.
    +
    23C> @param[in] FV REAL Earth-oriented v-component, positive from east.
    +
    24C> @param[out] FGU REAL Grid-oriented u-component. May reference
    +
    25C> same location as FU.
    +
    26C> @param[out] FGV REAL Grid-oriented v-component. May reference
    +
    27C> same location as FV.
    +
    28C>
    +
    29C> @note FFID and FFJD may be calculated as followS.....
    +
    30C> FFID = real(ip - i)
    +
    31C> FFJD = real(jp - j)
    +
    32C> where (ip, jp) are the grid coordinates of the north pole and
    +
    33C> (i,j) are the grid coordinates of the point.
    +
    34C>
    +
    35C> @author John Stackpole @date 1981-12-30
    +
    +
    36 SUBROUTINE w3fc08(FFID, FFJD, FU, FV, FGU, FGV)
    +
    37C
    +
    38 SAVE
    +
    39C
    +
    40 DATA cos280/ 0.1736482 /
    +
    41 DATA sin280/ -0.9848078 /
    +
    42C
    +
    43C COS280 AND SIN280 ARE FOR WIND AT POLE
    +
    44C (USED FOR CO-ORDINATE ROTATION TO GRID ORIENTATION)
    +
    45C
    +
    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/w3fi01_8f.html b/w3fi01_8f.html index c9759a72..14544d0a 100644 --- a/w3fi01_8f.html +++ b/w3fi01_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi01.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi01.f File Reference
    +
    w3fi01.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi01 (lw)
     Determines the number of bytes in a full word for the particular machine (IBM or cray).
     

    Detailed Description

    Determines machine word length in bytes.

    @@ -107,8 +113,8 @@

    Definition in file w3fi01.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi01()

    + +

    ◆ w3fi01()

    @@ -117,7 +123,7 @@

    subroutine w3fi01 ( integer  - LW) + lw) @@ -144,7 +150,7 @@

    diff --git a/w3fi01_8f.js b/w3fi01_8f.js index d85c57cf..1c2c567f 100644 --- a/w3fi01_8f.js +++ b/w3fi01_8f.js @@ -1,4 +1,4 @@ var w3fi01_8f = [ - [ "w3fi01", "w3fi01_8f.html#a10ac20498f7eca8e2281cad1218bede4", null ] + [ "w3fi01", "w3fi01_8f.html#a45d73d5e35cbbe33e27e9c11684ca491", null ] ]; \ No newline at end of file diff --git a/w3fi01_8f_source.html b/w3fi01_8f_source.html index 9e835e23..03911368 100644 --- a/w3fi01_8f_source.html +++ b/w3fi01_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi01.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,48 +81,56 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi01.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Determines machine word length in bytes.
    +
    3C> @author R. Kistler @date 1992-01-10
    +
    4
    +
    5C> Determines the number of bytes in a full word for the
    +
    6C> particular machine (IBM or cray).
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - R. Kistler 1992-01-10
    +
    10C> - Dennis Keyser 1992-05-22 Docblocked/commented.
    +
    11C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    12C> - Stephen Gilbert 2001-06-07 Uses f90 standard routine bit_size to
    +
    13C> find integer word length
    +
    14C>
    +
    15C> @note Subprogram can be called from a multiprocessing environment.
    +
    16C>
    +
    17C> @author R. Kistler @date 1992-01-10
    +
    +
    18 SUBROUTINE w3fi01(LW)
    +
    19C
    +
    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/w3fi02_8f.html b/w3fi02_8f.html index 7daa3703..763ef2db 100644 --- a/w3fi02_8f.html +++ b/w3fi02_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi02.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi02.f File Reference
    +
    w3fi02.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi02 (in, idest, num)
     Transfers an array of numbers from 16 bit (ibm integer*2) IBM half-words to default integers.
     

    Detailed Description

    Transfers array from 16 to 64 bit words.

    @@ -107,8 +113,8 @@

    Definition in file w3fi02.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi02()

    + +

    ◆ w3fi02()

    @@ -117,19 +123,19 @@

    subroutine w3fi02 ( integer(2), dimension(*)  - IN, + in, integer, dimension(*)  - IDEST, + idest,   - NUM  + num  @@ -166,7 +172,7 @@

    diff --git a/w3fi02_8f.js b/w3fi02_8f.js index abebf9de..8b5f2476 100644 --- a/w3fi02_8f.js +++ b/w3fi02_8f.js @@ -1,4 +1,4 @@ var w3fi02_8f = [ - [ "w3fi02", "w3fi02_8f.html#a217b3130b7e509776b74fde620e5b715", null ] + [ "w3fi02", "w3fi02_8f.html#a12ce6be899705cebb27f675ef5413353", null ] ]; \ No newline at end of file diff --git a/w3fi02_8f_source.html b/w3fi02_8f_source.html index 926f259a..2b5966ea 100644 --- a/w3fi02_8f_source.html +++ b/w3fi02_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi02.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,54 +81,62 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi02.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Transfers array from 16 to 64 bit words.
    +
    3C> @author Dennis Keyser @date 1992-06-29
    +
    4
    +
    5C> Transfers an array of numbers from 16 bit (ibm integer*2)
    +
    6C> IBM half-words to default integers.
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - Dennis Keyser 1992-06-29
    +
    10C> - Stephen Gilbert 1998-11-17 Removed Cray references.
    +
    11C>
    +
    12C> @param[in] IN Starting address for array of 16 bit IBM half-words.
    +
    13C> @param[in] NUM Number of numbers in 'IN' to transfer.
    +
    14C> @param[out] IDEST Starting address for array of output integers.
    +
    15C>
    +
    16C> @note This is the inverse of library routine w3fi03.
    +
    17C>
    +
    18C> @author Dennis Keyser @date 1992-06-29
    +
    +
    19 SUBROUTINE w3fi02(IN,IDEST,NUM)
    +
    20C
    +
    21 INTEGER(2) IN(*)
    +
    22 INTEGER IDEST(*)
    +
    23C
    +
    24 SAVE
    +
    25C
    +
    26C CALL USICTC(IN,1,IDEST,NUM,2)
    +
    27 idest(1:num)=in(1:num)
    +
    28C
    +
    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/w3fi03_8f.html b/w3fi03_8f.html index c39643d9..fb77043b 100644 --- a/w3fi03_8f.html +++ b/w3fi03_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi03.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi03.f File Reference
    +
    w3fi03.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi03 (in, idest, num, ier)
     Transfers an array of numbers from default integer words to 16 bit (IBM integer*2) IBM half-words.
     

    Detailed Description

    Transfers default integers to 16 bit ints.

    @@ -107,8 +113,8 @@

    Definition in file w3fi03.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi03()

    + +

    ◆ w3fi03()

    @@ -117,25 +123,25 @@

    subroutine w3fi03 ( integer, dimension(*)  - IN, + in, integer(2), dimension(*)  - IDEST, + idest,   - NUM, + num,   - IER  + ier  @@ -163,7 +169,7 @@

    Note
    This is the inverse of library routine w3fi02().
    +
    Note
    This is the inverse of library routine w3fi02().
    Author
    Dennis Keyser
    Date
    1992-06-29
    @@ -177,7 +183,7 @@

    diff --git a/w3fi03_8f.js b/w3fi03_8f.js index 8b9795b2..e803625f 100644 --- a/w3fi03_8f.js +++ b/w3fi03_8f.js @@ -1,4 +1,4 @@ var w3fi03_8f = [ - [ "w3fi03", "w3fi03_8f.html#a3cfc13ff3a45dea4c4f6f7c1832df3d3", null ] + [ "w3fi03", "w3fi03_8f.html#a875772e1917cd6bf73eabca330b517de", null ] ]; \ No newline at end of file diff --git a/w3fi03_8f_source.html b/w3fi03_8f_source.html index 3ccb01ca..b84c366d 100644 --- a/w3fi03_8f_source.html +++ b/w3fi03_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi03.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,59 +81,67 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi03.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Transfers default integers to 16 bit ints.
    +
    3C> @author Dennis Keyser @date 1992-06-29
    +
    4
    +
    5C> Transfers an array of numbers from default integer
    +
    6C> words to 16 bit (IBM integer*2) IBM half-words.
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - Dennis Keyser 1992-06-29
    +
    10C> - Stephen Gilbert 1998-11-17 Removed Cray references.
    +
    11C>
    +
    12C> @param[in] IN Starting address for array of default integers
    +
    13C> @param[in] NUM Number of numbers in 'IN' to transfer.
    +
    14C> @param[out] IDEST Starting address for array of 16 bit IBM half-words
    +
    15C> @param[out] IER Error return code as follows:
    +
    16C> IER = 0 - Transfer successful, all numbers
    +
    17C> - Transferred without overflow.
    +
    18C> IER = 1 - The transfer of one or more numbers
    +
    19C> - Resulted in an overflow.
    +
    20C>
    +
    21C> @note This is the inverse of library routine w3fi02().
    +
    22C>
    +
    23C> @author Dennis Keyser @date 1992-06-29
    +
    +
    24 SUBROUTINE w3fi03(IN,IDEST,NUM,IER)
    +
    25C
    +
    26 INTEGER(2) IDEST(*)
    +
    27 INTEGER IN(*)
    +
    28C
    +
    29 SAVE
    +
    30C
    +
    31C CALL USICTI(IN,IDEST,1,NUM,2,IER)
    +
    32 idest(1:num)=in(1:num)
    +
    33C
    +
    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/w3fi04_8f.html b/w3fi04_8f.html index 629ffd46..6ae25a4c 100644 --- a/w3fi04_8f.html +++ b/w3fi04_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi04.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi04.f File Reference
    +
    w3fi04.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Find word size, endian, character set.

    @@ -107,8 +113,8 @@

    Definition in file w3fi04.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi04()

    + +

    ◆ w3fi04()

    @@ -117,19 +123,19 @@

    subroutine w3fi04 ( integer  - IENDN, + iendn, integer  - ITYPEC, + itypec, integer  - LW  + lw  @@ -180,7 +186,7 @@

    diff --git a/w3fi04_8f.js b/w3fi04_8f.js index 3918385d..80d34a70 100644 --- a/w3fi04_8f.js +++ b/w3fi04_8f.js @@ -1,4 +1,4 @@ var w3fi04_8f = [ - [ "w3fi04", "w3fi04_8f.html#a43d8dd578a2f24d52b45332ed3ccc6c9", null ] + [ "w3fi04", "w3fi04_8f.html#a59af48612285f36dae46e14f4b0e8a85", null ] ]; \ No newline at end of file diff --git a/w3fi04_8f_source.html b/w3fi04_8f_source.html index d29508fc..492e2321 100644 --- a/w3fi04_8f_source.html +++ b/w3fi04_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi04.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,137 +81,145 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi04.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Find word size, endian, character set.
    +
    3C> @author Ralph Jones @date 1994-10-07
    +
    4
    +
    5C> Subroutine computes word size, the type of character
    +
    6C> set, ASCII or EBCDIC, and if the computer is big-endian, or
    +
    7C> little-endian.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Relph Jones 1994-10-07
    +
    11C> - Stephen Gilbert 1998-07-08 Removed the Fortran SAVE Statement.
    +
    12C> The SAVE statement is not needed for this outine, and may have been
    +
    13C> causing errors using the f90 compiler under the 2.0 Programming Environment.
    +
    14C> - Boi Vuong 2002-10-15 Replaced Function ICHAR with mova2i
    +
    15C>
    +
    16C> @param[out] IENDN Integer for big-endian or little-endian
    +
    17C> - =0 big-endian
    +
    18C> - =1 little-endian
    +
    19C> - =2 cannot compute
    +
    20C> @param[out] ITYPEC Integer for type of character set
    +
    21C> - =0 ASCII character set
    +
    22C> - =1 EBCDIC character set
    +
    23C> - =2 not ASCII or EBCDIC
    +
    24C> @param[out] LW Integer for words size of computer in bytes
    +
    25C> - =4 for 32 bit computers
    +
    26C> - =8 for 64 bit computers
    +
    27C>
    +
    28C> @author Ralph Jones @date 1994-10-07
    +
    +
    29 SUBROUTINE w3fi04(IENDN,ITYPEC,LW)
    +
    30C
    +
    31 INTEGER ITEST1
    +
    32 INTEGER ITEST2
    +
    33 INTEGER ITEST3
    +
    34 INTEGER IENDN
    +
    35 INTEGER ITYPEC
    +
    36 INTEGER LW
    +
    37C
    +
    38 CHARACTER * 8 CTEST1
    +
    39 CHARACTER * 8 CTEST2
    +
    40 CHARACTER * 1 CTEST3(8)
    +
    41 CHARACTER * 1 BLANK
    +
    42C
    +
    43 equivalence(ctest1,itest1),(ctest2,itest2)
    +
    44C
    +
    45 equivalence(itest3,ctest3(1))
    +
    46C
    +
    47 DATA ctest1/'12345678'/
    +
    48 DATA itest3/z'01020304'/
    +
    49 DATA blank /' '/
    +
    50C
    +
    51C SAVE
    +
    52C
    +
    53C TEST FOR TYPE OF CHARACTER SET
    +
    54C BLANK IS 32 (20 HEX) IN ASCII, 64 (40 HEX) IN EBCDEC
    +
    55C
    +
    56 IF (mova2i(blank).EQ.32) THEN
    +
    57 itypec = 0
    +
    58 ELSE IF (mova2i(blank).EQ.64) THEN
    +
    59C
    +
    60C COMPUTER IS PROBABLY AN IBM360, 370, OR 390 WITH
    +
    61C A 32 BIT WORD SIZE, AND BIG-ENDIAN.
    +
    62C
    +
    63 itypec = 1
    +
    64 ELSE
    +
    65 itypec = 2
    +
    66 END IF
    +
    67C
    +
    68C TEST FOR WORD SIZE, SET LW TO 4 FOR 32 BIT COMPUTER,
    +
    69C 8 FOR FOR 64 BIT COMPUTERS
    +
    70C
    +
    71 itest2 = itest1
    +
    72 IF (ctest1 .EQ. ctest2) THEN
    +
    73C
    +
    74C COMPUTER MAY BE A CRAY, OR COULD BE DEC VAX ALPHA
    +
    75C OR SGI WITH R4000, R4400, R8800 AFTER THEY CHANGE
    +
    76C FORTRAN COMPILERS FOR 64 BIT INTEGER.
    +
    77C
    +
    78 lw = 8
    +
    79 ELSE
    +
    80 lw = 4
    +
    81 ENDIF
    +
    82C
    +
    83C USING ITEST3 WITH Z'01020304' EQUIVALNCED TO CTEST3
    +
    84C ON A 32 BIT BIG-ENDIAN COMPUTER 03 IS IN THE 3RD
    +
    85C BYTE OF A 4 BYTE WORD. ON A 32 BIT LITTLE-ENDIAN
    +
    86C COMPUTER IT IS IN 2ND BYTE.
    +
    87C ON A 64 BIT COMPUTER Z'01020304' IS RIGHT ADJUSTED IN
    +
    88C A 64 BIT WORD, 03 IS IN THE 7TH BYTE. ON A LITTLE-
    +
    89C ENDIAN 64 BIT COMPUTER IT IS IN THE 2ND BYTE.
    +
    90C
    +
    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
    +
    110C
    +
    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/w3fi18_8f.html b/w3fi18_8f.html index b71c6575..44d46d05 100644 --- a/w3fi18_8f.html +++ b/w3fi18_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi18.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi18.f File Reference
    +
    w3fi18.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    NMC octagon boundary finding subroutine.

    @@ -107,8 +113,8 @@

    Definition in file w3fi18.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi18()

    + +

    ◆ w3fi18()

    @@ -117,19 +123,19 @@

    subroutine w3fi18 (   - I, + i,   - J, + j,   - NW  + nw  @@ -174,7 +180,7 @@

    diff --git a/w3fi18_8f.js b/w3fi18_8f.js index 5a68dd41..f840ba9f 100644 --- a/w3fi18_8f.js +++ b/w3fi18_8f.js @@ -1,4 +1,4 @@ var w3fi18_8f = [ - [ "w3fi18", "w3fi18_8f.html#a684daaf76526713839d9d702a2c8aff7", null ] + [ "w3fi18", "w3fi18_8f.html#a3e60fdacb75b639d8e444a507259a1e8", null ] ]; \ No newline at end of file diff --git a/w3fi18_8f_source.html b/w3fi18_8f_source.html index 7c6a9c01..41548312 100644 --- a/w3fi18_8f_source.html +++ b/w3fi18_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi18.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,71 +81,79 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi18.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief NMC octagon boundary finding subroutine.
    +
    3C> @author James Howcroft @date 1973-10-15
    +
    4
    +
    5C> Relates the I,J coordinate point in a 65x65 grid-point
    +
    6C> array as being either inside, outside, or on the boundary of the
    +
    7C> NMC octagon centered in the 65x65 array.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - James Howcroft 1973-10-15
    +
    11C> - Ralph Jones 1984-07-02 Convert to fortran 77.
    +
    12C> - Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10.
    +
    13C> - Ralph Jones 1990-06-12 Convert to sun fortran 1.3.
    +
    14C> - Ralph Jones 1991-03-16 Convert to silicongraphics 3.3 fortran 77.
    +
    15C> - Ralph Jones 1993-03-29 Add save statement.
    +
    16C>
    +
    17C> @param[in] I Coordinate identification of a point in the 65x65 array.
    +
    18C> @param[in] J Coordinate identification of a point in the 65x65 array.
    +
    19C> @param[out] NW Integer return code.
    +
    20C>
    +
    21C> Exit states:
    +
    22C> - NW = -1 Point is outside the octagon.
    +
    23C> - NW = 0 Point is on the octagon boundary.
    +
    24C> - NW = +1 Point is inside the octagon.
    +
    25C>
    +
    26C> @author James Howcroft @date 1973-10-15
    +
    +
    27 SUBROUTINE w3fi18(I,J,NW)
    +
    28C
    +
    29 SAVE
    +
    30C
    +
    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
    +
    39C
    +
    40 10 CONTINUE
    +
    41 nw = -1
    +
    42 RETURN
    +
    43C
    +
    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/w3fi19_8f.html b/w3fi19_8f.html index 5963f1c5..3c91d23f 100644 --- a/w3fi19_8f.html +++ b/w3fi19_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi19.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi19.f File Reference
    +
    w3fi19.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    NMC Rectangle boundary finding subroutine.

    @@ -107,8 +113,8 @@

    Definition in file w3fi19.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi19()

    + +

    ◆ w3fi19()

    @@ -117,19 +123,19 @@

    subroutine w3fi19 (   - I, + i,   - J, + j,   - NW  + nw  @@ -174,7 +180,7 @@

    diff --git a/w3fi19_8f.js b/w3fi19_8f.js index 892d02c0..ba879ed4 100644 --- a/w3fi19_8f.js +++ b/w3fi19_8f.js @@ -1,4 +1,4 @@ var w3fi19_8f = [ - [ "w3fi19", "w3fi19_8f.html#afcb6e01340c836fbd0f940b8c0e6814f", null ] + [ "w3fi19", "w3fi19_8f.html#a4eef5192d8f6d23e77aef025680f7b9f", null ] ]; \ No newline at end of file diff --git a/w3fi19_8f_source.html b/w3fi19_8f_source.html index f11b46f8..7b23bdaf 100644 --- a/w3fi19_8f_source.html +++ b/w3fi19_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi19.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,67 +81,75 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi19.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief NMC Rectangle boundary finding subroutine.
    +
    3C> @author James Howcroft @date 1973-10-15
    +
    4
    +
    5C> Relates the I,J coordinate point in a 65x65 grid-point
    +
    6C> array as being either inside, outside, or on the boundary of the
    +
    7C> 53x57 NMC rectangle centered in the 65x65 array.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - James Howcroft 1973-10-15
    +
    11C> - Ralph Jones 1984-07-02 Convert to fortran 77.
    +
    12C> - Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10.
    +
    13C> - Ralph Jones 1990-06-12 Convert to sun fortran 1.3.
    +
    14C> - Ralph Jones 1991-03-16 Convert to silicongraphics 3.3 fortran 77.
    +
    15C> - Ralph Jones 1993-03-29 Add save statement.
    +
    16C>
    +
    17C> @param[in] I Coordinate identification of a point in the 65x65 array.
    +
    18C> @param[in] J Coordinate identification of a point in the 65x65 array.
    +
    19C> @param[out] NW Integer return code.
    +
    20C>
    +
    21C> Exit states:
    +
    22C> - NW = -1 Point is outside the rectangle.
    +
    23C> - NW = 0 Point is on the rectangle boundary.
    +
    24C> - NW = +1 Point is inside the rectangle.
    +
    25C>
    +
    26C> @author James Howcroft @date 1973-10-15
    +
    +
    27 SUBROUTINE w3fi19(I,J,NW)
    +
    28C
    +
    29 SAVE
    +
    30C
    +
    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
    +
    35C
    +
    36 10 CONTINUE
    +
    37 nw = -1
    +
    38 RETURN
    +
    39C
    +
    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/w3fi20_8f.html b/w3fi20_8f.html index 9efd1724..59921e1f 100644 --- a/w3fi20_8f.html +++ b/w3fi20_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi20.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi20.f File Reference
    +
    w3fi20.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi20 (a, b)
     Extracts the NMC 1977 point octagon grid points out of a 65x65 (4225 point) array.
     

    Detailed Description

    Cut a 65 x 65 grid to a nmc 1977 point grid.

    @@ -107,8 +113,8 @@

    Definition in file w3fi20.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi20()

    + +

    ◆ w3fi20()

    @@ -117,13 +123,13 @@

    subroutine w3fi20 ( real, dimension(*)  - A, + a, real, dimension(*)  - B  + b  @@ -163,7 +169,7 @@

    diff --git a/w3fi20_8f.js b/w3fi20_8f.js index baf56fa7..151b4b45 100644 --- a/w3fi20_8f.js +++ b/w3fi20_8f.js @@ -1,4 +1,4 @@ var w3fi20_8f = [ - [ "w3fi20", "w3fi20_8f.html#a4d5864f48a1b0a2c1223f3dd4a06059f", null ] + [ "w3fi20", "w3fi20_8f.html#a9ef932fe706763c5afc84a7c6797d415", null ] ]; \ No newline at end of file diff --git a/w3fi20_8f_source.html b/w3fi20_8f_source.html index 09893aa5..b517b22a 100644 --- a/w3fi20_8f_source.html +++ b/w3fi20_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi20.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,84 +81,92 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi20.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Cut a 65 x 65 grid to a nmc 1977 point grid.
    +
    3C> @author Ralph Jones @date 1984-07-02
    +
    4
    +
    5C> Extracts the NMC 1977 point octagon grid points out of
    +
    6C> a 65x65 (4225 point) array.
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - Ralph Jones 1973-06-15
    +
    10C> - Ralph Jones 1984-07-02 Convert to vs fortran
    +
    11C> - Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10
    +
    12C> - Ralph Jones 1990-08-22 Convert to sun fortran 1.3
    +
    13C> - Ralph Jones 1991-03-29 Convert to silicongraphics fortran
    +
    14C> - Ralph Jones 1993-03-29 Add save statement
    +
    15C>
    +
    16C> @param[in] A REAL*4 (65 x 65 grid, 4225 point) array
    +
    17C> grid is office note 84 type 27 or 1b hex.
    +
    18C> @param[out] B 1977 point array (octagon) office note 84 type
    +
    19C> 0 or hex 0.
    +
    20C>
    +
    21C> @note Arrays A and B may be the same array or be equivalenced,
    +
    22C> in which case the first 1977 words of 'A' are written over.
    +
    23C>
    +
    24C> @author Ralph Jones @date 1984-07-02
    +
    +
    25 SUBROUTINE w3fi20(A,B)
    +
    26C
    +
    27 REAL A(*)
    +
    28 REAL B(*)
    +
    29C
    +
    30 INTEGER RB
    +
    31 INTEGER LBR(51)
    +
    32 INTEGER RBR(51)
    +
    33C
    +
    34 SAVE
    +
    35C
    +
    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/
    +
    40C
    +
    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/
    +
    45C
    +
    46 n = 0
    +
    47C
    +
    48 DO 200 i = 1,51
    +
    49 lb = lbr(i)
    +
    50 rb = rbr(i)
    +
    51C
    +
    52 DO 100 j = lb,rb
    +
    53 n = n + 1
    +
    54 b(n) = a(j)
    +
    55 100 CONTINUE
    +
    56C
    +
    57 200 CONTINUE
    +
    58C
    +
    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/w3fi32_8f.html b/w3fi32_8f.html index 168bbb32..e6b92f4a 100644 --- a/w3fi32_8f.html +++ b/w3fi32_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi32.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi32.f File Reference
    +
    w3fi32.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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).
     

    Detailed Description

    Pack id's into office note 84 format.

    @@ -107,8 +113,8 @@

    Definition in file w3fi32.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi32()

    + +

    ◆ w3fi32()

    @@ -117,13 +123,13 @@

    subroutine w3fi32 ( integer(8), dimension(27)  - LARRAY, + larray, integer(8), dimension(*)  - KIDNT  + kidnt  @@ -145,7 +151,7 @@

    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.
    [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.
    @@ -165,7 +171,7 @@

    diff --git a/w3fi32_8f.js b/w3fi32_8f.js index 34c294c7..42a29658 100644 --- a/w3fi32_8f.js +++ b/w3fi32_8f.js @@ -1,4 +1,4 @@ var w3fi32_8f = [ - [ "w3fi32", "w3fi32_8f.html#a28af7a8a671a5e22f09ba6f371a348db", null ] + [ "w3fi32", "w3fi32_8f.html#a873077240f7b409fea74580cbfed49ad", null ] ]; \ No newline at end of file diff --git a/w3fi32_8f_source.html b/w3fi32_8f_source.html index d7faae1e..ac7ab5d7 100644 --- a/w3fi32_8f_source.html +++ b/w3fi32_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi32.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,164 +81,172 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi32.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Pack id's into office note 84 format.
    +
    3C> @author Alan Nierow @date 1986-02-07
    +
    4
    +
    5C> Converts an array of the 27 data field identifiers into
    +
    6C> an array of the first 8 identification words of the format de-
    +
    7C> scribed in NMC office note 84 (89-06-15, page-35). On a cray
    +
    8C> they will fit into four 64 bit integer words.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Alan Nierow 1986-02-07
    +
    12C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
    +
    13C> - Ralph Jones 1991-03-19 Changes for big records.
    +
    14C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    15C> - Stephen Gilbert 1999-03-15 Specified 8-byte integer array explicitly.
    +
    16C>
    +
    17C> @param[in] LARRAY Integer array containing 27 data field
    +
    18C> identifiers (see o.n. 84)
    +
    19C> @param[out] KIDNT Integer array of 6 words, 12 office note 84 32 bit
    +
    20C> words, first 4 words are made by w3fi32(), if you are
    +
    21C> using packer w3ai00(), it will compute word 5 and 6.
    +
    22C> (office note 84 words 9,10, 11 and 12). If J the
    +
    23C> word count in word 27 of LARRAY is greater than
    +
    24C> 32743 then bits 15-0 of the 4th ID word are set to
    +
    25C> zero, J is stored in bits 31-0 of the 6th ID word.
    +
    26C> ID word 5 is set zero, bit 63-32 of the 6th ID
    +
    27C> word are set zero.
    +
    28C> @note bis are number left to right on the cray as 63-0.
    +
    29C>
    +
    30C> @note Exit states printed messages:
    +
    31C> If any number n in (LARRAY(i),i=1,27) is erroneously large:
    +
    32C> 'value in LARRAY(i)=n is too large to pack'
    +
    33C> if any number n in (LARRAY(i),i=1,27) is erroneously negative:
    +
    34C> 'value in LARRAY(i)=n should not be negative'
    +
    35C> in either of the above situations, that portion of the packed
    +
    36C> word corresponding to LARRAY(i) will be set to binary ones.
    +
    37C>
    +
    38C> @author Alan Nierow @date 1986-02-07
    +
    +
    39 SUBROUTINE w3fi32(LARRAY,KIDNT)
    +
    40C
    +
    41 INTEGER(8) LARRAY(27)
    +
    42 INTEGER(8) ITABLE(27)
    +
    43 INTEGER(8) KIDNT(*)
    +
    44 INTEGER(8) KX,MASK,MASK16,ISC,ITEMP8
    +
    45C
    +
    46 SAVE
    +
    47C
    +
    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'/
    +
    65C
    +
    66C MAKE KIDNT = 0
    +
    67C
    +
    68 DO 10 i = 1,4
    +
    69 kidnt(i) = 0
    +
    70 10 CONTINUE
    +
    71C
    +
    72 isign = 0
    +
    73C
    +
    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)
    +
    80C
    +
    81C SIGN TEST
    +
    82C
    +
    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
    +
    90C
    +
    91 30 CONTINUE
    +
    92 iv = iabs(iv)
    +
    93 msign = 1
    +
    94 isign = msign
    +
    95 k = i2 / 4
    +
    96C
    +
    97 DO 40 m = 1,k
    +
    98 isign = ishft(isign,4)
    +
    99 40 CONTINUE
    +
    100C
    +
    101 isign = ishft(isign,-1)
    +
    102 iv = ior(iv,isign)
    +
    103C
    +
    104 50 CONTINUE
    +
    105C
    +
    106C MAG TEST
    +
    107C
    +
    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',/)
    +
    113C
    +
    114 70 CONTINUE
    +
    115 iv = kx
    +
    116 ia = 32 - i2
    +
    117 iv = ishft(iv,-ia)
    +
    118C
    +
    119C SHIFT
    +
    120C
    +
    121 80 CONTINUE
    +
    122 itemp=ishft(iv,i3)
    +
    123 itemp8=itemp
    +
    124 kidnt(i1) = ior(kidnt(i1),itemp8)
    +
    125C
    +
    126 90 CONTINUE
    +
    127C
    +
    128C TEST FOR BIG RECORDS, STORE J THE WORD COUNT IN THE 6TH
    +
    129C ID WORD IF GREATER THAN 32743.
    +
    130C
    +
    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
    +
    138C
    +
    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/w3fi47_8f.html b/w3fi47_8f.html index 1c2d7127..249900cc 100644 --- a/w3fi47_8f.html +++ b/w3fi47_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi47.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi47.f File Reference
    +
    w3fi47.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi47 (ilabel, nlabel)
     Converts a office note 85 label in IBM370 format to office note 85 cray format.
     

    Detailed Description

    Convert label to off.

    @@ -107,8 +113,8 @@

    Definition in file w3fi47.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi47()

    + +

    ◆ w3fi47()

    @@ -117,13 +123,13 @@

    subroutine w3fi47 ( character*1, dimension(32)  - ILABEL, + ilabel, character*1, dimension(32)  - NLABEL  + nlabel  @@ -160,7 +166,7 @@

    diff --git a/w3fi47_8f.js b/w3fi47_8f.js index 1ad1e5b6..784202bb 100644 --- a/w3fi47_8f.js +++ b/w3fi47_8f.js @@ -1,4 +1,4 @@ var w3fi47_8f = [ - [ "w3fi47", "w3fi47_8f.html#aa65811b21988f0ddf7568b0a88f12282", null ] + [ "w3fi47", "w3fi47_8f.html#ad09c2b7b4957ee75a21baf17c5ae091e", null ] ]; \ No newline at end of file diff --git a/w3fi47_8f_source.html b/w3fi47_8f_source.html index 6698c178..49bc8546 100644 --- a/w3fi47_8f_source.html +++ b/w3fi47_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi47.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,92 +81,100 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi47.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert label to off. no. 85 format (cray)
    +
    3C> @author Ralph Jones @date 1985-07-31
    +
    4
    +
    5C> Converts a office note 85 label in IBM370 format
    +
    6C> to office note 85 cray format. All EBCDIC characters are
    +
    7C> converted to ASCII. Converts binary or coded label.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Ralph Jones 1985-07-31
    +
    11C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran
    +
    12C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
    +
    13C>
    +
    14C> @param[in] ILABEL 4 words (32 bytes) characters are in EBCDIc or
    +
    15C> binary.
    +
    16C> @param[out] NLABEL 4 words (32 bytes), characters are in ASCII or
    +
    17C> binary.
    +
    18C>
    +
    19C> @author Ralph Jones @date 1985-07-31
    +
    +
    20 SUBROUTINE w3fi47(ILABEL,NLABEL)
    +
    21C
    +
    22 CHARACTER*1 ILABEL(32)
    +
    23 CHARACTER*1 NLABEL(32)
    +
    24C
    +
    25C TEST FOR CODED LABEL, IF SO, CONVERT ALL CHARACTERS
    +
    26C TEST FOR EBCDIC C, 195 IN DECIMAL
    +
    27C
    +
    28 IF (mova2i(ilabel(7)).EQ.195) THEN
    +
    29C
    +
    30 CALL aea(nlabel(1),ilabel(1),32)
    +
    31C
    +
    32 ELSE
    +
    33C
    +
    34C BINARY LABEL, CONVERT BYTES 1-8, 21-30 TO ASCII
    +
    35C
    +
    36 CALL aea(nlabel(1),ilabel(1),8)
    +
    37C
    +
    38C MOVE BYTES 9 TO 20
    +
    39C
    +
    40 DO 10 i = 9,20
    +
    41 nlabel(i) = ilabel(i)
    +
    42 10 CONTINUE
    +
    43C
    +
    44C CONVERT WASHINGTON TO ASCII
    +
    45C
    +
    46 CALL aea(nlabel(21),ilabel(21),10)
    +
    47C
    +
    48C TEST BYTES 31 AND 32 FOR BINARY ZERO, IF NOT ZERO
    +
    49C CONVERT TO ASCII
    +
    50C
    +
    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
    +
    56C
    +
    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
    +
    62C
    +
    63 ENDIF
    +
    64C
    +
    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/w3fi48_8f.html b/w3fi48_8f.html index cd0c58ec..60a03fb2 100644 --- a/w3fi48_8f.html +++ b/w3fi48_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi48.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi48.f File Reference
    +
    w3fi48.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi48 (ilabel, nlabel)
     Converts office note 85 label from the cray format into a nas-9050 label.
     

    Detailed Description

    Convert office note 85 label to IBM.

    @@ -107,8 +113,8 @@

    Definition in file w3fi48.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi48()

    + +

    ◆ w3fi48()

    @@ -117,13 +123,13 @@

    subroutine w3fi48 ( character*1, dimension(32)  - ILABEL, + ilabel, character*1, dimension(32)  - NLABEL  + nlabel  @@ -161,7 +167,7 @@

    diff --git a/w3fi48_8f.js b/w3fi48_8f.js index fc334cb2..d09891f5 100644 --- a/w3fi48_8f.js +++ b/w3fi48_8f.js @@ -1,4 +1,4 @@ var w3fi48_8f = [ - [ "w3fi48", "w3fi48_8f.html#af4be979e393742d638626918089c9374", null ] + [ "w3fi48", "w3fi48_8f.html#aa7d2d23ac60388b262bab73ae8434fa7", null ] ]; \ No newline at end of file diff --git a/w3fi48_8f_source.html b/w3fi48_8f_source.html index 397497ab..1503623f 100644 --- a/w3fi48_8f_source.html +++ b/w3fi48_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi48.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,95 +81,103 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi48.f
    +
    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
    -
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    -
    w3fi48
    subroutine w3fi48(ILABEL, NLABEL)
    Converts office note 85 label from the cray format into a nas-9050 label.
    Definition: w3fi48.f:24
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert office note 85 label to IBM.
    +
    3C> @author Ralph Jones @date 1985-07-31
    +
    4
    +
    5C> Converts office note 85 label from the cray
    +
    6C> format into a nas-9050 label. All ASCII characters are
    +
    7C> converted into EBCDIC characters. Binary or coded labels
    +
    8C> can be converted.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Ralph Jones 1985-07-31
    +
    12C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
    +
    13C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    14C>
    +
    15C> @param[in] ILABEL 4 64 bit words or 32 characters
    +
    16C> characters are in ASCII or binary.
    +
    17C> @param[out] NLABEL 4 64 bit words or 32 characters,
    +
    18C> characters are in EBCDIC or binary.
    +
    19C>
    +
    20C> @note See office note 85.
    +
    21C>
    +
    22C> @author Ralph Jones @date 1985-07-31
    +
    +
    23 SUBROUTINE w3fi48(ILABEL,NLABEL)
    +
    24C
    +
    25 CHARACTER*1 ILABEL(32)
    +
    26 CHARACTER*1 NLABEL(32)
    +
    27C
    +
    28C TEST FOR CODED LABEL, IF SO, CONVERT ALL CHARACTERS
    +
    29C TEST FOR ASCII C, 67 IN DECIMAL
    +
    30C
    +
    31 IF (mova2i(ilabel(7)).EQ.67) THEN
    +
    32C
    +
    33 CALL aea(ilabel(1),nlabel(1),-32)
    +
    34C
    +
    35 ELSE
    +
    36C
    +
    37C BINARY LABEL, CONVERT BYTES 1-8, 21-30 TO EBCDIC
    +
    38C
    +
    39 CALL aea (ilabel(1),nlabel(1),-8)
    +
    40C
    +
    41C MOVE BYTES 9 TO 20
    +
    42C
    +
    43 DO 10 i = 9,20
    +
    44 nlabel(i) = ilabel(i)
    +
    45 10 CONTINUE
    +
    46C
    +
    47C CONVERT WASHINGTON TO EBCDIC
    +
    48C
    +
    49 CALL aea (ilabel(21),nlabel(21),-10)
    +
    50C
    +
    51C TEST BYTES 31 AND 32 FOR BINARY ZERO, IF NOT ZERO
    +
    52C CONVERT TO ASCII
    +
    53C
    +
    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
    +
    59C
    +
    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
    +
    65C
    +
    66 ENDIF
    +
    67C
    +
    68 RETURN
    +
    +
    69 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
    +
    w3fi48
    subroutine w3fi48(ilabel, nlabel)
    Converts office note 85 label from the cray format into a nas-9050 label.
    Definition w3fi48.f:24
    diff --git a/w3fi52_8f.html b/w3fi52_8f.html deleted file mode 100644 index c9fcabe0..00000000 --- a/w3fi52_8f.html +++ /dev/null @@ -1,178 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: w3fi52.f File Reference - - - - - - - - - - - - - -
    -
    - - - - - - -
    -
    NCEPLIBS-w3emc -  2.11.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 21 of file w3fi52.f.

    - -
    -
    -
    -
    - - - - diff --git a/w3fi52_8f.js b/w3fi52_8f.js deleted file mode 100644 index 944d0de7..00000000 --- a/w3fi52_8f.js +++ /dev/null @@ -1,4 +0,0 @@ -var w3fi52_8f = -[ - [ "w3fi52", "w3fi52_8f.html#a8ce70b189d09ff2d3acfb478833c640c", null ] -]; \ No newline at end of file diff --git a/w3fi52_8f_source.html b/w3fi52_8f_source.html deleted file mode 100644 index a2441b2e..00000000 --- a/w3fi52_8f_source.html +++ /dev/null @@ -1,436 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: w3fi52.f Source File - - - - - - - - - - - - - -
    -
    - - - - - - -
    -
    NCEPLIBS-w3emc -  2.11.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/w3fi58_8f.html b/w3fi58_8f.html index 01384a43..27541ddc 100644 --- a/w3fi58_8f.html +++ b/w3fi58_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi58.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi58.f File Reference
    +
    w3fi58.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Pack positive differences in least bits.

    @@ -107,8 +113,8 @@

    Definition in file w3fi58.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi58()

    + +

    ◆ w3fi58()

    @@ -117,43 +123,43 @@

    subroutine w3fi58 ( integer, dimension(*)  - IFIELD, + ifield,   - NPTS, + npts, integer, dimension(*)  - NWORK, + nwork, character*1, dimension(*)  - NPFLD, + npfld,   - NBITS, + nbits,   - LEN, + len,   - KMIN  + kmin  @@ -168,7 +174,7 @@

    w3fi58() +
  • 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.
    • @@ -202,7 +208,7 @@

    diff --git a/w3fi58_8f.js b/w3fi58_8f.js index f2f56bc1..b41fb71e 100644 --- a/w3fi58_8f.js +++ b/w3fi58_8f.js @@ -1,4 +1,4 @@ var w3fi58_8f = [ - [ "w3fi58", "w3fi58_8f.html#a9e29ba5f6e80a0133fdf08c4374d6e5e", null ] + [ "w3fi58", "w3fi58_8f.html#a06f9456e4b8c768f7853a0ba42a5d229", null ] ]; \ No newline at end of file diff --git a/w3fi58_8f_source.html b/w3fi58_8f_source.html index 55101b9d..44117f4b 100644 --- a/w3fi58_8f_source.html +++ b/w3fi58_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi58.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,122 +81,130 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi58.f
    +
    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
    -
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Pack positive differences in least bits.
    +
    3C> @author Robert Allard @date 1987-09-02
    +
    4
    +
    5C> Converts an array of integer numbers into an array of
    +
    6C> positive differences (number(s) - minimum value) and packs the
    +
    7C> magnitude of each difference right-adjusted into the least
    +
    8C> number of bits that holds the largest difference.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Robert Allard 1987-09-02
    +
    12C> - Ralph Jones 1988-10-02 Converted to cdc cyber 205 ftn200 fortran.
    +
    13C> - Ralph Jones 1990-05-17 Converted to cray cft77 fortran.
    +
    14C> - Ralph Jones 1990-05-18 Change name vbimpk to w3lib name w3fi58()
    +
    15C> - Mark Iredell 1996-05-14 Generalized computation of nbits.
    +
    16C> - Ebisuzaki 1998-06-30 Linux port.
    +
    17C>
    +
    18C> @param[in] IFIELD Array of integer data for processing.
    +
    19C> @param[in] NPTS Number of data values to process in IFIELD (and nwork)
    +
    20C> where, npts > 0.
    +
    21C> @param[out] NWORK Work array with integer difference
    +
    22C> @param[out] NPFLD Array for packed data (character*1)
    +
    23C> (user is responsible for an adequate dimension.)
    +
    24C> @param[out] NBITS Number of bits used to pack data where, 0 < nbits < 32
    +
    25C> (the maximum difference without overflow is 2**31 -1)
    +
    26C> @param[out] LEN Number of packed bytes in npfld (set to 0 if no packing)
    +
    27C> where, len = (nbits * npts + 7) / 8 without remainder
    +
    28C> @param[out] KMIN Minimum value (subtracted from each datum). If this
    +
    29C> packed data is being used for grib data, the
    +
    30C> programer will have to convert the KMIN value to an
    +
    31C> IBM370 32 bit floating point number.
    +
    32C>
    +
    33C> @note LEN = 0, NBITS = 0, and no packing performed if
    +
    34C> - (1) KMAX = KMIN (a constant field)
    +
    35C> - (2) NPTS < 1 (see input argument)
    +
    36C>
    +
    37C> @author Robert Allard @date 1987-09-02
    +
    +
    38 SUBROUTINE w3fi58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN)
    +
    39C
    +
    40 parameter(alog2=0.69314718056)
    +
    41 INTEGER IFIELD(*)
    +
    42 CHARACTER*1 NPFLD(*)
    +
    43 INTEGER NWORK(*)
    +
    44C
    +
    45 DATA kzero / 0 /
    +
    46C
    +
    47C / / / / / /
    +
    48C
    +
    49 len = 0
    +
    50 nbits = 0
    +
    51 IF (npts.LE.0) GO TO 3000
    +
    52C
    +
    53C FIND THE MAX-MIN VALUES IN INTEGER FIELD (IFIELD).
    +
    54C
    +
    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
    +
    61C
    +
    62C IF A CONSTANT FIELD, RETURN WITH NO PACKING AND 'LEN' AND 'NBITS' SET
    +
    63C TO ZERO.
    +
    64C
    +
    65 IF (kmax.EQ.kmin) GO TO 3000
    +
    66C
    +
    67C DETERMINE LARGEST DIFFERENCE IN IFIELD AND FLOAT (BIGDIF).
    +
    68C
    +
    69 bigdif = kmax - kmin
    +
    70C
    +
    71C NBITS IS COMPUTED AS THE LEAST INTEGER SUCH THAT
    +
    72C BIGDIF < 2**NBITS
    +
    73C
    +
    74 nbits=log(bigdif+0.5)/alog2+1
    +
    75C
    +
    76C FORM DIFFERENCES IN NWORK ARRAY.
    +
    77C
    +
    78 DO 2000 k = 1,npts
    +
    79 nwork(k) = ifield(k) - kmin
    +
    80 2000 CONTINUE
    +
    81C
    +
    82C PACK EACH MAGNITUDE IN NBITS (NBITS = THE LEAST POWER OF 2 OR 'N')
    +
    83C
    +
    84 len=(nbits*npts-1)/8+1
    +
    85 CALL sbytesc(npfld,nwork,0,nbits,0,npts)
    +
    86C
    +
    87C ADD ZERO-BITS AT END OF PACKED DATA TO INSURE A BYTE BOUNDARY.
    +
    88C
    +
    89 noff = nbits * npts
    +
    90 nzero=len*8-noff
    +
    91 IF(nzero.GT.0) CALL sbytec(npfld,kzero,noff,nzero)
    +
    92C
    +
    93 3000 CONTINUE
    +
    94 RETURN
    +
    95C
    +
    +
    96 END
    +
    sbytec
    subroutine sbytec(out, in, iskip, nbyte)
    This is a wrapper for sbytesc()
    Definition sbytec.f:14
    +
    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
    +
    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
    diff --git a/w3fi59_8f.html b/w3fi59_8f.html index 8d2c3c02..af303572 100644 --- a/w3fi59_8f.html +++ b/w3fi59_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi59.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi59.f File Reference
    +
    w3fi59.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Form and pack positive, scaled differences.

    @@ -107,8 +113,8 @@

    Definition in file w3fi59.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi59()

    + +

    ◆ w3fi59()

    @@ -117,49 +123,49 @@

    subroutine w3fi59 ( real, dimension(*)  - FIELD, + field,   - NPTS, + npts,   - NBITS, + nbits, integer, dimension(*)  - NWORK, + nwork, character*1, dimension(*)  - NPFLD, + npfld,   - ISCALE, + iscale,   - LEN, + len,   - RMIN  + rmin  @@ -173,7 +179,7 @@

    w3fi59(). +
  • 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.
    • @@ -210,7 +216,7 @@

    diff --git a/w3fi59_8f.js b/w3fi59_8f.js index 8df331b3..64b7486b 100644 --- a/w3fi59_8f.js +++ b/w3fi59_8f.js @@ -1,4 +1,4 @@ var w3fi59_8f = [ - [ "w3fi59", "w3fi59_8f.html#ab4f28b2c5e95c681036ef83142a58601", null ] + [ "w3fi59", "w3fi59_8f.html#a8bba5bf7656b97615cfba69962c91782", null ] ]; \ No newline at end of file diff --git a/w3fi59_8f_source.html b/w3fi59_8f_source.html index 8db20625..b38a40f3 100644 --- a/w3fi59_8f_source.html +++ b/w3fi59_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi59.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,145 +81,153 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi59.f
    +
    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
    -
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Form and pack positive, scaled differences.
    +
    3C> @author Robert Allard @date 1984-08-01
    +
    4
    +
    5C> Converts an array of single precision real numbers into
    +
    6C> an array of positive scaled differences (number(s) - minimum value),
    +
    7C> in integer format and packs the argument-specified number of
    +
    8C> significant bits from each difference.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Robert Allard 1984-08-01 ALLARD
    +
    12C> - Ralph Jones 1990-05-17 Convert to cray cft77 fortran.
    +
    13C> - Ralph Jones 1990-05-18 Change name pakmag to w3lib name w3fi59().
    +
    14C> - Ralph Jones 1993-07-06 Add nint to do loop 2000 so numbers are
    +
    15C> rounded to nearest integer, not truncated.
    +
    16C> - Mark Iredell 1994-01-05 Computation of iscale fixed with respect to
    +
    17C> the 93-07-06 change.
    +
    18C> - Ebisuzaki 1998-06-30 Linux port.
    +
    19C>
    +
    20C> @param[in] FIELD Array of floating point data for processing (real)
    +
    21C> @param[in] NPTS Number of data values to process in field (and nwork)
    +
    22C> where, npts > 0
    +
    23C> @param[in] NBITS Number of significant bits of processed data to be packed
    +
    24C> where, 0 < nbits < 32+1
    +
    25C> @param[out] NWORK Array for integer conversion (integer)
    +
    26C> if packing performed (see note below), the array will
    +
    27C> contain the pre-packed, right adjusted, scaled, integer
    +
    28C> differences upon return to the user.
    +
    29C> (the user may equivalence field and nwork. Same size.)
    +
    30C> @param[out] NPFLD Array for packed data (character*1)
    +
    31C> (dimension must be at least (nbits * npts) / 64 + 1)
    +
    32C> @param[out] ISCALE Power of 2 for restoring data, such that
    +
    33C> datum = (difference * 2**iscale) + rmin
    +
    34C> @param[out] LEN Number of packed bytes in npfld (set to 0 if no packing)
    +
    35C> where, len = (nbits * npts + 7) / 8 without remainder
    +
    36C> @param[out] RMIN Minimum value (reference value subtracted from input data)
    +
    37C> this is a cray floating point number, it will have to be
    +
    38C> converted to an ibm370 32 bit floating point number at
    +
    39C> some point in your program if you are packing grib data.
    +
    40C>
    +
    41C> @note: Len = 0 and no packing performed if
    +
    42C> - (1) RMAX = RMIN (a constant field)
    +
    43C> - (2) NBITS value out of range (see input argument)
    +
    44C> - (3) NPTS value less than 1 (see input argument)
    +
    45C>
    +
    46C> @author Robert Allard @date 1984-08-01
    +
    +
    47 SUBROUTINE w3fi59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN)
    +
    48C NATURAL LOGARITHM OF 2 AND 0.5 PLUS NOMINAL SAFE EPSILON
    +
    49 parameter(alog2=0.69314718056,hpeps=0.500001)
    +
    50C
    +
    51 REAL FIELD(*)
    +
    52C
    +
    53 CHARACTER*1 NPFLD(*)
    +
    54 INTEGER NWORK(*)
    +
    55C
    +
    56 DATA kzero / 0 /
    +
    57C
    +
    58C / / / / / /
    +
    59C
    +
    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
    +
    64C
    +
    65C FIND THE MAX-MIN VALUES IN FIELD.
    +
    66C
    +
    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
    +
    73C
    +
    74C IF A CONSTANT FIELD, RETURN WITH NO PACKING PERFORMED AND 'LEN' = 0.
    +
    75C
    +
    76 IF (rmax.EQ.rmin) GO TO 3000
    +
    77C
    +
    78C DETERMINE LARGEST DIFFERENCE IN FIELD (BIGDIF).
    +
    79C
    +
    80 bigdif = rmax - rmin
    +
    81C
    +
    82C ISCALE IS THE POWER OF 2 REQUIRED TO RESTORE THE PACKED DATA.
    +
    83C ISCALE IS COMPUTED AS THE LEAST INTEGER SUCH THAT
    +
    84C BIGDIF*2**(-ISCALE) < 2**NBITS-0.5
    +
    85C IN ORDER TO ENSURE THAT THE PACKED INTEGERS (COMPUTED IN LOOP 2000
    +
    86C WITH THE NEAREST INTEGER FUNCTION) STAY LESS THAN 2**NBITS.
    +
    87C
    +
    88 iscale=nint(alog(bigdif/(2.**nbits-0.5))/alog2+hpeps)
    +
    89C
    +
    90C FORM DIFFERENCES, RESCALE, AND CONVERT TO INTEGER FORMAT.
    +
    91C
    +
    92 twon = 2.0 ** (-iscale)
    +
    93 DO 2000 k = 1,npts
    +
    94 nwork(k) = nint( (field(k) - rmin) * twon )
    +
    95 2000 CONTINUE
    +
    96C
    +
    97C PACK THE MAGNITUDES (RIGHTMOST NBITS OF EACH WORD).
    +
    98C
    +
    99 koff = 0
    +
    100 iskip = 0
    +
    101C
    +
    102C USE NCAR ARRAY BIT PACKER SBYTES (GBYTES PACKAGE)
    +
    103C
    +
    104 CALL sbytesc(npfld,nwork,koff,nbits,iskip,npts)
    +
    105C
    +
    106C ADD 7 ZERO-BITS AT END OF PACKED DATA TO INSURE BYTE BOUNDARY.
    +
    107C USE NCAR WORD BIT PACKER SBYTE
    +
    108C
    +
    109 noff = nbits * npts
    +
    110 CALL sbytec(npfld,kzero,noff,7)
    +
    111C
    +
    112C DETERMINE BYTE LENGTH (LEN) OF PACKED FIELD (NPFLD).
    +
    113C
    +
    114 len = (noff + 7) / 8
    +
    115C
    +
    116 3000 CONTINUE
    +
    117 RETURN
    +
    118C
    +
    +
    119 END
    +
    sbytec
    subroutine sbytec(out, in, iskip, nbyte)
    This is a wrapper for sbytesc()
    Definition sbytec.f:14
    +
    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
    +
    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
    diff --git a/w3fi61_8f.html b/w3fi61_8f.html index 6bf50644..7b2dc3ec 100644 --- a/w3fi61_8f.html +++ b/w3fi61_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi61.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi61.f File Reference
    +
    w3fi61.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi61 (loc, icat, areg, ibckup, idatyp, ierr)
     Using information from the user, build a 40 character communications prefix and place in indicated location.
     

    Detailed Description

    Build 40 char communications prefix.

    @@ -107,8 +113,8 @@

    Definition in file w3fi61.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi61()

    + +

    ◆ w3fi61()

    @@ -117,37 +123,37 @@

    subroutine w3fi61 ( integer, dimension(*)  - LOC, + loc, integer  - ICAT, + icat, character*6  - AREG, + areg, integer  - IBCKUP, + ibckup, integer  - IDATYP, + idatyp, integer  - IERR  + ierr  @@ -218,7 +224,7 @@

    diff --git a/w3fi61_8f.js b/w3fi61_8f.js index 2a47e270..d0230525 100644 --- a/w3fi61_8f.js +++ b/w3fi61_8f.js @@ -1,4 +1,4 @@ var w3fi61_8f = [ - [ "w3fi61", "w3fi61_8f.html#a1b9630713670570f4aef4d99b284bfec", null ] + [ "w3fi61", "w3fi61_8f.html#a41ee42bf0040218d3bf0c0c93716d12e", null ] ]; \ No newline at end of file diff --git a/w3fi61_8f_source.html b/w3fi61_8f_source.html index 7e31e957..02206bdb 100644 --- a/w3fi61_8f_source.html +++ b/w3fi61_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi61.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,224 +81,232 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi61.f
    +
    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
    -
    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
    -
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Build 40 char communications prefix.
    +
    3C> @author Bill Cavanaugh @date 1991-06-21
    +
    4
    +
    5C> Using information from the user, build a 40 character
    +
    6C> communications prefix and place in indicated location.
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - Bill Cavanaugh 1991-06-21
    +
    10C> - Ralph Jones 1991-09-20 Changes for silicongraphics 3.3 fortran 77.
    +
    11C> - Ralph Jones 1993-03-29 Add save statement.
    +
    12C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and
    +
    13C> for ASCII character set computers.
    +
    14C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    15C>
    +
    16C> @param[in] ICAT Catalog number.
    +
    17C> @param[in] AREG AFOS regional addressing flags (6 positions)
    +
    18C> select any or all of the following. Selections
    +
    19C> will automatically be left justified and blank
    +
    20C> filled to 6 positions.
    +
    21C> If bulletins and/or messages are not to be routed
    +
    22C> to AFOS, then leave the field filled with blanks.
    +
    23C> - E - Eastern region
    +
    24C> - C - Central region
    +
    25C> - W - Western region
    +
    26C> - S - Southern region
    +
    27C> - A - Atlantic region
    +
    28C> - P - Pacific region
    +
    29C> @param[in] IERR Error return.
    +
    30C> @param[in] IBCKUP Backup indicator w/header key
    +
    31C> - 0 = Not a backup.
    +
    32C> - 1 = FD backup.
    +
    33C> - 2 = DF backup.
    +
    34C> - Back up is only permitted for KU and KU bulletins.
    +
    35C> @param[in] IDATYP Data type indicator.
    +
    36C> - 0 = EBCIDIC data.
    +
    37C> - 11 = Binary data.
    +
    38C> - 12 = Psuedo-ASCII data.
    +
    39C> - 3 = ASCII data.
    +
    40C> @param[out] LOC Name of the array to receive the communications prefix.
    +
    41C>
    +
    42C> @note Error returns
    +
    43C> IERR:
    +
    44C> - = 0 Normal return.
    +
    45C> - = 1 Incorrect backup flag.
    +
    46C> - = 2 A regional addressing flag is non-blank and non-standard entry.
    +
    47C> - = 3 Data type is non-standard entry.
    +
    48C>
    +
    49C> @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
    +
    54C
    +
    55 CHARACTER*6 AREG
    +
    56 CHARACTER*8 AHOLD
    +
    57 CHARACTER*6 ARGNL
    +
    58 CHARACTER*1 BLANK
    +
    59C
    +
    60 LOGICAL IBM370
    +
    61C
    +
    62 equivalence(ihold,ahold)
    +
    63C
    +
    64 SAVE
    +
    65C
    +
    66 DATA argnl /'ECWSAP'/
    +
    67C
    +
    68C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
    +
    69C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
    +
    70C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
    +
    71C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
    +
    72C SETS TO FIND IBM370 TYPE COMPUTER.
    +
    73C
    +
    74 DATA blank /' '/
    +
    75 DATA ibm370/.false./
    +
    76C
    +
    77C ----------------------------------------------------------------
    +
    78C
    +
    79C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
    +
    80C
    +
    81 CALL w3fi01(lw)
    +
    82C
    +
    83C TEST FOR EBCDIC CHARACTER SET
    +
    84C
    +
    85 IF (mova2i(blank).EQ.64) THEN
    +
    86 ibm370 = .true.
    +
    87 END IF
    +
    88C
    +
    89 ierr = 0
    +
    90 inofst = 0
    +
    91C BYTE 1 SOH - START OF HEADER
    +
    92 CALL sbyte (loc,125,inofst,8)
    +
    93 inofst = inofst + 8
    +
    94C BYTE 2 TRANSMISSION PRIORITY
    +
    95 CALL sbyte (loc,1,inofst,8)
    +
    96 inofst = inofst + 8
    +
    97C 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
    +
    122C BYTE 8-9-10 BACK-UP FLAG FOR FD OR DF BULLETINS
    +
    123C 0 = NOT A BACKUP
    +
    124C 1 = FD
    +
    125C 2 = DF
    +
    126 IF (ibckup.EQ.0) THEN
    +
    127C NOT A BACKUP
    +
    128 CALL sbyte (loc,4210752,inofst,24)
    +
    129 inofst = inofst + 24
    +
    130 ELSE IF (ibckup.EQ.1) THEN
    +
    131C BACKUP FOR FD
    +
    132 CALL sbyte (loc,12764868,inofst,24)
    +
    133 inofst = inofst + 24
    +
    134 ELSE IF (ibckup.EQ.2) THEN
    +
    135C BACKUP FOR DF
    +
    136 CALL sbyte (loc,12764358,inofst,24)
    +
    137 inofst = inofst + 24
    +
    138 END IF
    +
    139C BYTE 11 BLANK
    +
    140 CALL sbyte (loc,64,inofst,8)
    +
    141 inofst = inofst + 8
    +
    142C 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
    +
    153C 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
    +
    162C 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
    +
    175C PRINT *,'BLANK SOURCE '
    +
    176 GO TO 1000
    +
    177 END IF
    +
    178 900 CONTINUE
    +
    179 ierr = 2
    +
    180 RETURN
    +
    181 1000 CONTINUE
    +
    182 inofst = kreset
    +
    183C 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
    +
    188C BYTE 39 MUST BE A BLANK
    +
    189 CALL sbyte (loc,64,inofst,8)
    +
    190 inofst = inofst + 8
    +
    191C BYTE 40 MUST BE A BLANK
    +
    192 CALL sbyte (loc,64,inofst,8)
    +
    193C ----------------------------------------------------------------
    +
    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
    +
    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
    +
    w3ai39
    subroutine w3ai39(nfld, n)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition w3ai39.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
    +
    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
    diff --git a/w3fi62_8f.html b/w3fi62_8f.html index ae896976..eb05dd15 100644 --- a/w3fi62_8f.html +++ b/w3fi62_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi62.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi62.f File Reference
    +
    w3fi62.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Build 80-char on295 queue descriptor.

    @@ -107,8 +113,8 @@

    Definition in file w3fi62.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi62()

    + +

    ◆ w3fi62()

    @@ -117,25 +123,25 @@

    subroutine w3fi62 ( character*80  - LOC, + loc, character*6  - TTAAII, + ttaaii, integer, dimension(7)  - KARY, + kary, integer  - IERR  + ierr  @@ -192,7 +198,7 @@

    diff --git a/w3fi62_8f.js b/w3fi62_8f.js index 1d5e4b7a..58dc545b 100644 --- a/w3fi62_8f.js +++ b/w3fi62_8f.js @@ -1,4 +1,4 @@ var w3fi62_8f = [ - [ "w3fi62", "w3fi62_8f.html#a0dd3e7a53e1e42357c2579cbe74a4f77", null ] + [ "w3fi62", "w3fi62_8f.html#a462db56d61f6d13371250087a22255ba", null ] ]; \ No newline at end of file diff --git a/w3fi62_8f_source.html b/w3fi62_8f_source.html index 515e69b0..12c59d99 100644 --- a/w3fi62_8f_source.html +++ b/w3fi62_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi62.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,230 +81,238 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi62.f
    +
    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
    -
    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
    -
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Build 80-char on295 queue descriptor.
    +
    3C> @author Bill Cavanaugh @date 1991-06-21
    +
    4
    +
    5C> Build 80 character queue descriptor using information
    +
    6C> supplied by user, placing the completed queue descriptor in the
    +
    7C> location specified by the user. (based on office note 295).
    +
    8C>
    +
    9C> PROGRAM HISTORY LOG:
    +
    10C> - Bill Cavanaugh 1991-06-21
    +
    11C> - Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that
    +
    12C> exceed 20000 bytes
    +
    13C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and
    +
    14C> for ASCII character set computers
    +
    15C> - Ralph Jones 1996-01-29 Preset IERR to zero
    +
    16C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
    +
    17C>
    +
    18C> @param[in] TTAAII First 6 characters of WMO header
    +
    19C> @param[inout] KARY Integer array containing user information
    +
    20C> - (1) = Day of month
    +
    21C> - (2) = Hour of day
    +
    22C> - (3) = Hour * 100 + minute
    +
    23C> - (4) = Catalog number
    +
    24C> - (5) = Number of 80 byte increments
    +
    25C> - (6) = Number of bytes in last increment
    +
    26C> - (7) = Total size of message
    +
    27C> WMO header + body of message in bytes
    +
    28C> (not including queue descriptor)
    +
    29C> @param[out] LOC Location to receive queue descriptor
    +
    30C> @param[out] IERR Error return
    +
    31C>
    +
    32C> @note If total size is entered (kary(7)) then kary(5) and
    +
    33C> kary(6) will be calculated.
    +
    34C> If kary(5) and kary(6) are provided then kary(7) will
    +
    35C> be ignored.
    +
    36C>
    +
    37C> @note Equivalence array loc to integer array so it starts on
    +
    38C> a word boundary for sbyte subroutine.
    +
    39C>
    +
    40C> Error returns:
    +
    41C> - IERR = 1 Total byte count and/or 80 byte increment
    +
    42C> count is missing. One or the other is
    +
    43C> required to complete the queue descriptor.
    +
    44C> - IERR = 2 Total size too small
    +
    45C>
    +
    46C> @author Bill Cavanaugh @date 1991-06-21
    +
    +
    47 SUBROUTINE w3fi62 (LOC,TTAAII,KARY,IERR)
    +
    48C
    +
    49 INTEGER IHOLD(2)
    +
    50 INTEGER KARY(7),II,IERR
    +
    51C
    +
    52 LOGICAL IBM370
    +
    53C
    +
    54 CHARACTER*6 TTAAII,AHOLD
    +
    55 CHARACTER*80 LOC
    +
    56 CHARACTER*1 BLANK
    +
    57C
    +
    58 equivalence(ahold,ihold)
    +
    59C
    +
    60 SAVE
    +
    61C
    +
    62C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
    +
    63C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
    +
    64C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
    +
    65C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
    +
    66C SETS TO FIND IBM370 TYPE COMPUTER.
    +
    67C
    +
    68 DATA blank /' '/
    +
    69C ----------------------------------------------------------------
    +
    70C
    +
    71C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
    +
    72C
    +
    73 CALL w3fi01(lw)
    +
    74C
    +
    75C TEST FOR EBCDIC CHARACTER SET
    +
    76C
    +
    77 ibm370 = .false.
    +
    78 IF (mova2i(blank).EQ.64) THEN
    +
    79 ibm370 = .true.
    +
    80 END IF
    +
    81C
    +
    82 inofst = 0
    +
    83C 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
    +
    92C BYTES 17-20 INTEGER ZEROES
    +
    93 CALL sbyte (loc,0,inofst,32)
    +
    94 inofst = inofst + 32
    +
    95C IF TOTAL COUNT IS INCLUDED
    +
    96C THEN WILL DETERMINE THE NUMBER OF
    +
    97C 80 BYTE INCREMENTS AND WILL DETERMINE
    +
    98C 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
    +
    102C 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
    +
    119C BYTE 21-22 NR OF 80 BYTE INCREMENTS
    +
    120 CALL sbyte (loc,kary(5),inofst,16)
    +
    121 inofst = inofst + 16
    +
    122C BYTE 23 NR OF BYTES IN LAST INCREMENT
    +
    123 CALL sbyte (loc,kary(6),inofst,8)
    +
    124 inofst = inofst + 8
    +
    125C 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
    +
    130C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII
    +
    131 loc(29:34) = ttaaii(1:6)
    +
    132C
    +
    133C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
    +
    134C
    +
    135 IF (.NOT.ibm370) CALL w3ai39(loc(29:29),6)
    +
    136C
    +
    137 inofst = inofst + 48
    +
    138C BYTES 35-38 DAY OF MONTH AND UTC(Z) HRS
    +
    139C DAY
    +
    140C
    +
    141C NOTE: W3AI15 WILL MAKE ASCII OR EBCDIC CHARACTERS
    +
    142C DEPENDING ON WHAT TYPE OF COMPUTER IT IS ON
    +
    143C
    +
    144 CALL w3ai15 (kary(1),ii,1,lw,'-')
    +
    145 CALL sbyte (loc,ii,inofst,16)
    +
    146 inofst = inofst + 16
    +
    147C HOURS
    +
    148 CALL w3ai15 (kary(2),ii,1,lw,'-')
    +
    149 CALL sbyte (loc,ii,inofst,16)
    +
    150C
    +
    151C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
    +
    152C
    +
    153 IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
    +
    154 inofst = inofst + 16
    +
    155C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
    +
    156C 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
    +
    169C 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
    +
    177C
    +
    178C ON CRAY 64 BIT COMPUTER
    +
    179C
    +
    180 ELSE
    +
    181 CALL sbyte (loc,ihold,inofst,40)
    +
    182 inofst = inofst + 40
    +
    183 END IF
    +
    184C
    +
    185C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
    +
    186C
    +
    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
    +
    194C 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
    +
    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
    +
    w3ai39
    subroutine w3ai39(nfld, n)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition w3ai39.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
    +
    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
    diff --git a/w3fi63_8f.html b/w3fi63_8f.html index 769d6e53..6c4f459e 100644 --- a/w3fi63_8f.html +++ b/w3fi63_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi63.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi63.f File Reference
    +
    w3fi63.f File Reference
    @@ -94,35 +100,35 @@

    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...
     
    subroutine fi631 (msga, kptr, kpds, kret)
     Find 'grib' chars & reset pointers.
     
    subroutine fi632 (msga, kptr, kpds, kret)
     Gather info from product definition sec.
     
    subroutine fi633 (msga, kptr, kgds, kret)
     Extract info from grib-gds.
     
    subroutine fi634 (msga, kptr, kpds, kgds, kbms, kret)
     Extract or generate bit map for output.
     
    subroutine fi634x (npts, nskp, msga, kbms)
     Extract bit map.
     
    subroutine fi635 (msga, kptr, kpds, kgds, kbms, data, kret)
     Extract grib data elements from bds.
     
    subroutine fi636 (data, msga, kbms, refnce, kptr, kpds, kgds)
     Process second order packing.
     
    subroutine fi637 (j, kpds, kgds, kret)
     Grib grid/size test.
     
    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.
     

    Detailed Description

    Unpack GRIB field to a GRIB grid.

    @@ -131,8 +137,8 @@

    Definition in file w3fi63.f.

    Function/Subroutine Documentation

    - -

    ◆ fi631()

    + +

    ◆ fi631()

    @@ -141,25 +147,25 @@

    subroutine fi631 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer  - KRET  + kret  @@ -233,8 +239,8 @@

    -

    ◆ fi632()

    + +

    ◆ fi632()

    @@ -243,25 +249,25 @@

    subroutine fi632 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer  - KRET  + kret  @@ -343,8 +349,8 @@

    -

    ◆ fi633()

    + +

    ◆ fi633()

    @@ -353,25 +359,25 @@

    subroutine fi633 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KGDS, + kgds, integer  - KRET  + kret  @@ -537,8 +543,8 @@

    -

    ◆ fi634()

    + +

    ◆ fi634()

    @@ -547,37 +553,37 @@

    subroutine fi634 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds, logical*1, dimension(*)  - KBMS, + kbms, integer  - KRET  + kret  @@ -776,8 +782,8 @@

    -

    ◆ fi634x()

    + +

    ◆ fi634x()

    @@ -786,25 +792,25 @@

    subroutine fi634x (   - NPTS, + npts,   - NSKP, + nskp, character*1, dimension(*)  - MSGA, + msga, logical*1, dimension(npts)  - KBMS  + kbms  @@ -835,8 +841,8 @@

    -

    ◆ fi635()

    + +

    ◆ fi635()

    @@ -845,43 +851,43 @@

    subroutine fi635 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds, logical*1, dimension(*)  - KBMS, + kbms, real, dimension(*)  - DATA, + data,   - KRET  + kret  @@ -1082,8 +1088,8 @@

    -

    ◆ fi636()

    + +

    ◆ fi636()

    @@ -1092,43 +1098,43 @@

    subroutine fi636 ( real, dimension(*)  - DATA, + data, character*1, dimension(*)  - MSGA, + msga, logical*1, dimension(*)  - KBMS, + kbms, real  - REFNCE, + refnce, integer, dimension(*)  - KPTR, + kptr, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS  + kgds  @@ -1302,8 +1308,8 @@

    -

    ◆ fi637()

    + +

    ◆ fi637()

    @@ -1312,25 +1318,25 @@

    subroutine fi637 ( integer  - J, + j, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds,   - KRET  + kret  @@ -1374,8 +1380,8 @@

    -

    ◆ w3fi63()

    + +

    ◆ w3fi63()

    @@ -1384,43 +1390,43 @@

    subroutine w3fi63 ( character*1, dimension(*)  - MSGA, + msga, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS, + kgds, logical*1, dimension(*)  - KBMS, + kbms, real, dimension(*)  - DATA, + data, integer, dimension(*)  - KPTR, + kptr,   - KRET  + kret  @@ -1432,7 +1438,9 @@

    +

    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:

    diff --git a/w3fi63_8f.js b/w3fi63_8f.js index 13bb9d7d..31a76936 100644 --- a/w3fi63_8f.js +++ b/w3fi63_8f.js @@ -1,12 +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 ] + [ "fi631", "w3fi63_8f.html#a14d2f9e6b5fb3226561e037897d203c3", null ], + [ "fi632", "w3fi63_8f.html#ab0e08b59a11033f2b30c4597a9442fb7", null ], + [ "fi633", "w3fi63_8f.html#af02433c4bfbebcb7e7350ecbe7a61b81", null ], + [ "fi634", "w3fi63_8f.html#af01235610bd0574b0f96269311efa508", null ], + [ "fi634x", "w3fi63_8f.html#a70c16565c866b4d5147e74b75c2c8ab3", null ], + [ "fi635", "w3fi63_8f.html#ac10256c2bd0659630e821caf1c7ea44d", null ], + [ "fi636", "w3fi63_8f.html#a88dd0a17439f927fd7d2d742c6f7e310", null ], + [ "fi637", "w3fi63_8f.html#a52ab350d030e063ea1573ed81431d89e", null ], + [ "w3fi63", "w3fi63_8f.html#a275d433403624224a7d8da4c820b76be", null ] ]; \ No newline at end of file diff --git a/w3fi63_8f_source.html b/w3fi63_8f_source.html index 5b9aa5bd..5ab80708 100644 --- a/w3fi63_8f_source.html +++ b/w3fi63_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi63.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,3886 +81,3910 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi63.f
    +
    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
    -
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    -
    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
    -
    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
    -
    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
    -
    fi631
    subroutine fi631(MSGA, KPTR, KPDS, KRET)
    Find 'grib' chars & reset pointers.
    Definition: w3fi63.f:478
    -
    fi637
    subroutine fi637(J, KPDS, KGDS, KRET)
    Grib grid/size test.
    Definition: w3fi63.f:3598
    -
    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
    -
    fi634x
    subroutine fi634x(NPTS, NSKP, MSGA, KBMS)
    Extract bit map.
    Definition: w3fi63.f:2512
    -
    fi636
    subroutine fi636(DATA, MSGA, KBMS, REFNCE, KPTR, KPDS, KGDS)
    Process second order packing.
    Definition: w3fi63.f:3331
    -
    fi633
    subroutine fi633(MSGA, KPTR, KGDS, KRET)
    Extract info from grib-gds.
    Definition: w3fi63.f:981
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Unpack GRIB field to a GRIB grid.
    +
    3C> @author Bill Cavanaugh @date 1991-09-13
    +
    4
    +
    5C> Unpack a GRIB (edition 1) field to the exact grid
    +
    6C> specified in the GRIB message, isolate the bit map, and make
    +
    7C> the values of the product descripton section (PDS) and the
    +
    8C> grid description section (GDS) available in return arrays.
    +
    9C>
    +
    10C> When decoding is completed, data at each grid point has been
    +
    11C> returned in the units specified in the GRIB manual.
    +
    12C>
    +
    13C> See "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
    +
    14C> INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
    +
    15C> GRIDDED BINARY FORM" dated July 1, 1988 by John D. Stackpolem
    +
    16C> DOC, NOAA, NWS, National Meteorological Center.
    +
    17C>
    +
    18C> List of text messages from code:
    +
    19C> - W3FI63/FI632
    +
    20C> - 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
    +
    21C> AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    22C> (W/NMC42)'
    +
    23C>
    +
    24C> - 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
    +
    25C> AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    26C> (W/NMC42)'
    +
    27C>
    +
    28C> - 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
    +
    29C> OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
    +
    30C> PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
    +
    31C>
    +
    32C> - 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
    +
    33C> AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    34C> (W/NMC42)'
    +
    35C>
    +
    36C> - W3FI63/FI633
    +
    37C> - 'POLAR STEREO PROCESSING NOT AVAILABLE'
    +
    38C>
    +
    39C> - W3FI63/FI634
    +
    40C> - 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
    +
    41C> COEFFICIENTS'
    +
    42C>
    +
    43C> - W3FI63/FI637
    +
    44C> - 'NO CURRENT LISTING OF FNOC GRIDS'
    +
    45C>
    +
    46C> @param[in] MSGA Grib field - "grib" thru "7777" char*1
    +
    47C> (message can be preceded by junk chars). Contains the grib message to be unpacked. characters
    +
    48C> "GRIB" may begin anywhere within first 100 bytes.
    +
    49C> @param[out] KPDS Array of size 100 containing PDS elements, GRIB (edition 1):
    +
    50C> - 1 Id of center
    +
    51C> - 2 Generating process id number
    +
    52C> - 3 Grid definition
    +
    53C> - 4 Gds/bms flag (right adj copy of octet 8)
    +
    54C> - 5 Indicator of parameter
    +
    55C> - 6 Type of level
    +
    56C> - 7 Height/pressure , etc of level
    +
    57C> - 8 Year including (century-1)
    +
    58C> - 9 Month of year
    +
    59C> - 10 Day of month
    +
    60C> - 11 Hour of day
    +
    61C> - 12 Minute of hour
    +
    62C> - 13 Indicator of forecast time unit
    +
    63C> - 14 Time range 1
    +
    64C> - 15 Time range 2
    +
    65C> - 16 Time range flag
    +
    66C> - 17 Number included in average
    +
    67C> - 18 Version nr of grib specification
    +
    68C> - 19 Version nr of parameter table
    +
    69C> - 20 Nr missing from average/accumulation
    +
    70C> - 21 Century of reference time of data
    +
    71C> - 22 Units decimal scale factor
    +
    72C> - 23 Subcenter number
    +
    73C> - 24 Pds byte 29, for nmc ensemble products
    +
    74C> - 128 If forecast field error
    +
    75C> - 64 If bias corrected fcst field
    +
    76C> - 32 If smoothed field
    +
    77C> - Warning: can be combination of more than 1
    +
    78C> - 25 Pds byte 30, not used
    +
    79C> - 26-35 Reserved
    +
    80C> - 36-N Consecutive bytes extracted from program
    +
    81C> Definition section (pds) of grib message
    +
    82C> @param[out] KGDS ARRAY CONTAINING GDS ELEMENTS.
    +
    83C> - 1) Data representation type
    +
    84C> - 19 Number of vertical coordinate parameters
    +
    85C> - 20 Octet number of the list of vertical coordinate
    +
    86C> Parameters Or Octet number of the list of numbers of points
    +
    87C> In each row Or 255 if neither are present
    +
    88C> - 21 For grids with pl, number of points in grid
    +
    89C> - 22 Number of words in each row
    +
    90C> - LATITUDE/LONGITUDE GRIDS
    +
    91C> - 2 N(i) nr points on latitude circle
    +
    92C> - 3 N(j) nr points on longitude meridian
    +
    93C> - 4 La(1) latitude of origin
    +
    94C> - 5 Lo(1) longitude of origin
    +
    95C> - 6 Resolution flag (right adj copy of octet 17)
    +
    96C> - 7 La(2) latitude of extreme point
    +
    97C> - 8 Lo(2) longitude of extreme point
    +
    98C> - 9 Di longitudinal direction of increment
    +
    99C> - 10 Dj latitudinal direction increment
    +
    100C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    101C> - GAUSSIAN GRIDS
    +
    102C> - 2 N(i) nr points on latitude circle
    +
    103C> - 3 N(j) nr points on longitude meridian
    +
    104C> - 4 La(1) latitude of origin
    +
    105C> - 5 Lo(1) longitude of origin
    +
    106C> - 6 Resolution flag (right adj copy of octet 17)
    +
    107C> - 7 La(2) latitude of extreme point
    +
    108C> - 8 Lo(2) longitude of extreme point
    +
    109C> - 9 Di longitudinal direction of increment
    +
    110C> - 10 N - nr of circles pole to equator
    +
    111C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    112C> - 12 Nv - nr of vert coord parameters
    +
    113C> - 13 Pv - octet nr of list of vert coord parameters or
    +
    114C> Pl - location of the list of numbers of points in
    +
    115C> each row (if no vert coord parameters are present or
    +
    116C> 255 if neither are present
    +
    117C> - POLAR STEREOGRAPHIC GRIDS
    +
    118C> - 2 N(i) nr points along lat circle
    +
    119C> - 3 N(j) nr points along lon circle
    +
    120C> - 4 La(1) latitude of origin
    +
    121C> - 5 Lo(1) longitude of origin
    +
    122C> - 6 Resolution flag (right adj copy of octet 17)
    +
    123C> - 7 Lov grid orientation
    +
    124C> - 8 Dx - x direction increment
    +
    125C> - 9 Dy - y direction increment
    +
    126C> - 10 Projection center flag
    +
    127C> - 11 Scanning mode (right adj copy of octet 28)
    +
    128C> - SPHERICAL HARMONIC COEFFICIENTS
    +
    129C> - 2) J pentagonal resolution parameter
    +
    130C> - 3) K pentagonal resolution parameter
    +
    131C> - 4) M pentagonal resolution parameter
    +
    132C> - 5) Representation type
    +
    133C> - 6) Coefficient storage mode
    +
    134C> - MERCATOR GRIDS
    +
    135C> - 2 N(i) nr points on latitude circle
    +
    136C> - 3 N(j) nr points on longitude meridian
    +
    137C> - 4 La(1) latitude of origin
    +
    138C> - 5 Lo(1) longitude of origin
    +
    139C> - 6 Resolution flag (right adj copy of octet 17)
    +
    140C> - 7 La(2) latitude of last grid point
    +
    141C> - 8 Lo(2) longitude of last grid point
    +
    142C> - 9 Latit - latitude of projection intersection
    +
    143C> - 10 Reserved
    +
    144C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    145C> - 12 Longitudinal dir grid length
    +
    146C> - 13 Latitudinal dir grid length
    +
    147C> - LAMBERT CONFORMAL GRIDS
    +
    148C> - 2 Nx nr points along x-axis
    +
    149C> - 3 Ny nr points along y-axis
    +
    150C> - 4 La1 lat of origin (lower left)
    +
    151C> - 5 Lo1 lon of origin (lower left)
    +
    152C> - 6 Resolution (right adj copy of octet 17)
    +
    153C> - 7 Lov - orientation of grid
    +
    154C> - 8 Dx - x-dir increment
    +
    155C> - 9 Dy - y-dir increment
    +
    156C> - 10 Projection center flag
    +
    157C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    158C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    159C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    160C> - E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203)
    +
    161C> - 2 N(i) nr points on latitude circle
    +
    162C> - 3 N(j) nr points on longitude meridian
    +
    163C> - 4 La(1) latitude of origin
    +
    164C> - 5 Lo(1) longitude of origin
    +
    165C> - 6 Resolution flag (right adj copy of octet 17)
    +
    166C> - 7 La(2) latitude of center
    +
    167C> - 8 Lo(2) longitude of center
    +
    168C> - 9 Di longitudinal direction of increment
    +
    169C> - 10 Dj latitudinal direction increment
    +
    170C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    171C> - CURVILINEAR ORTHIGINAL GRID (TYPE 204)
    +
    172C> - 2 N(i) nr points on latitude circle
    +
    173C> - 3 N(j) nr points on longitude meridian
    +
    174C> - 4 Reserved set to 0
    +
    175C> - 5 Reserved set to 0
    +
    176C> - 6 Resolution flag (right adj copy of octet 17)
    +
    177C> - 7 Reserved set to 0
    +
    178C> - 8 Reserved set to 0
    +
    179C> - 9 Reserved set to 0
    +
    180C> - 10 Reserved set to 0
    +
    181C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    182C> - ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205)
    +
    183C> - 2 N(i) nr points on latitude circle
    +
    184C> - 3 N(j) nr points on longitude meridian
    +
    185C> - 4 La(1) latitude of first point
    +
    186C> - 5 Lo(1) longitude of first point
    +
    187C> - 6 Resolution flag (right adj copy of octet 17)
    +
    188C> - 7 La(2) latitude of center
    +
    189C> - 8 Lo(2) longitude of center
    +
    190C> - 9 Di longitudinal direction of increment
    +
    191C> - 10 Dj latitudinal direction increment
    +
    192C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    193C> - 12 Latitude of last point
    +
    194C> - 13 Longitude of last point
    +
    195C> @param[out] KBMS Bitmap describing location of output elements.
    +
    196C> (always constructed)
    +
    197C> @param[out] DATA Array containing the unpacked data elements.
    +
    198C> Note: 65160 is maximun field size allowable.
    +
    199C> @param[out] KPTR Array containing storage for following parameters
    +
    200C> - 1 Total length of grib message
    +
    201C> - 2 Length of indicator (section 0)
    +
    202C> - 3 Length of pds (section 1)
    +
    203C> - 4 Length of gds (section 2)
    +
    204C> - 5 Length of bms (section 3)
    +
    205C> - 6 Length of bds (section 4)
    +
    206C> - 7 Value of current byte
    +
    207C> - 8 Bit pointer
    +
    208C> - 9 Grib start bit nr
    +
    209C> - 10 Grib/grid element count
    +
    210C> - 11 Nr unused bits at end of section 3
    +
    211C> - 12 Bit map flag (copy of bms octets 5,6)
    +
    212C> - 13 Nr unused bits at end of section 2
    +
    213C> - 14 Bds flags (right adj copy of octet 4)
    +
    214C> - 15 Nr unused bits at end of section 4
    +
    215C> - 16 Reserved
    +
    216C> - 17 Reserved
    +
    217C> - 18 Reserved
    +
    218C> - 19 Binary scale factor
    +
    219C> - 20 Num bits used to pack each datum
    +
    220C> @param[out] KRET Flag indicating quality of completion.
    +
    221C>
    +
    222C> @note When decoding is completed, data at each grid point has been
    +
    223C> returned in the units specified in the grib manual.
    +
    224C>
    +
    225C> - Values for return flag (kret)
    +
    226C> - 0 - Normal return, no errors
    +
    227C> - 1 - 'grib' not found in first 100 chars
    +
    228C> - 2 - '7777' not in correct location
    +
    229C> - 3 - Unpacked field is larger than 260000
    +
    230C> - 4 - Gds/ grid not one of currently accepted values
    +
    231C> - 5 - Grid not currently avail for center indicated
    +
    232C> - 8 - Temp gds indicated, but gds flag is off
    +
    233C> - 9 - Gds indicates size mismatch with std grid
    +
    234C> - 10 - Incorrect center indicator
    +
    235C> - 11 - Binary data section (bds) not completely processed.
    +
    236C> program is not set to process flag combinations
    +
    237C> shown in octets 4 and 14.
    +
    238C> - 12 - Binary data section (bds) not completely processed.
    +
    239C> program is not set to process flag combinations
    +
    240C>
    +
    241C> @author Bill Cavanaugh @date 1991-09-13
    +
    +
    242 SUBROUTINE w3fi63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
    +
    243C
    +
    244C * WILL BE AVAILABLE IN NEXT UPDATE
    +
    245C ***************************************************************
    +
    246C
    +
    247C INCOMING MESSAGE HOLDER
    +
    248 CHARACTER*1 MSGA(*)
    +
    249C BIT MAP
    +
    250 LOGICAL*1 KBMS(*)
    +
    251C
    +
    252C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
    +
    253 INTEGER KPDS(*)
    +
    254C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
    +
    255 INTEGER KGDS(*)
    +
    256C
    +
    257C CONTAINER FOR GRIB GRID
    +
    258 REAL DATA(*)
    +
    259C
    +
    260C ARRAY OF POINTERS AND COUNTERS
    +
    261 INTEGER KPTR(*)
    +
    262C
    +
    263C *****************************************************************
    +
    264 INTEGER JSGN,JEXP,IFR,NPTS
    +
    265 REAL REALKK,FVAL1,FDIFF1
    +
    266C *****************************************************************
    +
    267C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
    +
    268C FIND 'GRIB' CHARACTERS
    +
    269C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
    +
    270C IF '7777' IS IN PROPER PLACE.
    +
    271C 3.0 PARSE PRODUCT DEFINITION SECTION.
    +
    272C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
    +
    273C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
    +
    274C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
    +
    275C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
    +
    276C DATA AND PLACE INTO PROPER ARRAY.
    +
    277C *******************************************************************
    +
    278C
    +
    279C MAIN DRIVER
    +
    280C
    +
    281C *******************************************************************
    +
    282 kptr(10) = 0
    +
    283C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
    +
    284C USING SEC COUNTS, DETERMINE IF '7777'
    +
    285C IS IN THE PROPER LOCATION
    +
    286C
    +
    287 CALL fi631(msga,kptr,kpds,kret)
    +
    288 IF(kret.NE.0) THEN
    +
    289 GO TO 900
    +
    290 END IF
    +
    291C PRINT *,'FI631 KPTR',(KPTR(I),I=1,16)
    +
    292C
    +
    293C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
    +
    294C
    +
    295 CALL fi632(msga,kptr,kpds,kret)
    +
    296 IF(kret.NE.0) THEN
    +
    297 GO TO 900
    +
    298 END IF
    +
    299C PRINT *,'FI632 KPTR',(KPTR(I),I=1,16)
    +
    300C
    +
    301C IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION
    +
    302C
    +
    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
    +
    308C PRINT *,'FI633 KPTR',(KPTR(I),I=1,16)
    +
    309 END IF
    +
    310C
    +
    311C EXTRACT OR GENERATE BIT MAP
    +
    312C
    +
    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
    +
    319C PRINT *,'FI634 KPTR',(KPTR(I),I=1,16)
    +
    320C
    +
    321C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
    +
    322C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
    +
    323C
    +
    324 IF (kpds(18).EQ.1) THEN
    +
    325 CALL fi635(msga,kptr,kpds,kgds,kbms,DATA,kret)
    +
    326 IF (kptr(3).EQ.50) THEN
    +
    327C
    +
    328C PDS EQUAL 50 BYTES
    +
    329C THEREFORE SOMETHING SPECIAL IS GOING ON
    +
    330C
    +
    331C IN THIS CASE 2ND DIFFERENCE PACKING
    +
    332C NEEDS TO BE UNDONE.
    +
    333C
    +
    334C EXTRACT FIRST VALUE FROM BYTE 41-44 PDS
    +
    335C KPTR(9) CONTAINS OFFSET TO START OF
    +
    336C GRIB MESSAGE.
    +
    337C EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS
    +
    338C
    +
    339C AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E
    +
    340C THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING
    +
    341C AND PLACED IN PDS BYTES 49-51
    +
    342C FACTOR IS A SIGNED TWO BYTE INTEGER
    +
    343C
    +
    344C ALSO NEED THE DECIMAL SCALING FROM PDS(27-28)
    +
    345C (AVAILABLE IN KPDS(22) FROM UNPACKER)
    +
    346C TO UNDO THE DECIMAL SCALING APPLIED TO THE
    +
    347C SECOND DIFFERENCES DURING UNPACKING.
    +
    348C SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE
    +
    349C BUT UNPACKER DOESNT KNOW THAT.
    +
    350C
    +
    351C CALL GBYTE (MSGA,FVAL1,KPTR(9)+384,32)
    +
    352C
    +
    353C NOTE INTEGERS, CHARACTERS AND EQUIVALENCES
    +
    354C DEFINED ABOVE TO MAKE THIS KKK EXTRACTION
    +
    355C WORK AND LINE UP ON WORD BOUNDARIES
    +
    356C
    +
    357C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    +
    358C TO THE FLOATING POINT USED ON YOUR MACHINE.
    +
    359C
    +
    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)
    +
    363C
    +
    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
    +
    373C
    +
    374C CALL GBYTE (MSGA,FDIFF1,KPTR(9)+416,32)
    +
    375C (REPLACED BY FOLLOWING EXTRACTION)
    +
    376C
    +
    377C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    +
    378C TO THE FLOATING POINT USED ON YOUR MACHINE.
    +
    379C
    +
    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)
    +
    383C
    +
    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
    +
    393C
    +
    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
    +
    399C PRINT *,'DELTA POINT 1-',FVAL1
    +
    400C PRINT *,'DELTA POINT 2-',FDIFF1
    +
    401C PRINT *,'DELTA POINT 3-',ISCAL2
    +
    402 npts = kptr(10)
    +
    403C WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/,
    +
    404C & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
    +
    405C PRINT *,'DELTA POINT 4-',KPDS(22)
    +
    406 CALL w3fi83 (DATA,npts,fval1,fdiff1,
    +
    407 & iscal2,kpds(22),kpds,kgds)
    +
    408C WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '',
    +
    409C & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
    +
    410C WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/,
    +
    411C & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS)
    +
    412 END IF
    +
    413 ELSE
    +
    414C PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18)
    +
    415 kret = 7
    +
    416 END IF
    +
    417C
    +
    418 900 RETURN
    +
    +
    419 END
    +
    420
    +
    421C> @brief Find 'grib' chars & reset pointers
    +
    422C> @author Bill Cavanaugh @date 1991-09-13
    +
    423
    +
    424C> Find 'grib; characters and set pointers to the next
    +
    425C> byte following 'grib'. If they exist extract counts from gds and
    +
    426C> bms. Extract count from bds. Determine if sum of counts actually
    +
    427C> places terminator '7777' at the correct location.
    +
    428C>
    +
    429C> Program history log:
    +
    430C> - Bill Cavanaugh 1991-09-13
    +
    431C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    432C>
    +
    433C> @param[in] MSGA Grib field - "grib" thru "7777"
    +
    434C> @param[inout] KPTR Array containing storage for following parameters
    +
    435C> - 1 Total length of grib message
    +
    436C> - 2 Length of indicator (section 0)
    +
    437C> - 3 Length of pds (section 1)
    +
    438C> - 4 Length of gds (section 2)
    +
    439C> - 5 Length of bms (section 3)
    +
    440C> - 6 Length of bds (section 4)
    +
    441C> - 7 Value of current byte
    +
    442C> - 8 Bit pointer
    +
    443C> - 9 Grib start bit nr
    +
    444C> - 10 Grib/grid element count
    +
    445C> - 11 Nr unused bits at end of section 3
    +
    446C> - 12 Bit map flag
    +
    447C> - 13 Nr unused bits at end of section 2
    +
    448C> - 14 Bds flags
    +
    449C> - 15 Nr unused bits at end of section 4
    +
    450C> @param[out] KPDS Array containing pds elements.
    +
    451C> - 1 Id of center
    +
    452C> - 2 Model identification
    +
    453C> - 3 Grid identification
    +
    454C> - 4 Gds/bms flag
    +
    455C> - 5 Indicator of parameter
    +
    456C> - 6 Type of level
    +
    457C> - 7 Height/pressure , etc of level
    +
    458C> - 8 Year of century
    +
    459C> - 9 Month of year
    +
    460C> - 10 Day of month
    +
    461C> - 11 Hour of day
    +
    462C> - 12 Minute of hour
    +
    463C> - 13 Indicator of forecast time unit
    +
    464C> - 14 Time range 1
    +
    465C> - 15 Time range 2
    +
    466C> - 16 Time range flag
    +
    467C> - 17 Number included in average
    +
    468C> @param[out] KRET Error return
    +
    469C>
    +
    470C> @note
    +
    471C> ERROR RETURNS
    +
    472C> KRET:
    +
    473C> - 1 NO 'GRIB'
    +
    474C> - 2 NO '7777' OR MISLOCATED (BY COUNTS)
    +
    475C>
    +
    476C> @author Bill Cavanaugh @date 1991-09-13
    +
    +
    477 SUBROUTINE fi631(MSGA,KPTR,KPDS,KRET)
    +
    478C
    +
    479C INCOMING MESSAGE HOLDER
    +
    480 CHARACTER*1 MSGA(*)
    +
    481C ARRAY OF POINTERS AND COUNTERS
    +
    482 INTEGER KPTR(*)
    +
    483C PRODUCT DESCRIPTION SECTION DATA.
    +
    484 INTEGER KPDS(*)
    +
    485C
    +
    486 INTEGER KRET
    +
    487C
    +
    488C ******************************************************************
    +
    489 kret = 0
    +
    490C ------------------- 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
    +
    501C -------------FOUND 'GRIB'
    +
    502C SKIP GRIB CHARACTERS
    +
    503C PRINT *,'FI631 GRIB AT',I
    +
    504 kptr(8) = kptr(9) + 32
    +
    505 CALL gbytec (msga,itotal,kptr(8),24)
    +
    506C 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
    +
    510C HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION
    +
    511C MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER
    +
    512C 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
    +
    519C CANNOT FIND END OF GRIB EDITION 1 MESSAGE
    +
    520 kret = 2
    +
    521 RETURN
    +
    522 END IF
    +
    523C ------------------- PROCESS SECTION 1
    +
    524C EXTRACT COUNT FROM PDS
    +
    525C PRINT *,'START OF PDS',KPTR(8)
    +
    526 CALL gbytec (msga,kptr(3),kptr(8),24)
    +
    527 look = kptr(8) + 56
    +
    528C EXTRACT GDS/BMS FLAG
    +
    529 CALL gbytec (msga,kpds(4),look,8)
    +
    530 kptr(8) = kptr(8) + kptr(3) * 8
    +
    531C PRINT *,'START OF GDS',KPTR(8)
    +
    532 IF (iand(kpds(4),128).NE.0) THEN
    +
    533C 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
    +
    539C PRINT *,'START OF BMS',KPTR(8)
    +
    540 IF (iand(kpds(4),64).NE.0) THEN
    +
    541C 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
    +
    547C PRINT *,'START OF BDS',KPTR(8)
    +
    548C EXTRACT COUNT FROM BDS
    +
    549 CALL gbytec (msga,kptr(6),kptr(8),24)
    +
    550C --------------- TEST FOR '7777'
    +
    551C PRINT *,(KPTR(KJ),KJ=1,10)
    +
    552 kptr(8) = kptr(8) + kptr(6) * 8
    +
    553C EXTRACT FOUR BYTES FROM THIS LOCATION
    +
    554C 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
    +
    560C 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
    +
    566C PRINT *,'KPTR',(KPTR(I),I=1,16)
    +
    567 RETURN
    +
    +
    568 END
    +
    569
    +
    570
    +
    571C> @brief Gather info from product definition sec.
    +
    572C> @author Bill Cavanaugh @date 1991-09-13
    +
    573
    +
    574C> Extract information from the product description
    +
    575C> sec , and generate label information to permit storage
    +
    576C> in office note 84 format.
    +
    577C>
    +
    578C> Program history log:
    +
    579C> - Bill Cavanaugh 1991-09-13
    +
    580C> - Bill Cavanaugh 1993-12-08 Corrected test for edition number instead
    +
    581C> of version number.
    +
    582C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    583C> - M. Baldwin 1999-01-20 Modified to handle grid 237.
    +
    584C>
    +
    585C> @param[in] MSGA Array containing grib message.
    +
    586C> @param[inout] KPTR Array containing storage for following parameters.
    +
    587C> - 1 Total length of grib message
    +
    588C> - 2 Length of indicator (section 0)
    +
    589C> - 3 Length of pds (section 1)
    +
    590C> - 4 Length of gds (section 2)
    +
    591C> - 5 Length of bms (section 3)
    +
    592C> - 6 Length of bds (section 4)
    +
    593C> - 7 Value of current byte
    +
    594C> - 8 Bit pointer
    +
    595C> - 9 Grib start bit nr
    +
    596C> - 10 Grib/grid element count
    +
    597C> - 11 Nr unused bits at end of section 3
    +
    598C> - 12 Bit map flag
    +
    599C> - 13 Nr unused bits at end of section 2
    +
    600C> - 14 Bds flags
    +
    601C> - 15 Nr unused bits at end of section 4
    +
    602C> @param[out] KPDS Array containing pds elements.
    +
    603C> - 1 Id of center
    +
    604C> - 2 Model identification
    +
    605C> - 3 Grid identification
    +
    606C> - 4 Gds/bms flag
    +
    607C> - 5 Indicator of parameter
    +
    608C> - 6 Type of level
    +
    609C> - 7 Height/pressure , etc of level
    +
    610C> - 8 Year of century
    +
    611C> - 9 Month of year
    +
    612C> - 10 Day of month
    +
    613C> - 11 Hour of day
    +
    614C> - 12 Minute of hour
    +
    615C> - 13 Indicator of forecast time unit
    +
    616C> - 14 Time range 1
    +
    617C> - 15 Time range 2
    +
    618C> - 16 Time range flag
    +
    619C> - 17 Number included in average
    +
    620C> - 18
    +
    621C> - 19
    +
    622C> - 20 Number missing from avgs/accumulations
    +
    623C> - 21 Century
    +
    624C> - 22 Units decimal scale factor
    +
    625C> - 23 Subcenter
    +
    626C> @param[out] KRET Error return.
    +
    627C>
    +
    628C> @note ERROR RETURN:
    +
    629C> - 0 - NO ERRORS
    +
    630C> - 8 - TEMP GDS INDICATED, BUT NO GDS
    +
    631C>
    +
    632C> @author Bill Cavanaugh @date 1991-09-13
    +
    633
    +
    +
    634 SUBROUTINE fi632(MSGA,KPTR,KPDS,KRET)
    +
    635
    +
    636C
    +
    637C INCOMING MESSAGE HOLDER
    +
    638 CHARACTER*1 MSGA(*)
    +
    639C
    +
    640C ARRAY OF POINTERS AND COUNTERS
    +
    641 INTEGER KPTR(*)
    +
    642C PRODUCT DESCRIPTION SECTION ENTRIES
    +
    643 INTEGER KPDS(*)
    +
    644C
    +
    645 INTEGER KRET
    +
    646 kret=0
    +
    647C ------------------- PROCESS SECTION 1
    +
    648 kptr(8) = kptr(9) + kptr(2) * 8 + 24
    +
    649C BYTE 4
    +
    650C PARAMETER TABLE VERSION NR
    +
    651 CALL gbytec (msga,kpds(19),kptr(8),8)
    +
    652 kptr(8) = kptr(8) + 8
    +
    653C BYTE 5 IDENTIFICATION OF CENTER
    +
    654 CALL gbytec (msga,kpds(1),kptr(8),8)
    +
    655 kptr(8) = kptr(8) + 8
    +
    656C BYTE 6
    +
    657C GET GENERATING PROCESS ID NR
    +
    658 CALL gbytec (msga,kpds(2),kptr(8),8)
    +
    659 kptr(8) = kptr(8) + 8
    +
    660C BYTE 7
    +
    661C GRID DEFINITION
    +
    662 CALL gbytec (msga,kpds(3),kptr(8),8)
    +
    663 kptr(8) = kptr(8) + 8
    +
    664C BYTE 8
    +
    665C GDS/BMS FLAGS
    +
    666C CALL GBYTEC (MSGA,KPDS(4),KPTR(8),8)
    +
    667 kptr(8) = kptr(8) + 8
    +
    668C BYTE 9
    +
    669C INDICATOR OF PARAMETER
    +
    670 CALL gbytec (msga,kpds(5),kptr(8),8)
    +
    671 kptr(8) = kptr(8) + 8
    +
    672C BYTE 10
    +
    673C TYPE OF LEVEL
    +
    674 CALL gbytec (msga,kpds(6),kptr(8),8)
    +
    675 kptr(8) = kptr(8) + 8
    +
    676C BYTE 11,12
    +
    677C HEIGHT/PRESSURE
    +
    678 CALL gbytec (msga,kpds(7),kptr(8),16)
    +
    679 kptr(8) = kptr(8) + 16
    +
    680C BYTE 13
    +
    681C YEAR OF CENTURY
    +
    682 CALL gbytec (msga,kpds(8),kptr(8),8)
    +
    683 kptr(8) = kptr(8) + 8
    +
    684C BYTE 14
    +
    685C MONTH OF YEAR
    +
    686 CALL gbytec (msga,kpds(9),kptr(8),8)
    +
    687 kptr(8) = kptr(8) + 8
    +
    688C BYTE 15
    +
    689C DAY OF MONTH
    +
    690 CALL gbytec (msga,kpds(10),kptr(8),8)
    +
    691 kptr(8) = kptr(8) + 8
    +
    692C BYTE 16
    +
    693C HOUR OF DAY
    +
    694 CALL gbytec (msga,kpds(11),kptr(8),8)
    +
    695 kptr(8) = kptr(8) + 8
    +
    696C BYTE 17
    +
    697C MINUTE
    +
    698 CALL gbytec (msga,kpds(12),kptr(8),8)
    +
    699 kptr(8) = kptr(8) + 8
    +
    700C BYTE 18
    +
    701C INDICATOR TIME UNIT RANGE
    +
    702 CALL gbytec (msga,kpds(13),kptr(8),8)
    +
    703 kptr(8) = kptr(8) + 8
    +
    704C BYTE 19
    +
    705C P1 - PERIOD OF TIME
    +
    706 CALL gbytec (msga,kpds(14),kptr(8),8)
    +
    707 kptr(8) = kptr(8) + 8
    +
    708C BYTE 20
    +
    709C P2 - PERIOD OF TIME
    +
    710 CALL gbytec (msga,kpds(15),kptr(8),8)
    +
    711 kptr(8) = kptr(8) + 8
    +
    712C BYTE 21
    +
    713C TIME RANGE INDICATOR
    +
    714 CALL gbytec (msga,kpds(16),kptr(8),8)
    +
    715 kptr(8) = kptr(8) + 8
    +
    716C
    +
    717C IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN
    +
    718C PDS BYTES 19-20
    +
    719C
    +
    720 IF (kpds(16).EQ.10) THEN
    +
    721 kpds(14) = kpds(14) * 256 + kpds(15)
    +
    722 kpds(15) = 0
    +
    723 END IF
    +
    724C BYTE 22,23
    +
    725C NUMBER INCLUDED IN AVERAGE
    +
    726 CALL gbytec (msga,kpds(17),kptr(8),16)
    +
    727 kptr(8) = kptr(8) + 16
    +
    728C BYTE 24
    +
    729C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS
    +
    730 CALL gbytec (msga,kpds(20),kptr(8),8)
    +
    731 kptr(8) = kptr(8) + 8
    +
    732C BYTE 25
    +
    733C 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
    +
    737C 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
    +
    741C BYTE 27-28
    +
    742C 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
    +
    754C BYTE 29
    +
    755 CALL gbytec (msga,kpds(24),kptr(8)+8,8)
    +
    756C BYTE 30
    +
    757 CALL gbytec (msga,kpds(25),kptr(8)+16,8)
    +
    758C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE
    +
    759 kptr(8) = kptr(8) + isiz * 8
    +
    760 ELSE
    +
    761C BYTE 29
    +
    762 CALL gbytec (msga,kpds(24),kptr(8)+8,8)
    +
    763C BYTE 30
    +
    764 CALL gbytec (msga,kpds(25),kptr(8)+16,8)
    +
    765C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE
    +
    766 kptr(8) = kptr(8) + 12 * 8
    +
    767C BYTES 41 - N LOCAL USE DATA
    +
    768 CALL w3fi01(lw)
    +
    769C 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
    +
    779C ----------- 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
    +
    809C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    810C * ' NMC WITHOUT A GRID DESCRIPTION SECTION'
    +
    811C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    812C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    813C 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
    +
    818C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    819C * ' ECMWF WITHOUT A GRID DESCRIPTION SECTION'
    +
    820C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    821C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    822C 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
    +
    830C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    831C * ' U.K. MET OFFICE, BRACKNELL',
    +
    832C * ' WITHOUT A GRID DESCRIPTION SECTION'
    +
    833C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    834C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    835C 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
    +
    840C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    841C * ' FNOC WITHOUT A GRID DESCRIPTION SECTION'
    +
    842C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    843C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    844C PRINT *,' W/NMC42)'
    +
    845 END IF
    +
    846 END IF
    +
    847 END IF
    +
    848 END IF
    +
    849 END IF
    +
    850 RETURN
    +
    +
    851 END
    +
    852
    +
    853C> @brief Extract info from grib-gds
    +
    854C> @author Bill Cavanaugh @date 1991-09-13
    +
    855
    +
    856C> Extract information on unlisted grid to allow
    +
    857C> conversion to office note 84 format.
    +
    858C>
    +
    859C> Program history log:
    +
    860C> - Bill Cavanaugh 1991-09-13
    +
    861C> - M. Baldwin 1995-03-20 fi633 modification to get
    +
    862C> data rep types [kgds(1)] 201 and 202 to work.
    +
    863C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    864C> - M. Baldwin 1998-09-08 Add data rep type [kgds(1)] 203
    +
    865C> - Boi Vuong 2007-04-24 Add data rep type [kgds(1)] 204
    +
    866C> - George Gayno 2010-07-20 Add data rep type [kgds(1)] 205
    +
    867C>
    +
    868C> @param[in] MSGA Array containing grib message
    +
    869C> @param[inout] KPTR Array containing storage for following parameters
    +
    870C> - 1 Total length of grib message
    +
    871C> - 2 Length of indicator (section 0)
    +
    872C> - 3 Length of pds (section 1)
    +
    873C> - 4 Length of gds (section 2)
    +
    874C> - 5 Length of bms (section 3)
    +
    875C> - 6 Length of bds (section 4)
    +
    876C> - 7 Value of current byte
    +
    877C> - 8 Bit pointer
    +
    878C> - 9 Grib start bit nr
    +
    879C> - 10 Grib/grid element count
    +
    880C> - 11 Nr unused bits at end of section 3
    +
    881C> - 12 Bit map flag
    +
    882C> - 13 Nr unused bits at end of section 2
    +
    883C> - 14 Bds flags
    +
    884C> - 15 Nr unused bits at end of section 4
    +
    885C> @param[out] KGDS Array containing gds elements.
    +
    886C> - 1) Data representation type
    +
    887C> - 19 Number of vertical coordinate parameters
    +
    888C> - 20 Octet number of the list of vertical coordinate
    +
    889C> parameters Or Octet number of the list of numbers of points
    +
    890C> in each row Or 255 if neither are present.
    +
    891C> - 21 For grids with pl, number of points in grid
    +
    892C> - 22 Number of words in each row
    +
    893C> - Longitude grids
    +
    894C> - 2) N(i) nr points on latitude circle
    +
    895C> - 3) N(j) nr points on longitude meridian
    +
    896C> - 4) La(1) latitude of origin
    +
    897C> - 5) Lo(1) longitude of origin
    +
    898C> - 6) Resolution flag
    +
    899C> - 7) La(2) latitude of extreme point
    +
    900C> - 8) Lo(2) longitude of extreme point
    +
    901C> - 9) Di longitudinal direction of increment
    +
    902C> - 10 Dj latitudinal direction increment
    +
    903C> - 11 Scanning mode flag
    +
    904C> - Polar stereographic grids
    +
    905C> - 2) N(i) nr points along lat circle
    +
    906C> - 3) N(j) nr points along lon circle
    +
    907C> - 4) La(1) latitude of origin
    +
    908C> - 5) Lo(1) longitude of origin
    +
    909C> - 6) Reserved
    +
    910C> - 7) Lov grid orientation
    +
    911C> - 8) Dx - x direction increment
    +
    912C> - 9) Dy - y direction increment
    +
    913C> - 10 Projection center flag
    +
    914C> - 11 Scanning mode
    +
    915C> - Spherical harmonic coefficients
    +
    916C> - 2 J pentagonal resolution parameter
    +
    917C> - 3 K pentagonal resolution parameter
    +
    918C> - 4 M pentagonal resolution parameter
    +
    919C> - 5 Representation type
    +
    920C> - 6 Coefficient storage mode
    +
    921C> - Mercator grids
    +
    922C> - 2 N(i) nr points on latitude circle
    +
    923C> - 3 N(j) nr points on longitude meridian
    +
    924C> - 4 La(1) latitude of origin
    +
    925C> - 5 Lo(1) longitude of origin
    +
    926C> - 6 Resolution flag
    +
    927C> - 7 La(2) latitude of last grid point
    +
    928C> - 8 Lo(2) longitude of last grid point
    +
    929C> - 9 Latin - latitude of projection intersection
    +
    930C> - 10 Reserved
    +
    931C> - 11 Scanning mode flag
    +
    932C> - 12 Longitudinal dir grid length
    +
    933C> - 13 Latitudinal dir grid length
    +
    934C> - Lambert conformal grids
    +
    935C> - 2 Nx nr points along x-axis
    +
    936C> - 3 Ny nr points along y-axis
    +
    937C> - 4 La1 lat of origin (lower left)
    +
    938C> - 5 Lo1 lon of origin (lower left)
    +
    939C> - 6 Resolution (right adj copy of octet 17)
    +
    940C> - 7 Lov - orientation of grid
    +
    941C> - 8 Dx - x-dir increment
    +
    942C> - 9 Dy - y-dir increment
    +
    943C> - 10 Projection center flag
    +
    944C> - 11 Scanning mode flag
    +
    945C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    946C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    947C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    948C> - 2 N(i) nr points on rotated latitude circle
    +
    949C> - 3 N(j) nr points on rotated longitude meridian
    +
    950C> - 4 La(1) latitude of origin
    +
    951C> - 5 Lo(1) longitude of origin
    +
    952C> - 6 Resolution flag
    +
    953C> - 7 La(2) latitude of center
    +
    954C> - 8 Lo(2) longitude of center
    +
    955C> - 9 Di longitudinal direction of increment
    +
    956C> - 10 Dj latitudinal direction increment
    +
    957C> - 11 Scanning mode flag
    +
    958C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    959C> - 2 N(i) nr points on rotated latitude circle
    +
    960C> - 3 N(j) nr points on rotated longitude meridian
    +
    961C> - 4 La(1) latitude of origin
    +
    962C> - 5 Lo(1) longitude of origin
    +
    963C> - 6 Resolution flag
    +
    964C> - 7 La(2) latitude of center
    +
    965C> - 8 Lo(2) longitude of center
    +
    966C> - 9 Di longitudinal direction of increment
    +
    967C> - 10 Dj latitudinal direction increment
    +
    968C> - 11 Scanning mode flag
    +
    969C> - 12 Latitude of last point
    +
    970C> - 13 Longitude of last point
    +
    971C> @param[out] KRET Error return
    +
    972C>
    +
    973C> @note
    +
    974C> - KRET
    +
    975C> - 0
    +
    976C> - 4 - Data representation type not currently acceptable
    +
    977C>
    +
    978C> @author Bill Cavanaugh @date 1991-09-13
    +
    979
    +
    +
    980 SUBROUTINE fi633(MSGA,KPTR,KGDS,KRET)
    +
    981
    +
    982C ************************************************************
    +
    983C INCOMING MESSAGE HOLDER
    +
    984 CHARACTER*1 MSGA(*)
    +
    985C
    +
    986C ARRAY GDS ELEMENTS
    +
    987 INTEGER KGDS(*)
    +
    988C ARRAY OF POINTERS AND COUNTERS
    +
    989 INTEGER KPTR(*)
    +
    990C
    +
    991 INTEGER KRET
    +
    992C ---------------------------------------------------------------
    +
    993 kret = 0
    +
    994C PROCESS GRID DEFINITION SECTION (IF PRESENT)
    +
    995C MAKE SURE BIT POINTER IS PROPERLY SET
    +
    996 kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + 24
    +
    997 nsave = kptr(8) - 24
    +
    998C BYTE 4
    +
    999C NV - NR OF VERT COORD PARAMETERS
    +
    1000 CALL gbytec (msga,kgds(19),kptr(8),8)
    +
    1001 kptr(8) = kptr(8) + 8
    +
    1002C BYTE 5
    +
    1003C PV - LOCATION - SEE FM92 MANUAL
    +
    1004 CALL gbytec (msga,kgds(20),kptr(8),8)
    +
    1005 kptr(8) = kptr(8) + 8
    +
    1006C BYTE 6
    +
    1007C DATA REPRESENTATION TYPE
    +
    1008 CALL gbytec (msga,kgds(1),kptr(8),8)
    +
    1009 kptr(8) = kptr(8) + 8
    +
    1010C BYTES 7-32 ARE GRID DEFINITION DEPENDING ON
    +
    1011C 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
    +
    1022C ELSE IF (KGDS(1).EQ.10) THEN
    +
    1023C ELSE IF (KGDS(1).EQ.14) THEN
    +
    1024C ELSE IF (KGDS(1).EQ.20) THEN
    +
    1025C ELSE IF (KGDS(1).EQ.24) THEN
    +
    1026C ELSE IF (KGDS(1).EQ.30) THEN
    +
    1027C ELSE IF (KGDS(1).EQ.34) THEN
    +
    1028 ELSE IF (kgds(1).EQ.50) THEN
    +
    1029 GO TO 3000
    +
    1030C ELSE IF (KGDS(1).EQ.60) THEN
    +
    1031C ELSE IF (KGDS(1).EQ.70) THEN
    +
    1032C 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
    +
    1037C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
    +
    1038 kret = 4
    +
    1039 RETURN
    +
    1040 END IF
    +
    1041C BYTE 33-N VERTICAL COORDINATE PARAMETERS
    +
    1042C -----------
    +
    1043C BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION
    +
    1044C OR STRETCHING OF THE COORDINATE SYSTEM OR
    +
    1045C LAMBERT CONFORMAL PROJECTION.
    +
    1046C BYTE 43-N VERTICAL COORDINATE PARAMETERS
    +
    1047C -----------
    +
    1048C BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED
    +
    1049C AND ROTATED COORDINATE SYSTEM
    +
    1050C BYTE 53-N VERTICAL COORDINATE PARAMETERS
    +
    1051C -----------
    +
    1052C ************************************************************
    +
    1053C ------------------- LATITUDE/LONGITUDE GRIDS
    +
    1054C ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED
    +
    1055C ROTATED LAT/LON GRIDS OR CURVILINEAR ORTHIGINAL GRIDS
    +
    1056C
    +
    1057C ------------------- 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
    +
    1061C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
    +
    1062 CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1063 kptr(8) = kptr(8) + 16
    +
    1064C ------------------- 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
    +
    1070C ------------------- 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
    +
    1076C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1077 CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1078 kptr(8) = kptr(8) + 8
    +
    1079C ------------------- 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
    +
    1085C ------------------- 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
    +
    1091C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
    +
    1092 CALL gbytec (msga,kgds(9),kptr(8),16)
    +
    1093 kptr(8) = kptr(8) + 16
    +
    1094C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
    +
    1095C HAVE LONGIT DIR INCREMENT
    +
    1096C ELSE IF GAUSSIAN GRID
    +
    1097C HAVE NR OF LAT CIRCLES
    +
    1098C BETWEEN POLE AND EQUATOR
    +
    1099 CALL gbytec (msga,kgds(10),kptr(8),16)
    +
    1100 kptr(8) = kptr(8) + 16
    +
    1101C ------------------- 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
    +
    1105C ------------------- 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
    +
    1111C ------------------- 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
    +
    1119C ------------------- BYTE 29-32 RESERVED
    +
    1120C SKIP TO START OF BYTE 33
    +
    1121 CALL gbytec (msga,kgds(12),kptr(8),32)
    +
    1122 kptr(8) = kptr(8) + 32
    +
    1123 ENDIF
    +
    1124C -------------------
    +
    1125 GO TO 900
    +
    1126C ******************************************************************
    +
    1127C ' POLAR STEREO PROCESSING '
    +
    1128C
    +
    1129C ------------------- 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
    +
    1133C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
    +
    1134 CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1135 kptr(8) = kptr(8) + 16
    +
    1136C ------------------- 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
    +
    1142C ------------------- 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
    +
    1148C ------------------- BYTE 17 RESERVED
    +
    1149 CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1150 kptr(8) = kptr(8) + 8
    +
    1151C ------------------- 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
    +
    1157C ------------------- 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
    +
    1163C ------------------- 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
    +
    1169C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1170 CALL gbytec (msga,kgds(10),kptr(8),8)
    +
    1171 kptr(8) = kptr(8) + 8
    +
    1172C ------------------- BYTE 28 SCANNING MODE
    +
    1173 CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1174 kptr(8) = kptr(8) + 8
    +
    1175C ------------------- BYTE 29-32 RESERVED
    +
    1176C SKIP TO START OF BYTE 33
    +
    1177 CALL gbytec (msga,kgds(12),kptr(8),32)
    +
    1178 kptr(8) = kptr(8) + 32
    +
    1179C
    +
    1180C -------------------
    +
    1181 GO TO 900
    +
    1182C
    +
    1183C ******************************************************************
    +
    1184C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
    +
    1185C
    +
    1186C ------------------- 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
    +
    1190C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
    +
    1191 CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1192 kptr(8) = kptr(8) + 16
    +
    1193C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
    +
    1194 CALL gbytec (msga,kgds(4),kptr(8),16)
    +
    1195 kptr(8) = kptr(8) + 16
    +
    1196C ------------------- BYTE 13 REPRESENTATION TYPE
    +
    1197 CALL gbytec (msga,kgds(5),kptr(8),8)
    +
    1198 kptr(8) = kptr(8) + 8
    +
    1199C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
    +
    1200 CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1201 kptr(8) = kptr(8) + 8
    +
    1202C ------------------- EMPTY FIELDS - BYTES 15 - 32
    +
    1203C SET TO START OF BYTE 33
    +
    1204 kptr(8) = kptr(8) + 18 * 8
    +
    1205 GO TO 900
    +
    1206C ******************************************************************
    +
    1207C PROCESS MERCATOR GRIDS
    +
    1208C
    +
    1209C ------------------- 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
    +
    1213C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
    +
    1214 CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1215 kptr(8) = kptr(8) + 16
    +
    1216C ------------------- 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
    +
    1222C ------------------- 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
    +
    1228C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1229 CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1230 kptr(8) = kptr(8) + 8
    +
    1231C ------------------- 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
    +
    1237C ------------------- 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
    +
    1243C ------------------- 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
    +
    1249C ------------------- BYTE 27 RESERVED
    +
    1250 CALL gbytec (msga,kgds(10),kptr(8),8)
    +
    1251 kptr(8) = kptr(8) + 8
    +
    1252C ------------------- BYTE 28 SCANNING MODE
    +
    1253 CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1254 kptr(8) = kptr(8) + 8
    +
    1255C ------------------- 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
    +
    1261C ------------------- 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
    +
    1267C ------------------- BYTE 35-42 RESERVED
    +
    1268C SKIP TO START OF BYTE 43
    +
    1269 kptr(8) = kptr(8) + 8 * 8
    +
    1270C -------------------
    +
    1271 GO TO 900
    +
    1272C ******************************************************************
    +
    1273C PROCESS LAMBERT CONFORMAL
    +
    1274C
    +
    1275C ------------------- 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
    +
    1279C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
    +
    1280 CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1281 kptr(8) = kptr(8) + 16
    +
    1282C ------------------- 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
    +
    1288C ------------------- 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
    +
    1294C ------------------- BYTE 17 RESOLUTION
    +
    1295 CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1296 kptr(8) = kptr(8) + 8
    +
    1297C ------------------- 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
    +
    1303C ------------------- BYTE 21-23 DX - X-DIR INCREMENT
    +
    1304 CALL gbytec (msga,kgds(8),kptr(8),24)
    +
    1305 kptr(8) = kptr(8) + 24
    +
    1306C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
    +
    1307 CALL gbytec (msga,kgds(9),kptr(8),24)
    +
    1308 kptr(8) = kptr(8) + 24
    +
    1309C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1310 CALL gbytec (msga,kgds(10),kptr(8),8)
    +
    1311 kptr(8) = kptr(8) + 8
    +
    1312C ------------------- BYTE 28 SCANNING MODE
    +
    1313 CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1314 kptr(8) = kptr(8) + 8
    +
    1315C ------------------- 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
    +
    1321C ------------------- 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
    +
    1327C ------------------- 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
    +
    1333C ------------------- 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
    +
    1339C ------------------- BYTE 41-42 RESERVED
    +
    1340 CALL gbytec (msga,kgds(16),kptr(8),16)
    +
    1341 kptr(8) = kptr(8) + 16
    +
    1342C -------------------
    +
    1343 900 CONTINUE
    +
    1344C
    +
    1345C MORE CODE FOR GRIDS WITH PL
    +
    1346C
    +
    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
    +
    1362C> @brief Extract or generate bit map for output
    +
    1363C> @author Bill Cavanaugh @date 1991-09-13
    +
    1364
    +
    1365C> If bit map sec is available in grib message, extract
    +
    1366C> for program use, otherwise generate an appropriate bit map.
    +
    1367C>
    +
    1368C> Program history log:
    +
    1369C> - Bill Cavanaugh 1991-09-13
    +
    1370C> - Bill Cavanaugh 1991-11-12 Modified size of ecmwf grids 5 - 8.
    +
    1371C> - Mark Iredell 1995-10-31 removed saves and prints
    +
    1372C> - W. Bostelman 1997-02-12 corrects ecmwf us grid 2 processing
    +
    1373C> - Mark Iredell 1997-09-19 vectorized bitmap decoder
    +
    1374C> - Stephen Gilbert 1998-09-02 corrected error in map size for u.s. grid 92
    +
    1375C> - M. Baldwin 1998-09-08 add grids 190,192
    +
    1376C> - M. Baldwin 1999-01-20 add grids 236,237
    +
    1377C> - Eric Rogers 2001-10-02 redefined grid #218 for 12 km eta
    +
    1378C> redefined grid 192 for new 32-km eta grid
    +
    1379C> - Stephen Gilbert 2003-06-30 added grids 145 and 146 for cmaq
    +
    1380C> and grid 175 for awips over guam.
    +
    1381C> - Boi Vuong 2004-09-02 Added awips grids 147, 148, 173 and 254
    +
    1382C> - Boi Vuong 2006-12-12 Added awips grids 120
    +
    1383C> - Boi Vuong 2007-04-20 Added awips grids 176
    +
    1384C> - Boi Vuong 2007-06-11 Added awips grids 11 to 18 and 122 to 125
    +
    1385C> and 180 to 183
    +
    1386C> - Boi Vuong 2010-08-05 Added new grid 184, 199, 83 and
    +
    1387C> redefined grid 90 for new rtma conus 1.27-km
    +
    1388C> redefined grid 91 for new rtma alaska 2.976-km
    +
    1389C> redefined grid 92 for new rtma alaska 1.488-km
    +
    1390C> - Boi Vuong 2012-02-28 Added new grid 200
    +
    1391C>
    +
    1392C> @param[in] MSGA Bufr message
    +
    1393C> @param[inout] KPTR Array containing storage for following parameters
    +
    1394C> - 1 Total length of grib message
    +
    1395C> - 2 Length of indicator (section 0)
    +
    1396C> - 3 Length of pds (section 1)
    +
    1397C> - 4 Length of gds (section 2)
    +
    1398C> - 5 Length of bms (section 3)
    +
    1399C> - 6 Length of bds (section 4)
    +
    1400C> - 7 Value of current byte
    +
    1401C> - 8 Bit pointer
    +
    1402C> - 9 Grib start bit nr
    +
    1403C> - 10 Grib/grid element count
    +
    1404C> - 11 Nr unused bits at end of section 3
    +
    1405C> - 12 Bit map flag
    +
    1406C> - 13 Nr unused bits at end of section 2
    +
    1407C> - 14 Bds flags
    +
    1408C> - 15 Nr unused bits at end of section 4
    +
    1409C> @param[in] KPDS Array containing pds elements.
    +
    1410C> - 1 Id of center
    +
    1411C> - 2 Model identification
    +
    1412C> - 3 Grid identification
    +
    1413C> - 4 Gds/bms flag
    +
    1414C> - 5 Indicator of parameter
    +
    1415C> - 6 Type of level
    +
    1416C> - 7 Height/pressure , etc of level
    +
    1417C> - 8 Year of century
    +
    1418C> - 9 Month of year
    +
    1419C> - 10 Day of month
    +
    1420C> - 11 Hour of day
    +
    1421C> - 12 Minute of hour
    +
    1422C> - 13 Indicator of forecast time unit
    +
    1423C> - 14 Time range 1
    +
    1424C> - 15 Time range 2
    +
    1425C> - 16 Time range flag
    +
    1426C> - 17 Number included in average
    +
    1427C> @param[in] KGDS Array containing gds elements.
    +
    1428C> - 1) Data representation type
    +
    1429C> - 19 Number of vertical coordinate parameters
    +
    1430C> - 20 Octet number of the list of vertical coordinate
    +
    1431C> parameters Or Octet number of the list of numbers of points
    +
    1432C> in each row Or 255 if neither are present.
    +
    1433C> - 21 For grids with pl, number of points in grid
    +
    1434C> - 22 Number of words in each row
    +
    1435C> - Longitude grids
    +
    1436C> - 2) N(i) nr points on latitude circle
    +
    1437C> - 3) N(j) nr points on longitude meridian
    +
    1438C> - 4) La(1) latitude of origin
    +
    1439C> - 5) Lo(1) longitude of origin
    +
    1440C> - 6) Resolution flag
    +
    1441C> - 7) La(2) latitude of extreme point
    +
    1442C> - 8) Lo(2) longitude of extreme point
    +
    1443C> - 9) Di longitudinal direction of increment
    +
    1444C> - 10 Dj latitudinal direction increment
    +
    1445C> - 11 Scanning mode flag
    +
    1446C> - Polar stereographic grids
    +
    1447C> - 2) N(i) nr points along lat circle
    +
    1448C> - 3) N(j) nr points along lon circle
    +
    1449C> - 4) La(1) latitude of origin
    +
    1450C> - 5) Lo(1) longitude of origin
    +
    1451C> - 6) Reserved
    +
    1452C> - 7) Lov grid orientation
    +
    1453C> - 8) Dx - x direction increment
    +
    1454C> - 9) Dy - y direction increment
    +
    1455C> - 10 Projection center flag
    +
    1456C> - 11 Scanning mode
    +
    1457C> - Spherical harmonic coefficients
    +
    1458C> - 2 J pentagonal resolution parameter
    +
    1459C> - 3 K pentagonal resolution parameter
    +
    1460C> - 4 M pentagonal resolution parameter
    +
    1461C> - 5 Representation type
    +
    1462C> - 6 Coefficient storage mode
    +
    1463C> - Mercator grids
    +
    1464C> - 2 N(i) nr points on latitude circle
    +
    1465C> - 3 N(j) nr points on longitude meridian
    +
    1466C> - 4 La(1) latitude of origin
    +
    1467C> - 5 Lo(1) longitude of origin
    +
    1468C> - 6 Resolution flag
    +
    1469C> - 7 La(2) latitude of last grid point
    +
    1470C> - 8 Lo(2) longitude of last grid point
    +
    1471C> - 9 Latin - latitude of projection intersection
    +
    1472C> - 10 Reserved
    +
    1473C> - 11 Scanning mode flag
    +
    1474C> - 12 Longitudinal dir grid length
    +
    1475C> - 13 Latitudinal dir grid length
    +
    1476C> - Lambert conformal grids
    +
    1477C> - 2 Nx nr points along x-axis
    +
    1478C> - 3 Ny nr points along y-axis
    +
    1479C> - 4 La1 lat of origin (lower left)
    +
    1480C> - 5 Lo1 lon of origin (lower left)
    +
    1481C> - 6 Resolution (right adj copy of octet 17)
    +
    1482C> - 7 Lov - orientation of grid
    +
    1483C> - 8 Dx - x-dir increment
    +
    1484C> - 9 Dy - y-dir increment
    +
    1485C> - 10 Projection center flag
    +
    1486C> - 11 Scanning mode flag
    +
    1487C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    1488C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    1489C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    1490C> - 2 N(i) nr points on rotated latitude circle
    +
    1491C> - 3 N(j) nr points on rotated longitude meridian
    +
    1492C> - 4 La(1) latitude of origin
    +
    1493C> - 5 Lo(1) longitude of origin
    +
    1494C> - 6 Resolution flag
    +
    1495C> - 7 La(2) latitude of center
    +
    1496C> - 8 Lo(2) longitude of center
    +
    1497C> - 9 Di longitudinal direction of increment
    +
    1498C> - 10 Dj latitudinal direction increment
    +
    1499C> - 11 Scanning mode flag
    +
    1500C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    1501C> - 2 N(i) nr points on rotated latitude circle
    +
    1502C> - 3 N(j) nr points on rotated longitude meridian
    +
    1503C> - 4 La(1) latitude of origin
    +
    1504C> - 5 Lo(1) longitude of origin
    +
    1505C> - 6 Resolution flag
    +
    1506C> - 7 La(2) latitude of center
    +
    1507C> - 8 Lo(2) longitude of center
    +
    1508C> - 9 Di longitudinal direction of increment
    +
    1509C> - 10 Dj latitudinal direction increment
    +
    1510C> - 11 Scanning mode flag
    +
    1511C> - 12 Latitude of last point
    +
    1512C> - 13 Longitude of last point
    +
    1513C> @param[out] KBMS Bitmap describing location of output elements.
    +
    1514C> @param[out] KRET Error return
    +
    1515C>
    +
    1516C> @note
    +
    1517C> - KRET
    +
    1518C> - 0 - No error
    +
    1519C> - 5 - Grid not avail for center indicated
    +
    1520C> - 10 - Incorrect center indicator
    +
    1521C> - 12 - Bytes 5-6 are not zero in bms, predefined bit map
    +
    1522C> not provided by this center
    +
    1523C>
    +
    1524C> @author Bill Cavanaugh @date 1991-09-13
    +
    1525
    +
    +
    1526 SUBROUTINE fi634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    +
    1527
    +
    1528C
    +
    1529C INCOMING MESSAGE HOLDER
    +
    1530 CHARACTER*1 MSGA(*)
    +
    1531C
    +
    1532C BIT MAP
    +
    1533 LOGICAL*1 KBMS(*)
    +
    1534C
    +
    1535C ARRAY OF POINTERS AND COUNTERS
    +
    1536 INTEGER KPTR(*)
    +
    1537C ARRAY OF POINTERS AND COUNTERS
    +
    1538 INTEGER KPDS(*)
    +
    1539 INTEGER KGDS(*)
    +
    1540C
    +
    1541 INTEGER KRET
    +
    1542 INTEGER MASK(8)
    +
    1543C ----------------------GRID 21 AND GRID 22 ARE THE SAME
    +
    1544 LOGICAL*1 GRD21( 1369)
    +
    1545C ----------------------GRID 23 AND GRID 24 ARE THE SAME
    +
    1546 LOGICAL*1 GRD23( 1369)
    +
    1547 LOGICAL*1 GRD25( 1368)
    +
    1548 LOGICAL*1 GRD26( 1368)
    +
    1549C ----------------------GRID 27 AND GRID 28 ARE THE SAME
    +
    1550C ----------------------GRID 29 AND GRID 30 ARE THE SAME
    +
    1551C ----------------------GRID 33 AND GRID 34 ARE THE SAME
    +
    1552 LOGICAL*1 GRD50( 1188)
    +
    1553C -----------------------GRID 61 AND GRID 62 ARE THE SAME
    +
    1554 LOGICAL*1 GRD61( 4186)
    +
    1555C -----------------------GRID 63 AND GRID 64 ARE THE SAME
    +
    1556 LOGICAL*1 GRD63( 4186)
    +
    1557C LOGICAL*1 GRD70(16380)/16380*.TRUE./
    +
    1558C -------------------------------------------------------------
    +
    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/
    +
    1564C LINE 1-4
    +
    1565 & 7*.false.,22*.true.,14*.false.,22*.true.,
    +
    1566 & 14*.false.,22*.true.,14*.false.,22*.true.,7*.false.,
    +
    1567C LINE 5-8
    +
    1568 & 6*.false.,24*.true.,12*.false.,24*.true.,
    +
    1569 & 12*.false.,24*.true.,12*.false.,24*.true.,6*.false.,
    +
    1570C LINE 9-12
    +
    1571 & 5*.false.,26*.true.,10*.false.,26*.true.,
    +
    1572 & 10*.false.,26*.true.,10*.false.,26*.true.,5*.false.,
    +
    1573C LINE 13-16
    +
    1574 & 4*.false.,28*.true., 8*.false.,28*.true.,
    +
    1575 & 8*.false.,28*.true., 8*.false.,28*.true.,4*.false.,
    +
    1576C LINE 17-20
    +
    1577 & 3*.false.,30*.true., 6*.false.,30*.true.,
    +
    1578 & 6*.false.,30*.true., 6*.false.,30*.true.,3*.false.,
    +
    1579C LINE 21-24
    +
    1580 & 2*.false.,32*.true., 4*.false.,32*.true.,
    +
    1581 & 4*.false.,32*.true., 4*.false.,32*.true.,2*.false.,
    +
    1582C LINE 25-28
    +
    1583 & .false.,34*.true., 2*.false.,34*.true.,
    +
    1584 & 2*.false.,34*.true., 2*.false.,34*.true., .false.,
    +
    1585C 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/
    +
    1590C
    +
    1591C PRINT *,'FI634'
    +
    1592 IF (iand(kpds(4),64).EQ.64) THEN
    +
    1593C
    +
    1594C SET UP BIT POINTER
    +
    1595C SECTION 0 SECTION 1 SECTION 2
    +
    1596 kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8) + 24
    +
    1597C
    +
    1598C BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3
    +
    1599C
    +
    1600 CALL gbytec (msga,kptr(11),kptr(8),8)
    +
    1601 kptr(8) = kptr(8) + 8
    +
    1602C
    +
    1603C BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS
    +
    1604C
    +
    1605 CALL gbytec (msga,kptr(12),kptr(8),16)
    +
    1606 kptr(8) = kptr(8) + 16
    +
    1607C IF TABLE REFERENCE = 0, EXTRACT BIT MAP
    +
    1608 IF (kptr(12).EQ.0) THEN
    +
    1609C 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
    +
    1614C 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
    +
    1630C 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
    +
    1671C EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS
    +
    1672 CALL fi634x(ibits,kptr(8),msga,kbms)
    +
    1673 END IF
    +
    1674 RETURN
    +
    1675 ELSE
    +
    1676C PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER'
    +
    1677 kret = 12
    +
    1678 RETURN
    +
    1679 END IF
    +
    1680C
    +
    1681 END IF
    +
    1682 kret = 0
    +
    1683C -------------------------------------------------------
    +
    1684C PROCESS NON-STANDARD GRID
    +
    1685C -------------------------------------------------------
    +
    1686 IF (kpds(3).EQ.255) THEN
    +
    1687C 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
    +
    1695C -------------------------------------------------------
    +
    1696C CHECK INTERNATIONAL SET
    +
    1697C -------------------------------------------------------
    +
    1698 IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
    +
    1699C ----- 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
    +
    1709C ----- 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
    +
    1719C ----- 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
    +
    1729C ----- 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
    +
    1739C ----- 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
    +
    1743C ----- 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
    +
    1753C ----- 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
    +
    1763C ----- 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
    +
    1773C -------------------------------------------------------
    +
    1774C CHECK UNITED STATES SET
    +
    1775C -------------------------------------------------------
    +
    1776 IF (kpds(1).EQ.7) THEN
    +
    1777 IF (kpds(3).LT.100) THEN
    +
    1778 IF (kpds(3).EQ.1) THEN
    +
    1779C ----- U.S. GRID 1 - MAP SIZE 1679
    +
    1780 j = 1679
    +
    1781 GO TO 800
    +
    1782 END IF
    +
    1783 IF (kpds(3).EQ.2) THEN
    +
    1784C ----- U.S. GRID 2 - MAP SIZE 10512
    +
    1785 j = 10512
    +
    1786 GO TO 800
    +
    1787 ELSE IF (kpds(3).EQ.3) THEN
    +
    1788C ----- U.S. GRID 3 - MAP SIZE 65160
    +
    1789 j = 65160
    +
    1790 GO TO 800
    +
    1791 ELSE IF (kpds(3).EQ.4) THEN
    +
    1792C ----- U.S. GRID 4 - MAP SIZE 259920
    +
    1793 j = 259920
    +
    1794 GO TO 800
    +
    1795 ELSE IF (kpds(3).EQ.5) THEN
    +
    1796C ----- U.S. GRID 5 - MAP SIZE 3021
    +
    1797 j = 3021
    +
    1798 GO TO 800
    +
    1799 ELSE IF (kpds(3).EQ.6) THEN
    +
    1800C ----- U.S. GRID 6 - MAP SIZE 2385
    +
    1801 j = 2385
    +
    1802 GO TO 800
    +
    1803 ELSE IF (kpds(3).EQ.8) THEN
    +
    1804C ----- U.S. GRID 8 - MAP SIZE 5104
    +
    1805 j = 5104
    +
    1806 GO TO 800
    +
    1807 ELSE IF (kpds(3).EQ.10) THEN
    +
    1808C ----- U.S. GRID 10 - MAP SIZE 25020
    +
    1809 j = 25020
    +
    1810 GO TO 800
    +
    1811 ELSE IF (kpds(3).EQ.11) THEN
    +
    1812C ----- U.S. GRID 11 - MAP SIZE 223920
    +
    1813 j = 223920
    +
    1814 GO TO 800
    +
    1815 ELSE IF (kpds(3).EQ.12) THEN
    +
    1816C ----- U.S. GRID 12 - MAP SIZE 99631
    +
    1817 j = 99631
    +
    1818 GO TO 800
    +
    1819 ELSE IF (kpds(3).EQ.13) THEN
    +
    1820C ----- U.S. GRID 13 - MAP SIZE 36391
    +
    1821 j = 36391
    +
    1822 GO TO 800
    +
    1823 ELSE IF (kpds(3).EQ.14) THEN
    +
    1824C ----- U.S. GRID 14 - MAP SIZE 153811
    +
    1825 j = 153811
    +
    1826 GO TO 800
    +
    1827 ELSE IF (kpds(3).EQ.15) THEN
    +
    1828C ----- U.S. GRID 15 - MAP SIZE 74987
    +
    1829 j = 74987
    +
    1830 GO TO 800
    +
    1831 ELSE IF (kpds(3).EQ.16) THEN
    +
    1832C ----- U.S. GRID 16 - MAP SIZE 214268
    +
    1833 j = 214268
    +
    1834 GO TO 800
    +
    1835 ELSE IF (kpds(3).EQ.17) THEN
    +
    1836C ----- U.S. GRID 17 - MAP SIZE 387136
    +
    1837 j = 387136
    +
    1838 GO TO 800
    +
    1839 ELSE IF (kpds(3).EQ.18) THEN
    +
    1840C ----- 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
    +
    1844C ----- 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
    +
    1848C ----- 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
    +
    1852C ----- 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
    +
    1856C ----- U.S. GRID 37-44 - MAP SIZE 3447
    +
    1857 j = 3447
    +
    1858 GO TO 800
    +
    1859 ELSE IF (kpds(3).EQ.45) THEN
    +
    1860C ----- U.S. GRID 45 - MAP SIZE 41760
    +
    1861 j = 41760
    +
    1862 GO TO 800
    +
    1863 ELSE IF (kpds(3).EQ.53) THEN
    +
    1864C ----- 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
    +
    1868C ----- 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
    +
    1872C ----- U.S GRID 67-71 - MAP SIZE 13689
    +
    1873 j = 13689
    +
    1874 GO TO 800
    +
    1875 ELSE IF (kpds(3).EQ.72) THEN
    +
    1876C ----- U.S GRID 72 - MAP SIZE 406
    +
    1877 j = 406
    +
    1878 GO TO 800
    +
    1879 ELSE IF (kpds(3).EQ.73) THEN
    +
    1880C ----- U.S GRID 73 - MAP SIZE 13056
    +
    1881 j = 13056
    +
    1882 GO TO 800
    +
    1883 ELSE IF (kpds(3).EQ.74) THEN
    +
    1884C ----- 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
    +
    1888C ----- U.S GRID 75-77 - MAP SIZE 12321
    +
    1889 j = 12321
    +
    1890 GO TO 800
    +
    1891 ELSE IF (kpds(3).EQ.83) THEN
    +
    1892C ----- 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
    +
    1896C ----- U.S GRID 85,86 - MAP SIZE 32400
    +
    1897 j = 32400
    +
    1898 GO TO 800
    +
    1899 ELSE IF (kpds(3).EQ.87) THEN
    +
    1900C ----- U.S GRID 87 - MAP SIZE 5022
    +
    1901 j = 5022
    +
    1902 GO TO 800
    +
    1903 ELSE IF (kpds(3).EQ.88) THEN
    +
    1904C ----- U.S GRID 88 - MAP SIZE 317840
    +
    1905 j = 317840
    +
    1906 GO TO 800
    +
    1907 ELSE IF (kpds(3).EQ.90) THEN
    +
    1908C ----- U.S GRID 90 - MAP SIZE 11807617
    +
    1909 j = 11807617
    +
    1910 GO TO 800
    +
    1911 ELSE IF (kpds(3).EQ.91) THEN
    +
    1912C ----- U.S GRID 91 - MAP SIZE 1822145
    +
    1913 j = 1822145
    +
    1914 GO TO 800
    +
    1915 ELSE IF (kpds(3).EQ.92) THEN
    +
    1916C ----- U.S GRID 92 - MAP SIZE 7283073
    +
    1917 j = 7283073
    +
    1918 GO TO 800
    +
    1919 ELSE IF (kpds(3).EQ.93) THEN
    +
    1920C ----- U.S GRID 93 - MAP SIZE 111723
    +
    1921 j = 111723
    +
    1922 GO TO 800
    +
    1923 ELSE IF (kpds(3).EQ.94) THEN
    +
    1924C ----- U.S GRID 94 - MAP SIZE 371875
    +
    1925 j = 371875
    +
    1926 GO TO 800
    +
    1927 ELSE IF (kpds(3).EQ.95) THEN
    +
    1928C ----- U.S GRID 95 - MAP SIZE 130325
    +
    1929 j = 130325
    +
    1930 GO TO 800
    +
    1931 ELSE IF (kpds(3).EQ.96) THEN
    +
    1932C ----- U.S GRID 96 - MAP SIZE 209253
    +
    1933 j = 209253
    +
    1934 GO TO 800
    +
    1935 ELSE IF (kpds(3).EQ.97) THEN
    +
    1936C ----- U.S GRID 97 - MAP SIZE 1508100
    +
    1937 j = 1508100
    +
    1938 GO TO 800
    +
    1939 ELSE IF (kpds(3).EQ.98) THEN
    +
    1940C ----- U.S GRID 98 - MAP SIZE 18048
    +
    1941 j = 18048
    +
    1942 GO TO 800
    +
    1943 ELSE IF (kpds(3).EQ.99) THEN
    +
    1944C ----- 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
    +
    1950C ----- U.S. GRID 100 - MAP SIZE 6889
    +
    1951 j = 6889
    +
    1952 GO TO 800
    +
    1953 ELSE IF (kpds(3).EQ.101) THEN
    +
    1954C ----- U.S. GRID 101 - MAP SIZE 10283
    +
    1955 j = 10283
    +
    1956 GO TO 800
    +
    1957 ELSE IF (kpds(3).EQ.103) THEN
    +
    1958C ----- U.S. GRID 103 - MAP SIZE 3640
    +
    1959 j = 3640
    +
    1960 GO TO 800
    +
    1961 ELSE IF (kpds(3).EQ.104) THEN
    +
    1962C ----- U.S. GRID 104 - MAP SIZE 16170
    +
    1963 j = 16170
    +
    1964 GO TO 800
    +
    1965 ELSE IF (kpds(3).EQ.105) THEN
    +
    1966C ----- U.S. GRID 105 - MAP SIZE 6889
    +
    1967 j = 6889
    +
    1968 GO TO 800
    +
    1969 ELSE IF (kpds(3).EQ.106) THEN
    +
    1970C ----- U.S. GRID 106 - MAP SIZE 19305
    +
    1971 j = 19305
    +
    1972 GO TO 800
    +
    1973 ELSE IF (kpds(3).EQ.107) THEN
    +
    1974C ----- U.S. GRID 107 - MAP SIZE 11040
    +
    1975 j = 11040
    +
    1976 GO TO 800
    +
    1977 ELSE IF (kpds(3).EQ.110) THEN
    +
    1978C ----- U.S. GRID 110 - MAP SIZE 103936
    +
    1979 j = 103936
    +
    1980 GO TO 800
    +
    1981 ELSE IF (kpds(3).EQ.120) THEN
    +
    1982C ----- U.S. GRID 120 - MAP SIZE 2020800
    +
    1983 j = 2020800
    +
    1984 GO TO 800
    +
    1985 ELSE IF (kpds(3).EQ.122) THEN
    +
    1986C ----- U.S. GRID 122 - MAP SIZE 162750
    +
    1987 j = 162750
    +
    1988 GO TO 800
    +
    1989 ELSE IF (kpds(3).EQ.123) THEN
    +
    1990C ----- U.S. GRID 123 - MAP SIZE 100800
    +
    1991 j = 100800
    +
    1992 GO TO 800
    +
    1993 ELSE IF (kpds(3).EQ.124) THEN
    +
    1994C ----- U.S. GRID 124 - MAP SIZE 75360
    +
    1995 j = 75360
    +
    1996 GO TO 800
    +
    1997 ELSE IF (kpds(3).EQ.125) THEN
    +
    1998C ----- U.S. GRID 125 - MAP SIZE 102000
    +
    1999 j = 102000
    +
    2000 GO TO 800
    +
    2001 ELSE IF (kpds(3).EQ.126) THEN
    +
    2002C ----- U.S. GRID 126 - MAP SIZE 72960
    +
    2003 j = 72960
    +
    2004 GO TO 800
    +
    2005 ELSE IF (kpds(3).EQ.127) THEN
    +
    2006C ----- U.S. GRID 127 - MAP SIZE 294912
    +
    2007 j = 294912
    +
    2008 GO TO 800
    +
    2009 ELSE IF (kpds(3).EQ.128) THEN
    +
    2010C ----- U.S. GRID 128 - MAP SIZE 663552
    +
    2011 j = 663552
    +
    2012 GO TO 800
    +
    2013 ELSE IF (kpds(3).EQ.129) THEN
    +
    2014C ----- U.S. GRID 129 - MAP SIZE 1548800
    +
    2015 j = 1548800
    +
    2016 GO TO 800
    +
    2017 ELSE IF (kpds(3).EQ.130) THEN
    +
    2018C ----- U.S. GRID 130 - MAP SIZE 151987
    +
    2019 j = 151987
    +
    2020 GO TO 800
    +
    2021 ELSE IF (kpds(3).EQ.132) THEN
    +
    2022C ----- U.S. GRID 132 - MAP SIZE 385441
    +
    2023 j = 385441
    +
    2024 GO TO 800
    +
    2025 ELSE IF (kpds(3).EQ.138) THEN
    +
    2026C ----- U.S. GRID 138 - MAP SIZE 134784
    +
    2027 j = 134784
    +
    2028 GO TO 800
    +
    2029 ELSE IF (kpds(3).EQ.139) THEN
    +
    2030C ----- U.S. GRID 139 - MAP SIZE 4160
    +
    2031 j = 4160
    +
    2032 GO TO 800
    +
    2033 ELSE IF (kpds(3).EQ.140) THEN
    +
    2034C ----- U.S. GRID 140 - MAP SIZE 32437
    +
    2035 j = 32437
    +
    2036 GO TO 800
    +
    2037C
    +
    2038 ELSE IF (kpds(3).EQ.145) THEN
    +
    2039C ----- U.S. GRID 145 - MAP SIZE 24505
    +
    2040 j = 24505
    +
    2041 GO TO 800
    +
    2042 ELSE IF (kpds(3).EQ.146) THEN
    +
    2043C ----- U.S. GRID 146 - MAP SIZE 23572
    +
    2044 j = 23572
    +
    2045 GO TO 800
    +
    2046 ELSE IF (kpds(3).EQ.147) THEN
    +
    2047C ----- U.S. GRID 147 - MAP SIZE 69412
    +
    2048 j = 69412
    +
    2049 GO TO 800
    +
    2050 ELSE IF (kpds(3).EQ.148) THEN
    +
    2051C ----- U.S. GRID 148 - MAP SIZE 117130
    +
    2052 j = 117130
    +
    2053 GO TO 800
    +
    2054 ELSE IF (kpds(3).EQ.150) THEN
    +
    2055C ----- U.S. GRID 150 - MAP SIZE 806010
    +
    2056 j = 806010
    +
    2057 GO TO 800
    +
    2058 ELSE IF (kpds(3).EQ.151) THEN
    +
    2059C ----- U.S. GRID 151 - MAP SIZE 205062
    +
    2060 j = 205062
    +
    2061 GO TO 800
    +
    2062 ELSE IF (kpds(3).EQ.160) THEN
    +
    2063C ----- U.S. GRID 160 - MAP SIZE 28080
    +
    2064 j = 28080
    +
    2065 GO TO 800
    +
    2066 ELSE IF (kpds(3).EQ.161) THEN
    +
    2067C ----- U.S. GRID 161 - MAP SIZE 14111
    +
    2068 j = 14111
    +
    2069 GO TO 800
    +
    2070 ELSE IF (kpds(3).EQ.163) THEN
    +
    2071C ----- U.S. GRID 163 - MAP SIZE 727776
    +
    2072 j = 727776
    +
    2073 GO TO 800
    +
    2074 ELSE IF (kpds(3).EQ.170) THEN
    +
    2075C ----- U.S. GRID 170 - MAP SIZE 131072
    +
    2076 j = 131072
    +
    2077 GO TO 800
    +
    2078 ELSE IF (kpds(3).EQ.171) THEN
    +
    2079C ----- U.S. GRID 171 - MAP SIZE 716100
    +
    2080 j = 716100
    +
    2081 GO TO 800
    +
    2082 ELSE IF (kpds(3).EQ.172) THEN
    +
    2083C ----- U.S. GRID 172 - MAP SIZE 489900
    +
    2084 j = 489900
    +
    2085 GO TO 800
    +
    2086 ELSE IF (kpds(3).EQ.173) THEN
    +
    2087C ----- U.S. GRID 173 - MAP SIZE 9331200
    +
    2088 j = 9331200
    +
    2089 GO TO 800
    +
    2090 ELSE IF (kpds(3).EQ.174) THEN
    +
    2091C ----- U.S. GRID 174 - MAP SIZE 4147200
    +
    2092 j = 4147200
    +
    2093 GO TO 800
    +
    2094 ELSE IF (kpds(3).EQ.175) THEN
    +
    2095C ----- U.S. GRID 175 - MAP SIZE 185704
    +
    2096 j = 185704
    +
    2097 GO TO 800
    +
    2098 ELSE IF (kpds(3).EQ.176) THEN
    +
    2099C ----- U.S. GRID 176 - MAP SIZE 76845
    +
    2100 j = 76845
    +
    2101 GO TO 800
    +
    2102 ELSE IF (kpds(3).EQ.179) THEN
    +
    2103C ----- U.S. GRID 179 - MAP SIZE 977132
    +
    2104 j = 977132
    +
    2105 GO TO 800
    +
    2106 ELSE IF (kpds(3).EQ.180) THEN
    +
    2107C ----- U.S. GRID 180 - MAP SIZE 267168
    +
    2108 j = 267168
    +
    2109 GO TO 800
    +
    2110 ELSE IF (kpds(3).EQ.181) THEN
    +
    2111C ----- U.S. GRID 181 - MAP SIZE 102860
    +
    2112 j = 102860
    +
    2113 GO TO 800
    +
    2114 ELSE IF (kpds(3).EQ.182) THEN
    +
    2115C ----- U.S. GRID 182 - MAP SIZE 64218
    +
    2116 j = 64218
    +
    2117 GO TO 800
    +
    2118 ELSE IF (kpds(3).EQ.183) THEN
    +
    2119C ----- U.S. GRID 183 - MAP SIZE 180144
    +
    2120 j = 180144
    +
    2121 GO TO 800
    +
    2122 ELSE IF (kpds(3).EQ.184) THEN
    +
    2123C ----- U.S. GRID 184 - MAP SIZE 2953665
    +
    2124 j = 2953665
    +
    2125 GO TO 800
    +
    2126 ELSE IF (kpds(3).EQ.187) THEN
    +
    2127C ----- U.S. GRID 187 - MAP SIZE 3425565
    +
    2128 j = 3425565
    +
    2129 GO TO 800
    +
    2130 ELSE IF (kpds(3).EQ.188) THEN
    +
    2131C ----- U.S. GRID 188 - MAP SIZE 563655
    +
    2132 j = 563655
    +
    2133 GO TO 800
    +
    2134 ELSE IF (kpds(3).EQ.189) THEN
    +
    2135C ----- U.S. GRID 189 - MAP SIZE 560025
    +
    2136 j = 560025
    +
    2137 GO TO 800
    +
    2138 ELSE IF (kpds(3).EQ.190) THEN
    +
    2139C ----- U.S GRID 190 - MAP SIZE 796590
    +
    2140 j = 796590
    +
    2141 GO TO 800
    +
    2142 ELSE IF (kpds(3).EQ.192) THEN
    +
    2143C ----- U.S GRID 192 - MAP SIZE 91719
    +
    2144 j = 91719
    +
    2145 GO TO 800
    +
    2146 ELSE IF (kpds(3).EQ.193) THEN
    +
    2147C ----- U.S GRID 193 - MAP SIZE 1038240
    +
    2148 j = 1038240
    +
    2149 GO TO 800
    +
    2150 ELSE IF (kpds(3).EQ.194) THEN
    +
    2151C ----- U.S GRID 194 - MAP SIZE 168640
    +
    2152 j = 168640
    +
    2153 GO TO 800
    +
    2154 ELSE IF (kpds(3).EQ.195) THEN
    +
    2155C ----- U.S. GRID 195 - MAP SIZE 22833
    +
    2156 j = 22833
    +
    2157 GO TO 800
    +
    2158 ELSE IF (kpds(3).EQ.196) THEN
    +
    2159C ----- U.S. GRID 196 - MAP SIZE 72225
    +
    2160 j = 72225
    +
    2161 GO TO 800
    +
    2162 ELSE IF (kpds(3).EQ.197) THEN
    +
    2163C ----- U.S. GRID 197 - MAP SIZE 739297
    +
    2164 j = 739297
    +
    2165 GO TO 800
    +
    2166 ELSE IF (kpds(3).EQ.198) THEN
    +
    2167C ----- U.S. GRID 198 - MAP SIZE 456225
    +
    2168 j = 456225
    +
    2169 GO TO 800
    +
    2170 ELSE IF (kpds(3).EQ.199) THEN
    +
    2171C ----- U.S. GRID 199 - MAP SIZE 37249
    +
    2172 j = 37249
    +
    2173 GO TO 800
    +
    2174 ELSE IF (iand(kpds(4),128).EQ.128) THEN
    +
    2175C ----- 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
    +
    2348C -------------------------------------------------------
    +
    2349C CHECK JAPAN METEOROLOGICAL AGENCY SET
    +
    2350C -------------------------------------------------------
    +
    2351 IF (kpds(1).EQ.34) THEN
    +
    2352 IF (iand(kpds(4),128).EQ.128) THEN
    +
    2353C PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL'
    +
    2354C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    +
    2355 GO TO 900
    +
    2356 END IF
    +
    2357 END IF
    +
    2358C -------------------------------------------------------
    +
    2359C CHECK CANADIAN SET
    +
    2360C -------------------------------------------------------
    +
    2361 IF (kpds(1).EQ.54) THEN
    +
    2362 IF (iand(kpds(4),128).EQ.128) THEN
    +
    2363C PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL'
    +
    2364C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    +
    2365 GO TO 900
    +
    2366 END IF
    +
    2367 END IF
    +
    2368C -------------------------------------------------------
    +
    2369C CHECK FNOC SET
    +
    2370C -------------------------------------------------------
    +
    2371 IF (kpds(1).EQ.58) THEN
    +
    2372 IF (kpds(3).EQ.220.OR.kpds(3).EQ.221) THEN
    +
    2373C 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
    +
    2382C 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
    +
    2391C PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL'
    +
    2392C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    +
    2393 GO TO 900
    +
    2394 END IF
    +
    2395 END IF
    +
    2396C -------------------------------------------------------
    +
    2397C CHECK UKMET SET
    +
    2398C -------------------------------------------------------
    +
    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
    +
    2404C -------------------------------------------------------
    +
    2405C CHECK ECMWF SET
    +
    2406C -------------------------------------------------------
    +
    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
    +
    2438C PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED'
    +
    2439 IF (iand(kpds(4),128).EQ.128) THEN
    +
    2440C PRINT *,'GDS WILL BE USED TO UNPACK THE DATA',
    +
    2441C * ' MAP = ',KPDS(3)
    +
    2442 GO TO 900
    +
    2443 ELSE
    +
    2444 kret = 10
    +
    2445 RETURN
    +
    2446 END IF
    +
    2447 END IF
    +
    2448C =======================================
    +
    2449C
    +
    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
    +
    2459C
    +
    2460C ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION
    +
    2461C ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE
    +
    2462C ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE
    +
    2463C ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN
    +
    2464C ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE
    +
    2465C ----- A BIT MAP.
    +
    2466C
    +
    2467 810 CONTINUE
    +
    2468C PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    +
    2469 GO TO 895
    +
    2470C
    +
    2471 820 CONTINUE
    +
    2472C PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    +
    2473 GO TO 895
    +
    2474C
    +
    2475 890 CONTINUE
    +
    2476C PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    +
    2477 895 CONTINUE
    +
    2478C PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3)
    +
    2479C
    +
    2480 900 CONTINUE
    +
    2481 j = kgds(2) * kgds(3)
    +
    2482C AFOS AFOS AFOS SPECIAL CASE
    +
    2483C 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
    +
    2489C PRINT *,'EXIT FI634'
    +
    2490 RETURN
    +
    +
    2491 END
    +
    2492C-----------------------------------------------------------------------
    +
    2493
    +
    2494C> @brief Extract bit map.
    +
    2495C> @author Mark Iredell @date 1997-09-19
    +
    2496
    +
    2497C> Extract the packed bitmap into a logical array.
    +
    2498C>
    +
    2499C> Program history log:
    +
    2500C> 97-09-19 Vectorized bitmap decoder.
    +
    2501C>
    +
    2502C> @param[in] NPTS XInteger number of points in the bitmap field
    +
    2503C> @param[in] NSKP Integer number of bits to skip in grib message
    +
    2504C> @param[in] MSGA Character*1 grib message
    +
    2505C> @param[out] KBMS Logical*1 bitmap
    +
    2506C>
    +
    2507C> @note Subprogram can be called from a multiprocessing environment.
    +
    2508C>
    +
    2509C> @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)
    +
    2516C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    2517 CALL gbytesc(msga,ichk,nskp,1,0,npts)
    +
    2518 kbms=ichk.NE.0
    +
    2519C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    +
    2520 END
    +
    2521
    +
    2522
    +
    2523C> @brief Extract grib data elements from bds
    +
    2524C> @author Bill Cavanaugh @date 1991-09-13
    +
    2525
    +
    2526C> Extract grib data from binary data section and place
    +
    2527C> into output array in proper position.
    +
    2528C>
    +
    2529C> Program history log:
    +
    2530C> - Bill Cavanaugh 1991-09-13
    +
    2531C> - Bill Cavanaugh 1994-04-01 Modified code to include decimal scaling when
    +
    2532C> calculating the value of data points specified
    +
    2533C> as being equal to the reference value
    +
    2534C> - Farley 1994-11-10 Increased mxsize from 72960 to 260000
    +
    2535C> for .5 degree sst analysis fields.
    +
    2536C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    2537C> - Mark Iredell 1998-08-31 Eliminated need for mxsize
    +
    2538C>
    +
    2539C> @param[in] MSGA Array containing grib message
    +
    2540C> @param[inout] KPTR Array containing storage for following parameters
    +
    2541C> - 1 Total length of grib message
    +
    2542C> - 2 Length of indicator (section 0)
    +
    2543C> - 3 Length of pds (section 1)
    +
    2544C> - 4 Length of gds (section 2)
    +
    2545C> - 5 Length of bms (section 3)
    +
    2546C> - 6 Length of bds (section 4)
    +
    2547C> - 7 Value of current byte
    +
    2548C> - 8 Bit pointer
    +
    2549C> - 9 Grib start bit nr
    +
    2550C> - 10 Grib/grid element count
    +
    2551C> - 11 Nr unused bits at end of section 3
    +
    2552C> - 12 Bit map flag
    +
    2553C> - 13 Nr unused bits at end of section 2
    +
    2554C> - 14 Bds flags
    +
    2555C> - 15 Nr unused bits at end of section 4
    +
    2556C> - 16 Reserved
    +
    2557C> - 17 Reserved
    +
    2558C> - 18 Reserved
    +
    2559C> - 19 Binary scale factor
    +
    2560C> - 20 Num bits used to pack each datum
    +
    2561C> @param[in] KPDS Array containing pds elements.
    +
    2562C> See initial routine
    +
    2563C> @param[in] KGDS Array containing gds elements.
    +
    2564C> - 1) Data representation type
    +
    2565C> - 19 Number of vertical coordinate parameters
    +
    2566C> - 20 Octet number of the list of vertical coordinate
    +
    2567C> parameters Or Octet number of the list of numbers of points
    +
    2568C> in each row Or 255 if neither are present.
    +
    2569C> - 21 For grids with pl, number of points in grid
    +
    2570C> - 22 Number of words in each row
    +
    2571C> - Longitude grids
    +
    2572C> - 2) N(i) nr points on latitude circle
    +
    2573C> - 3) N(j) nr points on longitude meridian
    +
    2574C> - 4) La(1) latitude of origin
    +
    2575C> - 5) Lo(1) longitude of origin
    +
    2576C> - 6) Resolution flag
    +
    2577C> - 7) La(2) latitude of extreme point
    +
    2578C> - 8) Lo(2) longitude of extreme point
    +
    2579C> - 9) Di longitudinal direction of increment
    +
    2580C> - 10 Dj latitudinal direction increment
    +
    2581C> - 11 Scanning mode flag
    +
    2582C> - Polar stereographic grids
    +
    2583C> - 2) N(i) nr points along lat circle
    +
    2584C> - 3) N(j) nr points along lon circle
    +
    2585C> - 4) La(1) latitude of origin
    +
    2586C> - 5) Lo(1) longitude of origin
    +
    2587C> - 6) Reserved
    +
    2588C> - 7) Lov grid orientation
    +
    2589C> - 8) Dx - x direction increment
    +
    2590C> - 9) Dy - y direction increment
    +
    2591C> - 10 Projection center flag
    +
    2592C> - 11 Scanning mode
    +
    2593C> - Spherical harmonic coefficients
    +
    2594C> - 2 J pentagonal resolution parameter
    +
    2595C> - 3 K pentagonal resolution parameter
    +
    2596C> - 4 M pentagonal resolution parameter
    +
    2597C> - 5 Representation type
    +
    2598C> - 6 Coefficient storage mode
    +
    2599C> - Mercator grids
    +
    2600C> - 2 N(i) nr points on latitude circle
    +
    2601C> - 3 N(j) nr points on longitude meridian
    +
    2602C> - 4 La(1) latitude of origin
    +
    2603C> - 5 Lo(1) longitude of origin
    +
    2604C> - 6 Resolution flag
    +
    2605C> - 7 La(2) latitude of last grid point
    +
    2606C> - 8 Lo(2) longitude of last grid point
    +
    2607C> - 9 Latin - latitude of projection intersection
    +
    2608C> - 10 Reserved
    +
    2609C> - 11 Scanning mode flag
    +
    2610C> - 12 Longitudinal dir grid length
    +
    2611C> - 13 Latitudinal dir grid length
    +
    2612C> - Lambert conformal grids
    +
    2613C> - 2 Nx nr points along x-axis
    +
    2614C> - 3 Ny nr points along y-axis
    +
    2615C> - 4 La1 lat of origin (lower left)
    +
    2616C> - 5 Lo1 lon of origin (lower left)
    +
    2617C> - 6 Resolution (right adj copy of octet 17)
    +
    2618C> - 7 Lov - orientation of grid
    +
    2619C> - 8 Dx - x-dir increment
    +
    2620C> - 9 Dy - y-dir increment
    +
    2621C> - 10 Projection center flag
    +
    2622C> - 11 Scanning mode flag
    +
    2623C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    2624C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    2625C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    2626C> - 2 N(i) nr points on rotated latitude circle
    +
    2627C> - 3 N(j) nr points on rotated longitude meridian
    +
    2628C> - 4 La(1) latitude of origin
    +
    2629C> - 5 Lo(1) longitude of origin
    +
    2630C> - 6 Resolution flag
    +
    2631C> - 7 La(2) latitude of center
    +
    2632C> - 8 Lo(2) longitude of center
    +
    2633C> - 9 Di longitudinal direction of increment
    +
    2634C> - 10 Dj latitudinal direction increment
    +
    2635C> - 11 Scanning mode flag
    +
    2636C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    2637C> - 2 N(i) nr points on rotated latitude circle
    +
    2638C> - 3 N(j) nr points on rotated longitude meridian
    +
    2639C> - 4 La(1) latitude of origin
    +
    2640C> - 5 Lo(1) longitude of origin
    +
    2641C> - 6 Resolution flag
    +
    2642C> - 7 La(2) latitude of center
    +
    2643C> - 8 Lo(2) longitude of center
    +
    2644C> - 9 Di longitudinal direction of increment
    +
    2645C> - 10 Dj latitudinal direction increment
    +
    2646C> - 11 Scanning mode flag
    +
    2647C> - 12 Latitude of last point
    +
    2648C> - 13 Longitude of last point
    +
    2649C> @param[in] KBMS Bitmap describing location of output elements.
    +
    2650C> -KBDS Information extracted from binary data section
    +
    2651C> - KBDS(1) - N1
    +
    2652C> - KBDS(2) - N2
    +
    2653C> - KBDS(3) - P1
    +
    2654C> - KBDS(4) - P2
    +
    2655C> - KBDS(5) - Bit pointer to 2nd order widths
    +
    2656C> - KBDS(6) - Bit pointer to 2nd order bit maps
    +
    2657C> - KBDS(7) - Bit pointer to first order values
    +
    2658C> - KBDS(8) - Bit pointer to second order values
    +
    2659C> - KBDS(9) - Bit pointer start of bds
    +
    2660C> - KBDS(10) - Bit pointer main bit map
    +
    2661C> - KBDS(11) - Binary scaling
    +
    2662C> - KBDS(12) - Decimal scaling
    +
    2663C> - KBDS(13) - Bit width of first order values
    +
    2664C> - KBDS(14) - Bit map flag
    +
    2665C> 0 = no second order bit map
    +
    2666C> 1 = second order bit map present
    +
    2667C> - KBDS(15) - Second order bit width
    +
    2668C> - KBDS(16) - Constant / different widths
    +
    2669C> 0 = constant widths
    +
    2670C> 1 = different widths
    +
    2671C> - KBDS(17) - Single datum / matrix
    +
    2672C> - 0 = single datum at each grid point
    +
    2673C> - 1 = matrix of values at each grid point
    +
    2674C> - (18-20) - Unused
    +
    2675C> @param[out] DATA Real*4 array of gridded elements in grib message.
    +
    2676C> @param[out] KRET Error return
    +
    2677C>
    +
    2678C> @note
    +
    2679C> - Error return
    +
    2680C> - 3 = Unpacked field is larger than 65160
    +
    2681C> - 6 = Does not match nr of entries for this grib/grid
    +
    2682C> - 7 = Number of bits in fill too large
    +
    2683C>
    +
    2684C> @author Bill Cavanaugh @date 1991-09-13
    +
    +
    2685 SUBROUTINE fi635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
    +
    2686
    +
    2687C
    +
    2688 CHARACTER*1 MSGA(*)
    +
    2689C
    +
    2690 LOGICAL*1 KBMS(*)
    +
    2691C
    +
    2692 INTEGER KPDS(*)
    +
    2693 INTEGER KGDS(*)
    +
    2694 INTEGER KBDS(20)
    +
    2695 INTEGER KPTR(*)
    +
    2696 INTEGER NRBITS
    +
    2697 INTEGER,ALLOCATABLE:: KSAVE(:)
    +
    2698 INTEGER KSCALE
    +
    2699C
    +
    2700 REAL DATA(*)
    +
    2701 REAL REFNCE
    +
    2702 REAL SCALE
    +
    2703 REAL REALKK
    +
    2704C
    +
    2705C
    +
    2706C CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE
    +
    2707C
    +
    2708C *************************************************************
    +
    2709C PRINT *,'ENTER FI635'
    +
    2710C SET UP BIT POINTER
    +
    2711 kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8)
    +
    2712 * + (kptr(5)*8) + 24
    +
    2713C ------------- EXTRACT FLAGS
    +
    2714C BYTE 4
    +
    2715 CALL gbytec(msga,kptr(14),kptr(8),4)
    +
    2716 kptr(8) = kptr(8) + 4
    +
    2717C --------- 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)
    +
    2722C ------------- GET SCALE FACTOR
    +
    2723C BYTES 5,6
    +
    2724C CHECK SIGN
    +
    2725 CALL gbytec (msga,ksign,kptr(8),1)
    +
    2726 kptr(8) = kptr(8) + 1
    +
    2727C 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
    +
    2735C ------------ GET REFERENCE VALUE
    +
    2736C BYTES 7,10
    +
    2737C 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
    +
    2742C
    +
    2743C THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT
    +
    2744C TO THE FLOATING POINT USED ON YOUR COMPUTER.
    +
    2745C
    +
    2746C
    +
    2747C PRINT *,109,JSGN,JEXP,IFR
    +
    2748C 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
    +
    2757C PRINT *,'SCALE ',SCALE,' REF VAL ',REFNCE
    +
    2758C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    +
    2759C BYTE 11
    +
    2760 CALL gbytec (msga,kbits,kptr(8),8)
    +
    2761 kptr(8) = kptr(8) + 8
    +
    2762 kbds(4) = kbits
    +
    2763C KBDS(13) = KBITS
    +
    2764 kptr(20) = kbits
    +
    2765 ibyt12 = kptr(8)
    +
    2766C ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT
    +
    2767C THIS IS WHERE DATA BEGINS AND AND THE PROCESSING
    +
    2768C INCLUDED IN THE FOLLOWING IF...END IF
    +
    2769C WILL BE SKIPPED
    +
    2770C PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1)
    +
    2771 IF (iand(kptr(14),1).EQ.0) THEN
    +
    2772C PRINT *,'NO EXTENDED FLAGS'
    +
    2773 ELSE
    +
    2774C BYTES 12,13
    +
    2775 CALL gbytec (msga,koctet,kptr(8),16)
    +
    2776 kptr(8) = kptr(8) + 16
    +
    2777C --------------------------- EXTENDED FLAGS
    +
    2778C BYTE 14
    +
    2779 CALL gbytec (msga,kxflag,kptr(8),8)
    +
    2780C PRINT *,'HAVE EXTENDED FLAGS',KXFLAG
    +
    2781 kptr(8) = kptr(8) + 8
    +
    2782 IF (iand(kxflag,16).EQ.0) THEN
    +
    2783C SECOND ORDER VALUES CONSTANT WIDTHS
    +
    2784 kbds(16) = 0
    +
    2785 ELSE
    +
    2786C SECOND ORDER VALUES DIFFERENT WIDTHS
    +
    2787 kbds(16) = 1
    +
    2788 END IF
    +
    2789 IF (iand(kxflag,32).EQ.0) THEN
    +
    2790C NO SECONDARY BIT MAP
    +
    2791 kbds(14) = 0
    +
    2792 ELSE
    +
    2793C HAVE SECONDARY BIT MAP
    +
    2794 kbds(14) = 1
    +
    2795 END IF
    +
    2796 IF (iand(kxflag,64).EQ.0) THEN
    +
    2797C SINGLE DATUM AT GRID POINT
    +
    2798 kbds(17) = 0
    +
    2799 ELSE
    +
    2800C MATRIX OF VALUES AT GRID POINT
    +
    2801 kbds(17) = 1
    +
    2802 END IF
    +
    2803C ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX
    +
    2804C BYTES 15,16
    +
    2805 CALL gbytec (msga,nr,kptr(8),16)
    +
    2806 kptr(8) = kptr(8) + 16
    +
    2807C ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX
    +
    2808C BYTES 17,18
    +
    2809 CALL gbytec (msga,nc,kptr(8),16)
    +
    2810 kptr(8) = kptr(8) + 16
    +
    2811C ---------------------- NRV - FIRST DIM COORD VALS
    +
    2812C BYTE 19
    +
    2813 CALL gbytec (msga,nrv,kptr(8),8)
    +
    2814 kptr(8) = kptr(8) + 8
    +
    2815C ---------------------- NC1 - NR COEFF'S OR VALUES
    +
    2816C BYTE 20
    +
    2817 CALL gbytec (msga,nc1,kptr(8),8)
    +
    2818 kptr(8) = kptr(8) + 8
    +
    2819C ---------------------- NCV - SECOND DIM COORD OR VALUE
    +
    2820C BYTE 21
    +
    2821 CALL gbytec (msga,ncv,kptr(8),8)
    +
    2822 kptr(8) = kptr(8) + 8
    +
    2823C ---------------------- NC2 - NR COEFF'S OR VALS
    +
    2824C BYTE 22
    +
    2825 CALL gbytec (msga,nc2,kptr(8),8)
    +
    2826 kptr(8) = kptr(8) + 8
    +
    2827C ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF
    +
    2828C BYTE 23
    +
    2829 CALL gbytec (msga,kphys1,kptr(8),8)
    +
    2830 kptr(8) = kptr(8) + 8
    +
    2831C ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF
    +
    2832C BYTE 24
    +
    2833 CALL gbytec (msga,kphys2,kptr(8),8)
    +
    2834 kptr(8) = kptr(8) + 8
    +
    2835C BYTES 25-N
    +
    2836 END IF
    +
    2837 IF (kbits.EQ.0) THEN
    +
    2838C 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
    +
    2851C PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS
    +
    2852 knr = (kend - kptr(8)) / kbits
    +
    2853C PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR
    +
    2854C --------------------
    +
    2855C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    +
    2856C ENTRIES.
    +
    2857C ------------- UNUSED BITS IN DATA AREA
    +
    2858C NUMBER OF BYTES IN DATA AREA
    +
    2859 nrbyte = kptr(6) - 11
    +
    2860C ------------- TOTAL NR OF USABLE BITS
    +
    2861 nrbits = nrbyte * 8 - kptr(15)
    +
    2862C ------------- TOTAL NR OF ENTRIES
    +
    2863 kentry = nrbits / kbits
    +
    2864C ALLOCATE KSAVE
    +
    2865 ALLOCATE(ksave(kentry))
    +
    2866C
    +
    2867C IF (IAND(KPTR(14),2).EQ.0) THEN
    +
    2868C PRINT *,'SOURCE VALUES IN FLOATING POINT'
    +
    2869C ELSE
    +
    2870C PRINT *,'SOURCE VALUES IN INTEGER'
    +
    2871C END IF
    +
    2872C
    +
    2873 IF (iand(kptr(14),8).EQ.0) THEN
    +
    2874C PRINT *,'PROCESSING GRID POINT DATA'
    +
    2875 IF (iand(kptr(14),4).EQ.0) THEN
    +
    2876C PRINT *,' WITH SIMPLE PACKING'
    +
    2877 IF (iand(kptr(14),1).EQ.0) THEN
    +
    2878C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    2879 GO TO 4000
    +
    2880 ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    2881C PRINT *,' WITH ADDITIONAL FLAGS',KXFLAG
    +
    2882 IF (kbds(17).EQ.0) THEN
    +
    2883C PRINT *,' SINGLE DATUM EACH GRID PT'
    +
    2884 IF (kbds(14).EQ.0) THEN
    +
    2885C PRINT *,' NO SEC BIT MAP'
    +
    2886 IF (kbds(16).EQ.0) THEN
    +
    2887C PRINT *,' SECOND ORDER',
    +
    2888C * ' VALUES CONSTANT WIDTH'
    +
    2889 ELSE IF (kbds(16).NE.0) THEN
    +
    2890C PRINT *,' SECOND ORDER',
    +
    2891C * ' VALUES DIFFERENT WIDTHS'
    +
    2892 END IF
    +
    2893 ELSE IF (kbds(14).NE.0) THEN
    +
    2894C PRINT *,' SEC BIT MAP'
    +
    2895 IF (kbds(16).EQ.0) THEN
    +
    2896C PRINT *,' SECOND ORDER',
    +
    2897C * ' VALUES CONSTANT WIDTH'
    +
    2898 ELSE IF (kbds(16).NE.0) THEN
    +
    2899C PRINT *,' SECOND ORDER',
    +
    2900C * ' VALUES DIFFERENT WIDTHS'
    +
    2901 END IF
    +
    2902 END IF
    +
    2903 ELSE IF (kbds(17).NE.0) THEN
    +
    2904C PRINT *,' MATRIX OF VALS EACH PT'
    +
    2905 IF (kbds(14).EQ.0) THEN
    +
    2906C PRINT *,' NO SEC BIT MAP'
    +
    2907 IF (kbds(16).EQ.0) THEN
    +
    2908C PRINT *,' SECOND ORDER',
    +
    2909C * ' VALUES CONSTANT WIDTH'
    +
    2910 ELSE IF (kbds(16).NE.0) THEN
    +
    2911C PRINT *,' SECOND ORDER',
    +
    2912C * ' VALUES DIFFERENT WIDTHS'
    +
    2913 END IF
    +
    2914 ELSE IF (kbds(14).NE.0) THEN
    +
    2915C PRINT *,' SEC BIT MAP'
    +
    2916 IF (kbds(16).EQ.0) THEN
    +
    2917C PRINT *,' SECOND ORDER',
    +
    2918C * ' VALUES CONSTANT WIDTH'
    +
    2919 ELSE IF (kbds(16).NE.0) THEN
    +
    2920C PRINT *,' SECOND ORDER',
    +
    2921C * ' 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
    +
    2927C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
    +
    2928 IF (iand(kptr(14),1).EQ.0) THEN
    +
    2929C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    2930 ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    2931C PRINT *,' WITH ADDITIONAL FLAGS'
    +
    2932 IF (kbds(17).EQ.0) THEN
    +
    2933C PRINT *,' SINGLE DATUM AT EACH PT'
    +
    2934 IF (kbds(14).EQ.0) THEN
    +
    2935C PRINT *,' NO SEC BIT MAP'
    +
    2936 IF (kbds(16).EQ.0) THEN
    +
    2937C PRINT *,' SECOND ORDER',
    +
    2938C * ' VALUES CONSTANT WIDTH'
    +
    2939 ELSE IF (kbds(16).NE.0) THEN
    +
    2940C PRINT *,' SECOND ORDER',
    +
    2941C * ' VALUES DIFFERENT WIDTHS'
    +
    2942 END IF
    +
    2943C 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
    +
    2948C PRINT *,' SEC BIT MAP'
    +
    2949 IF (kbds(16).EQ.0) THEN
    +
    2950C PRINT *,' SECOND ORDER',
    +
    2951C * ' VALUES CONSTANT WIDTH'
    +
    2952 ELSE IF (kbds(16).NE.0) THEN
    +
    2953C PRINT *,' SECOND ORDER',
    +
    2954C * ' 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
    +
    2961C PRINT *,' MATRIX OF VALS EACH PT'
    +
    2962 IF (kbds(14).EQ.0) THEN
    +
    2963C PRINT *,' NO SEC BIT MAP'
    +
    2964 IF (kbds(16).EQ.0) THEN
    +
    2965C PRINT *,' SECOND ORDER',
    +
    2966C * ' VALUES CONSTANT WIDTH'
    +
    2967 ELSE IF (kbds(16).NE.0) THEN
    +
    2968C PRINT *,' SECOND ORDER',
    +
    2969C * ' VALUES DIFFERENT WIDTHS'
    +
    2970 END IF
    +
    2971 ELSE IF (kbds(14).NE.0) THEN
    +
    2972C PRINT *,' SEC BIT MAP'
    +
    2973 IF (kbds(16).EQ.0) THEN
    +
    2974C PRINT *,' SECOND ORDER',
    +
    2975C * ' VALUES CONSTANT WIDTH'
    +
    2976 ELSE IF (kbds(16).NE.0) THEN
    +
    2977C PRINT *,' SECOND ORDER',
    +
    2978C * ' 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
    +
    2985C PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS'
    +
    2986 IF (iand(kptr(14),4).EQ.0) THEN
    +
    2987C PRINT *,' WITH SIMPLE PACKING'
    +
    2988 IF (iand(kptr(14),1).EQ.0) THEN
    +
    2989C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    2990 GO TO 5000
    +
    2991 ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    2992C PRINT *,' WITH ADDITIONAL FLAGS'
    +
    2993 IF (kbds(17).EQ.0) THEN
    +
    2994C PRINT *,' SINGLE DATUM EACH GRID PT'
    +
    2995 IF (kbds(14).EQ.0) THEN
    +
    2996C PRINT *,' NO SEC BIT MAP'
    +
    2997 IF (kbds(16).EQ.0) THEN
    +
    2998C PRINT *,' SECOND ORDER',
    +
    2999C * ' VALUES CONSTANT WIDTH'
    +
    3000 ELSE IF (kbds(16).NE.0) THEN
    +
    3001C PRINT *,' SECOND ORDER',
    +
    3002C * ' VALUES DIFFERENT WIDTHS'
    +
    3003 END IF
    +
    3004 ELSE IF (kbds(14).NE.0) THEN
    +
    3005C PRINT *,' SEC BIT MAP'
    +
    3006 IF (kbds(16).EQ.0) THEN
    +
    3007C PRINT *,' SECOND ORDER',
    +
    3008C * ' VALUES CONSTANT WIDTH'
    +
    3009 ELSE IF (kbds(16).NE.0) THEN
    +
    3010C PRINT *,' SECOND ORDER',
    +
    3011C * ' VALUES DIFFERENT WIDTHS'
    +
    3012 END IF
    +
    3013 END IF
    +
    3014 ELSE IF (kbds(17).NE.0) THEN
    +
    3015C PRINT *,' MATRIX OF VALS EACH PT'
    +
    3016 IF (kbds(14).EQ.0) THEN
    +
    3017C PRINT *,' NO SEC BIT MAP'
    +
    3018 IF (kbds(16).EQ.0) THEN
    +
    3019C PRINT *,' SECOND ORDER',
    +
    3020C * ' VALUES CONSTANT WIDTH'
    +
    3021 ELSE IF (kbds(16).NE.0) THEN
    +
    3022C PRINT *,' SECOND ORDER',
    +
    3023C * ' VALUES DIFFERENT WIDTHS'
    +
    3024 END IF
    +
    3025 ELSE IF (kbds(14).NE.0) THEN
    +
    3026C PRINT *,' SEC BIT MAP'
    +
    3027 IF (kbds(16).EQ.0) THEN
    +
    3028C PRINT *,' SECOND ORDER',
    +
    3029C * ' VALUES CONSTANT WIDTH'
    +
    3030 ELSE IF (kbds(16).NE.0) THEN
    +
    3031C PRINT *,' SECOND ORDER',
    +
    3032C * ' 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
    +
    3038C COMPLEX/SECOND ORDER PACKING
    +
    3039C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
    +
    3040 IF (iand(kptr(14),1).EQ.0) THEN
    +
    3041C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    3042 ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    3043C PRINT *,' WITH ADDITIONAL FLAGS'
    +
    3044 IF (kbds(17).EQ.0) THEN
    +
    3045C PRINT *,' SINGLE DATUM EACH GRID PT'
    +
    3046 IF (kbds(14).EQ.0) THEN
    +
    3047C PRINT *,' NO SEC BIT MAP'
    +
    3048 IF (kbds(16).EQ.0) THEN
    +
    3049C PRINT *,' SECOND ORDER',
    +
    3050C * ' VALUES CONSTANT WIDTH'
    +
    3051 ELSE IF (kbds(16).NE.0) THEN
    +
    3052C PRINT *,' SECOND ORDER',
    +
    3053C * ' VALUES DIFFERENT WIDTHS'
    +
    3054 END IF
    +
    3055 ELSE IF (kbds(14).NE.0) THEN
    +
    3056C PRINT *,' SEC BIT MAP'
    +
    3057 IF (kbds(16).EQ.0) THEN
    +
    3058C PRINT *,' SECOND ORDER',
    +
    3059C * ' VALUES CONSTANT WIDTH'
    +
    3060 ELSE IF (kbds(16).NE.0) THEN
    +
    3061C PRINT *,' SECOND ORDER',
    +
    3062C * ' VALUES DIFFERENT WIDTHS'
    +
    3063 END IF
    +
    3064 END IF
    +
    3065 ELSE IF (kbds(17).NE.0) THEN
    +
    3066C PRINT *,' MATRIX OF VALS EACH PT'
    +
    3067 IF (kbds(14).EQ.0) THEN
    +
    3068C PRINT *,' NO SEC BIT MAP'
    +
    3069 IF (kbds(16).EQ.0) THEN
    +
    3070C PRINT *,' SECOND ORDER',
    +
    3071C * ' VALUES CONSTANT WIDTH'
    +
    3072 ELSE IF (kbds(16).NE.0) THEN
    +
    3073C PRINT *,' SECOND ORDER',
    +
    3074C * ' VALUES DIFFERENT WIDTHS'
    +
    3075 END IF
    +
    3076 ELSE IF (kbds(14).NE.0) THEN
    +
    3077C PRINT *,' SEC BIT MAP'
    +
    3078 IF (kbds(16).EQ.0) THEN
    +
    3079C PRINT *,' SECOND ORDER',
    +
    3080C * ' VALUES CONSTANT WIDTH'
    +
    3081 ELSE IF (kbds(16).NE.0) THEN
    +
    3082C PRINT *,' SECOND ORDER',
    +
    3083C * ' 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)
    +
    3091C PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED'
    +
    3092 kret = 11
    +
    3093 RETURN
    +
    3094 4000 CONTINUE
    +
    3095C ****************************************************************
    +
    3096C
    +
    3097C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
    +
    3098C
    +
    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
    +
    3163C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS,
    +
    3164C SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
    +
    3165 5000 CONTINUE
    +
    3166C PRINT *,'CHECK POINT SPECTRAL COEFF'
    +
    3167 kptr(8) = ibyt12
    +
    3168C 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
    +
    3173C
    +
    3174C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    +
    3175C TO THE FLOATING POINT USED ON YOUR MACHINE.
    +
    3176C
    +
    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)
    +
    3187C --------------
    +
    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)
    +
    3193C PRINT *,'EXIT FI635'
    +
    3194 RETURN
    +
    +
    3195 END
    +
    3196
    +
    3197C> @brief Process second order packing.
    +
    3198C> @author Bill Cavanaugh @date 1992-09-22
    +
    3199
    +
    3200C> Process second order packing from the binary data section
    +
    3201C> (bds) for single data items grid point data.
    +
    3202C>
    +
    3203C> Program history log:
    +
    3204C> - Bill Cavanaugh 1993-06-08
    +
    3205C> - Bill Cavanaugh 1993-12-15 Modified second order pointers to first order
    +
    3206C> values and second order values correctly.
    +
    3207C> - Ralph Jones 1995-04-26 Fi636 corection for 2nd order complex
    +
    3208C> Unpacking.
    +
    3209C> - Mark Iredell 1995-10-31 Saves and prints.
    +
    3210C>
    +
    3211C> @param[in] MSGA Array containing grib message
    +
    3212C> @param[in] REFNCE Reference value
    +
    3213C> @param[in] KPTR Work array
    +
    3214C> @param[out] DATA Location of output array
    +
    3215C> - KBDS Working array
    +
    3216C> - KBDS(1) N1
    +
    3217C> - KBDS(2) N2
    +
    3218C> - KBDS(3) P1
    +
    3219C> - KBDS(4) P2
    +
    3220C> - KBDS(5) Bit pointer to 2nd order widths
    +
    3221C> - KBDS(6) Bit pointer to 2nd order bit maps
    +
    3222C> - KBDS(7) Bit pointer to first order values
    +
    3223C> - KBDS(8) Bit pointer to second order values
    +
    3224C> - KBDS(9) Bit pointer start of bds
    +
    3225C> - KBDS(10) Bit pointer main bit map
    +
    3226C> - KBDS(11) Binary scaling
    +
    3227C> - KBDS(12) Decimal scaling
    +
    3228C> - KBDS(13) Bit width of first order values
    +
    3229C> - KBDS(14) Bit map flag
    +
    3230C> - 0 = No second order bit map
    +
    3231C> - 1 = Second order bit map present
    +
    3232C> - KBDS(15) Second order bit width
    +
    3233C> - KBDS(16) Constant / different widths
    +
    3234C> - 0 = Constant widths
    +
    3235C> - 1 = Different widths
    +
    3236C> - KBDS(17) Single datum / matrix
    +
    3237C> - 0 = Single datum at each grid point
    +
    3238C> - 1 = Matrix of values at each grid point
    +
    3239C> - KBDS(18-20) Unused
    +
    3240C> @param[in] KBMS
    +
    3241C> @param[in] KPDS
    +
    3242C> @param[in] KGDS Array containing gds elements.
    +
    3243C> - 1) Data representation type
    +
    3244C> - 19 Number of vertical coordinate parameters
    +
    3245C> - 20 Octet number of the list of vertical coordinate
    +
    3246C> parameters Or Octet number of the list of numbers of points
    +
    3247C> in each row Or 255 if neither are present.
    +
    3248C> - 21 For grids with pl, number of points in grid
    +
    3249C> - 22 Number of words in each row
    +
    3250C> - Longitude grids
    +
    3251C> - 2) N(i) nr points on latitude circle
    +
    3252C> - 3) N(j) nr points on longitude meridian
    +
    3253C> - 4) La(1) latitude of origin
    +
    3254C> - 5) Lo(1) longitude of origin
    +
    3255C> - 6) Resolution flag
    +
    3256C> - 7) La(2) latitude of extreme point
    +
    3257C> - 8) Lo(2) longitude of extreme point
    +
    3258C> - 9) Di longitudinal direction of increment
    +
    3259C> - 10 Dj latitudinal direction increment
    +
    3260C> - 11 Scanning mode flag
    +
    3261C> - Polar stereographic grids
    +
    3262C> - 2) N(i) nr points along lat circle
    +
    3263C> - 3) N(j) nr points along lon circle
    +
    3264C> - 4) La(1) latitude of origin
    +
    3265C> - 5) Lo(1) longitude of origin
    +
    3266C> - 6) Reserved
    +
    3267C> - 7) Lov grid orientation
    +
    3268C> - 8) Dx - x direction increment
    +
    3269C> - 9) Dy - y direction increment
    +
    3270C> - 10 Projection center flag
    +
    3271C> - 11 Scanning mode
    +
    3272C> - Spherical harmonic coefficients
    +
    3273C> - 2 J pentagonal resolution parameter
    +
    3274C> - 3 K pentagonal resolution parameter
    +
    3275C> - 4 M pentagonal resolution parameter
    +
    3276C> - 5 Representation type
    +
    3277C> - 6 Coefficient storage mode
    +
    3278C> - Mercator grids
    +
    3279C> - 2 N(i) nr points on latitude circle
    +
    3280C> - 3 N(j) nr points on longitude meridian
    +
    3281C> - 4 La(1) latitude of origin
    +
    3282C> - 5 Lo(1) longitude of origin
    +
    3283C> - 6 Resolution flag
    +
    3284C> - 7 La(2) latitude of last grid point
    +
    3285C> - 8 Lo(2) longitude of last grid point
    +
    3286C> - 9 Latin - latitude of projection intersection
    +
    3287C> - 10 Reserved
    +
    3288C> - 11 Scanning mode flag
    +
    3289C> - 12 Longitudinal dir grid length
    +
    3290C> - 13 Latitudinal dir grid length
    +
    3291C> - Lambert conformal grids
    +
    3292C> - 2 Nx nr points along x-axis
    +
    3293C> - 3 Ny nr points along y-axis
    +
    3294C> - 4 La1 lat of origin (lower left)
    +
    3295C> - 5 Lo1 lon of origin (lower left)
    +
    3296C> - 6 Resolution (right adj copy of octet 17)
    +
    3297C> - 7 Lov - orientation of grid
    +
    3298C> - 8 Dx - x-dir increment
    +
    3299C> - 9 Dy - y-dir increment
    +
    3300C> - 10 Projection center flag
    +
    3301C> - 11 Scanning mode flag
    +
    3302C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    3303C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    3304C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    3305C> - 2 N(i) nr points on rotated latitude circle
    +
    3306C> - 3 N(j) nr points on rotated longitude meridian
    +
    3307C> - 4 La(1) latitude of origin
    +
    3308C> - 5 Lo(1) longitude of origin
    +
    3309C> - 6 Resolution flag
    +
    3310C> - 7 La(2) latitude of center
    +
    3311C> - 8 Lo(2) longitude of center
    +
    3312C> - 9 Di longitudinal direction of increment
    +
    3313C> - 10 Dj latitudinal direction increment
    +
    3314C> - 11 Scanning mode flag
    +
    3315C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    3316C> - 2 N(i) nr points on rotated latitude circle
    +
    3317C> - 3 N(j) nr points on rotated longitude meridian
    +
    3318C> - 4 La(1) latitude of origin
    +
    3319C> - 5 Lo(1) longitude of origin
    +
    3320C> - 6 Resolution flag
    +
    3321C> - 7 La(2) latitude of center
    +
    3322C> - 8 Lo(2) longitude of center
    +
    3323C> - 9 Di longitudinal direction of increment
    +
    3324C> - 10 Dj latitudinal direction increment
    +
    3325C> - 11 Scanning mode flag
    +
    3326C> - 12 Latitude of last point
    +
    3327C> - 13 Longitude of last point
    +
    3328C>
    +
    3329C> @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
    +
    3335C
    +
    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(*)
    +
    3342C
    +
    3343 LOGICAL*1 KBMS(*)
    +
    3344C
    +
    3345 CHARACTER*1 MSGA(*)
    +
    3346C
    +
    3347C ******************* SETUP ******************************
    +
    3348C PRINT *,'ENTER FI636'
    +
    3349C START OF BMS (BIT POINTER)
    +
    3350 DO i = 1,20
    +
    3351 kbds(i) = 0
    +
    3352 END DO
    +
    3353C BYTE START OF BDS
    +
    3354 ibds = kptr(2) + kptr(3) + kptr(4) + kptr(5)
    +
    3355C PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5)
    +
    3356C BIT START OF BDS
    +
    3357 jptr = ibds * 8
    +
    3358C PRINT *,'JPTR ',JPTR
    +
    3359 kbds(9) = jptr
    +
    3360C PRINT *,'START OF BDS ',KBDS(9)
    +
    3361C 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
    +
    3367C PRINT *,'BINARY SCALE VALUE =',KBDS(11)
    +
    3368C EXTRACT REFERENCE VALUE
    +
    3369C 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
    +
    3381C PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE
    +
    3382C F O BIT WIDTH
    +
    3383 CALL gbytec(msga,kbds(13),jptr+80,8)
    +
    3384 jptr = jptr + 88
    +
    3385C AT START OF BDS BYTE 12
    +
    3386C EXTRACT N1
    +
    3387 CALL gbytec (msga,kbds(1),jptr,16)
    +
    3388C PRINT *,'N1 = ',KBDS(1)
    +
    3389 jptr = jptr + 16
    +
    3390C EXTENDED FLAGS
    +
    3391 CALL gbytec (msga,kflag,jptr,8)
    +
    3392C 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
    +
    3409C EXTRACT N2
    +
    3410 CALL gbytec (msga,kbds(2),jptr,16)
    +
    3411C PRINT *,'N2 = ',KBDS(2)
    +
    3412 jptr = jptr + 16
    +
    3413C EXTRACT P1
    +
    3414 CALL gbytec (msga,kbds(3),jptr,16)
    +
    3415C PRINT *,'P1 = ',KBDS(3)
    +
    3416 jptr = jptr + 16
    +
    3417C EXTRACT P2
    +
    3418 CALL gbytec (msga,kbds(4),jptr,16)
    +
    3419C PRINT *,'P2 = ',KBDS(4)
    +
    3420 jptr = jptr + 16
    +
    3421C SKIP RESERVED BYTE
    +
    3422 jptr = jptr + 8
    +
    3423C START OF SECOND ORDER BIT WIDTHS
    +
    3424 kbds(5) = jptr
    +
    3425C COMPUTE START OF SECONDARY BIT MAP
    +
    3426 IF (kbds(14).NE.0) THEN
    +
    3427C FOR INCLUDED SECONDARY BIT MAP
    +
    3428 jptr = jptr + (kbds(3) * 8)
    +
    3429 kbds(6) = jptr
    +
    3430 ELSE
    +
    3431C FOR CONSTRUCTED SECONDARY BIT MAP
    +
    3432 kbds(6) = 0
    +
    3433 END IF
    +
    3434C CREATE POINTER TO START OF FIRST ORDER VALUES
    +
    3435 kbds(7) = kbds(9) + kbds(1) * 8 - 8
    +
    3436C PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7)
    +
    3437C CREATE POINTER TO START OF SECOND ORDER VALUES
    +
    3438 kbds(8) = kbds(9) + kbds(2) * 8 - 8
    +
    3439C PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8)
    +
    3440C PRINT *,'KBDS( 1) - N1 ',KBDS( 1)
    +
    3441C PRINT *,'KBDS( 2) - N2 ',KBDS( 2)
    +
    3442C PRINT *,'KBDS( 3) - P1 ',KBDS( 3)
    +
    3443C PRINT *,'KBDS( 4) - P2 ',KBDS( 4)
    +
    3444C PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5)
    +
    3445C PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6)
    +
    3446C PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7)
    +
    3447C PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8)
    +
    3448C PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9)
    +
    3449C PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10)
    +
    3450C PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11)
    +
    3451C PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22)
    +
    3452C PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13)
    +
    3453C PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14)
    +
    3454C PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15)
    +
    3455C PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16)
    +
    3456C PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17)
    +
    3457C PRINT *,'REFNCE VAL ',REFNCE
    +
    3458C ************************* PROCESS DATA **********************
    +
    3459 ij = 0
    +
    3460C ========================================================
    +
    3461 IF (kbds(14).EQ.0) THEN
    +
    3462C NO BIT MAP, MUST CONSTRUCT ONE
    +
    3463 IF (kgds(2).EQ.65535) THEN
    +
    3464 IF (kgds(20).EQ.255) THEN
    +
    3465C PRINT *,'CANNOT BE USED HERE'
    +
    3466 ELSE
    +
    3467C POINT TO PL
    +
    3468 lp = kptr(9) + kptr(2)*8 + kptr(3)*8 + kgds(20)*8 - 8
    +
    3469C PRINT *,'LP = ',LP
    +
    3470 jt = 0
    +
    3471 DO 2000 jz = 1, kgds(3)
    +
    3472C GET NUMBER IN CURRENT ROW
    +
    3473 CALL gbytec (msga,number,lp,16)
    +
    3474C INCREMENT TO NEXT ROW NUMBER
    +
    3475 lp = lp + 16
    +
    3476C 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
    +
    3489C ROW BY ROW
    +
    3490C PRINT *,' ROW BY ROW'
    +
    3491 kout = kgds(3)
    +
    3492 kin = kgds(2)
    +
    3493 ELSE
    +
    3494C COL BY COL
    +
    3495C PRINT *,' COL BY COL'
    +
    3496 kin = kgds(3)
    +
    3497 kout = kgds(2)
    +
    3498 END IF
    +
    3499C 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
    +
    3512C ========================================================
    +
    3513C PRINT 99,(BMAP2(J),J=1,110)
    +
    3514C99 FORMAT ( 10(1X,Z8.8))
    +
    3515C CALL BINARY (BMAP2,2)
    +
    3516C FOR EACH GRID POINT ENTRY
    +
    3517C
    +
    3518 scale2 = 2.0**kbds(11)
    +
    3519 scal10 = 10.0**kpds(22)
    +
    3520C PRINT *,'SCALE VALUES - ',SCALE2,SCAL10
    +
    3521 DO 1000 i = 1, kptr(10)
    +
    3522C GET NEXT MASTER BIT MAP BIT POSITION
    +
    3523C IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1)
    +
    3524 IF (kbms(i)) THEN
    +
    3525C WRITE(6,900)I,KBMS(I)
    +
    3526C 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
    +
    3532C PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT
    +
    3533 kbds(6) = kbds(6) + 1
    +
    3534 IF (kbit.NE.0) THEN
    +
    3535C PRINT *,' SOB ON'
    +
    3536C GET NEXT FIRST ORDER PACKED VALUE
    +
    3537 CALL gbytec (msga,ifoval,kbds(7),kbds(13))
    +
    3538 kbds(7) = kbds(7) + kbds(13)
    +
    3539C PRINT *,'FOVAL =',IFOVAL
    +
    3540C GET SECOND ORDER BIT WIDTH
    +
    3541 CALL gbytec (msga,kbds(15),kbds(5),8)
    +
    3542 kbds(5) = kbds(5) + 8
    +
    3543C PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=',
    +
    3544C * ,KBDS(5), 'ISOWID =',KBDS(15)
    +
    3545 ELSE
    +
    3546C PRINT *,' SOB NOT ON'
    +
    3547 END IF
    +
    3548 isoval = 0
    +
    3549 IF (kbds(15).EQ.0) THEN
    +
    3550C IF SECOND ORDER BIT WIDTH = 0
    +
    3551C THEN SECOND ORDER VALUE IS 0
    +
    3552C SO CALCULATE DATA VALUE FOR THIS POINT
    +
    3553C 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
    +
    3560C PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10
    +
    3561 ELSE
    +
    3562C WRITE(6,901) I,KBMS(I)
    +
    3563C 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4)
    +
    3564 DATA(i) = 0.0
    +
    3565 END IF
    +
    3566C PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15)
    +
    3567 1000 CONTINUE
    +
    3568C **************************************************************
    +
    3569C PRINT *,'EXIT FI636'
    +
    3570 RETURN
    +
    +
    3571 END
    +
    3572
    +
    3573C> @brief Grib grid/size test.
    +
    3574C> @author Bill Cavanaugh @date 1991-09-13
    +
    3575
    +
    3576C> To test when gds is available to see if size mismatch
    +
    3577C> on existing grids (by center) is indicated.
    +
    3578C>
    +
    3579C> Program history log:
    +
    3580C> - Bill Cavanaugh 1991-09-13
    +
    3581C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    3582C> - M. Bostelman 1997-02-12 Corrects ecmwf us grid 2 processing
    +
    3583C> - Mark Iredell 1998-06-17 Removed alternate return
    +
    3584C> - M. Baldwin 1999-01-20 Modify to handle grid 237
    +
    3585C> - Boi Vuong 1909-05-21 Modify to handle grid 45
    +
    3586C>
    +
    3587C> @param[inout] J Size for indicated grid modified for ecmwf-us 2
    +
    3588C> @param[in] KPDS
    +
    3589C> @param[in] KGDS
    +
    3590C> @param[out] KRET Error return (a mismatch was detected if kret is not zero)
    +
    3591C>
    +
    3592C> @note
    +
    3593C> - KRET:
    +
    3594C> - 9 - Gds indicates size mismatch with std grid
    +
    3595C>
    +
    3596C> @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
    +
    3603C ---------------------------------------
    +
    3604C ---------------------------------------
    +
    3605C IF GDS NOT INDICATED, RETURN
    +
    3606C ----------------------------------------
    +
    3607 kret=0
    +
    3608 IF (iand(kpds(4),128).EQ.0) RETURN
    +
    3609C ---------------------------------------
    +
    3610C GDS IS INDICATED, PROCEED WITH TESTING
    +
    3611C ---------------------------------------
    +
    3612 IF (kgds(2).EQ.65535) THEN
    +
    3613 RETURN
    +
    3614 END IF
    +
    3615 kret=1
    +
    3616 i = kgds(2) * kgds(3)
    +
    3617C ---------------------------------------
    +
    3618C INTERNATIONAL SET
    +
    3619C ---------------------------------------
    +
    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
    +
    3636C ---------------------------------------
    +
    3637C TEST ECMWF CONTENT
    +
    3638C ---------------------------------------
    +
    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
    +
    3654C ---------------------------------------
    +
    3655C U.K. MET OFFICE, BRACKNELL
    +
    3656C ---------------------------------------
    +
    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
    +
    3667C ---------------------------------------
    +
    3668C CANADA
    +
    3669C ---------------------------------------
    +
    3670 ELSE IF (kpds(1).EQ.54) THEN
    +
    3671C PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS'
    +
    3672 RETURN
    +
    3673C ---------------------------------------
    +
    3674C JAPAN METEOROLOGICAL AGENCY
    +
    3675C ---------------------------------------
    +
    3676 ELSE IF (kpds(1).EQ.34) THEN
    +
    3677C PRINT *,' NO CURRENT LISTING OF JMA GRIDS'
    +
    3678 RETURN
    +
    3679C ---------------------------------------
    +
    3680C NAVY - FNOC
    +
    3681C ---------------------------------------
    +
    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
    +
    3699C ---------------------------------------
    +
    3700C U.S. GRIDS
    +
    3701C ---------------------------------------
    +
    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
    +
    3844C ------------------------------------
    +
    3845C NORMAL EXIT
    +
    3846C ------------------------------------
    +
    3847 kret = 0
    +
    3848 RETURN
    +
    +
    3849 END
    +
    gbytec
    subroutine gbytec(in, iout, iskip, nbyte)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition gbytec.f:14
    +
    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
    +
    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
    +
    fi631
    subroutine fi631(msga, kptr, kpds, kret)
    Find 'grib' chars & reset pointers.
    Definition w3fi63.f:478
    +
    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
    +
    fi637
    subroutine fi637(j, kpds, kgds, kret)
    Grib grid/size test.
    Definition w3fi63.f:3598
    +
    fi634x
    subroutine fi634x(npts, nskp, msga, kbms)
    Extract bit map.
    Definition w3fi63.f:2512
    +
    fi636
    subroutine fi636(data, msga, kbms, refnce, kptr, kpds, kgds)
    Process second order packing.
    Definition w3fi63.f:3331
    +
    fi632
    subroutine fi632(msga, kptr, kpds, kret)
    Gather info from product definition sec.
    Definition w3fi63.f:635
    +
    fi635
    subroutine fi635(msga, kptr, kpds, kgds, kbms, data, kret)
    Extract grib data elements from bds.
    Definition w3fi63.f:2686
    +
    fi634
    subroutine fi634(msga, kptr, kpds, kgds, kbms, kret)
    Extract or generate bit map for output.
    Definition w3fi63.f:1527
    +
    fi633
    subroutine fi633(msga, kptr, kgds, kret)
    Extract info from grib-gds.
    Definition w3fi63.f:981
    +
    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/w3fi64_8f.html b/w3fi64_8f.html index de239f63..430f43e5 100644 --- a/w3fi64_8f.html +++ b/w3fi64_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi64.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi64.f File Reference
    +
    w3fi64.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    NMC office note 29 report unpacker.

    @@ -107,8 +113,8 @@

    Definition in file w3fi64.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi64()

    + +

    ◆ w3fi64()

    @@ -117,19 +123,19 @@

    subroutine w3fi64 ( character*10, dimension(*)  - COCBUF, + cocbuf, integer, dimension(*)  - LOCRPT, + locrpt,   - NEXT  + next  @@ -250,9 +256,9 @@

    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.

    +

    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.

    +

    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)
    @@ -273,7 +279,7 @@

    next = 0

    c ------ begin unpacking loop
    20 CONTINUE
    -
    CALL w3fi64(cocbuf, locrpt, next)
    +
    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)
    @@ -295,7 +301,7 @@

    ..... etc .....

    GO TO 20
    ...............
    -
    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
    +
    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

    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...

    diff --git a/w3fi64_8f.js b/w3fi64_8f.js index e0556170..eda09441 100644 --- a/w3fi64_8f.js +++ b/w3fi64_8f.js @@ -1,4 +1,4 @@ var w3fi64_8f = [ - [ "w3fi64", "w3fi64_8f.html#abd64595a92fa11f1d11661e1e94b9dcc", null ] + [ "w3fi64", "w3fi64_8f.html#a450e698ffae06cf8cd67fa9e2ba1170b", null ] ]; \ No newline at end of file diff --git a/w3fi64_8f_source.html b/w3fi64_8f_source.html index db0c9d64..3dbf6d7d 100644 --- a/w3fi64_8f_source.html +++ b/w3fi64_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi64.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,788 +81,796 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi64.f
    +
    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
    -
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief NMC office note 29 report unpacker.
    +
    3C> @author L. Marx @date 1990-01
    +
    4
    +
    5C> Unpacks an array of upper-air reports that are packed in
    +
    6C> the format described by NMC office note 29, or unpacks an array
    +
    7C> of surface reports that are packed in the format described by NMC
    +
    8C> office note 124. Input character data are converted to integer,
    +
    9C> real or character type as specified in the category tables below.
    +
    10C> Missing integer data are replaced with 99999, missing real data
    +
    11C> are replaced with 99999.0 and missing character data are replaced
    +
    12C> with blanks. This library is similar to w3ai02() except w3ai02()
    +
    13C> was written in assembler and could not handle internal read errors
    +
    14C> (program calling w3ai02() would fail in this case w/o explanation).
    +
    15C>
    +
    16C> Program history log:
    +
    17C> - L. Marx 1990-01 Converted code from assembler
    +
    18C> to vs fortran; Expanded error return codes in 'NEXT'
    +
    19C> - Dennis Keyser 1991-07-22 Use same arguments as w3ai02() ;
    +
    20C> Streamlined code; Docblocked and commented; Diag-
    +
    21C> nostic print for errors; Attempts to skip to NEXT
    +
    22C> report in same record rather than exiting record.
    +
    23C> - Dennis Keyser 1991-08-12 Slight changes to make sub-
    +
    24C> program more portable; Test for absence of end-
    +
    25C> of-record indicator, will gracefully exit record.
    +
    26C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran
    +
    27C> - Dennis Keyser 1992-08-06 Corrected error which could
    +
    28C> lead to the length for a concatenation operator
    +
    29C> being less than 1 when an input parameter spans
    +
    30C> across two 10-character words.
    +
    31C>
    +
    32C> @param[in] COCBUF Character*10 array containing a block of packed
    +
    33C> reports in nmc office note 29/124 format.
    +
    34C> @param[in] NEXT Marker indicating relative location (in bytes) of
    +
    35C> end of last report in COCBUF. Exception: NEXT must
    +
    36C> be set to zero prior to unpacking the first report of
    +
    37C> a new block of reports. subsequently, the value of
    +
    38C> NEXT returned by the previous call to w3fi64 should
    +
    39C> be used as input. (see output argument list below.)
    +
    40C> if NEXT is negative, w3fi64 will return immediately
    +
    41C> without action.
    +
    42C> @param[out] LOCRPT Array containing one unpacked report with pointers
    +
    43C> and counters to direct the user. Locrpt() must begin
    +
    44C> on a fullword boundary. Format is mixed, user must
    +
    45C> equivalence real and character arrays to this array
    +
    46C> (see below and remarks for content).
    +
    47C>
    +
    48C> ***************************************************************
    +
    49C>
    +
    50C> |word | content | unit | format |
    +
    51C> | :---- | :---------------------- | :------------------- | :----- |
    +
    52C> | 1 | latitude | 0.01 degrees | real |
    +
    53C> | 2 | longitude | 0.01 degrees west | real |
    +
    54C> | 3 | unused | | |
    +
    55C> | 4 | observation time | 0.01 hours (utc) | real |
    +
    56C> | 5 | reserved (3rd byte is | 4-characters | char*8 |
    +
    57C> | | on29 "25'th char.; 4th | left-justified | |
    +
    58C> | |byte is on29 "26'th | | |
    +
    59C> | |char." (see on29) | | |
    +
    60C> | 6 |reserved (3rd byte is | 3-characters | char*8 |
    +
    61C> | |on29 "27'th char. (see |left-justified | |
    +
    62C> | |on29) | | |
    +
    63C> | 7 |station elevation |meters | real |
    +
    64C> | 8 |instrument type |on29 table r.2 | integer|
    +
    65C> | 9 |report type |on29 table r.1 or | integer|
    +
    66C> | |on124 table s.3 | | |
    +
    67C> | 10 |ununsed | | |
    +
    68C> | 11 |stn. id. (first 4 char.) | 4-characters | char*8 |
    +
    69C> | |left-justified | | |
    +
    70C> | 12 |stn. id. (last 2 char.) | 2-characters | char*8 |
    +
    71C> | |left-justified | | |
    +
    72C> | 13 |category 1, no. levels | count | integer|
    +
    73C> | 14 |category 1, data index | count | integer|
    +
    74C> | 15 |category 2, no. levels | count | integer|
    +
    75C> | 16 |category 2, data index | count | integer|
    +
    76C> | 17 |category 3, no. levels | count | integer|
    +
    77C> | 18 |category 3, data index | count | integer|
    +
    78C> | 19 |category 4, no. levels | count | integer|
    +
    79C> | 20 |category 4, data index | count | integer|
    +
    80C> | 21 |category 5, no. levels | count | integer|
    +
    81C> | 22 |category 5, data index | count | integer|
    +
    82C> | 23 |category 6, no. levels | count | integer|
    +
    83C> | 24 |category 6, data index | count | integer|
    +
    84C> | 25 |category 7, no. levels | count | integer|
    +
    85C> | 26 |category 7, data index | count | integer|
    +
    86C> | 27 |category 8, no. levels | count | integer|
    +
    87C> | 28 |category 8, data index | count | integer|
    +
    88C> | 29 |category 51, no. levels | count | integer|
    +
    89C> | 30 |category 51, data index | count | integer|
    +
    90C> | 31 |category 52, no. levels | count | integer|
    +
    91C> | 32 |category 52, data index | count | integer|
    +
    92C> | 33 |category 9, no. levels | count | integer|
    +
    93C> | 34 |category 9, data index | count | integer|
    +
    94C> | 35-42 | zeroed out - not used | | integer|
    +
    95C> | 43-end| unpacked data groups |(see remarks) | mixed|
    +
    96C>
    +
    97C> ***************************************************************
    +
    98C>
    +
    99C> NEXT: Marker indicating relative location (in bytes)
    +
    100C> of end of current report in COCBUF. NEXT will be
    +
    101C> set to -1 if w3fi64() encounters string 'end record'
    +
    102C> in place of the NEXT report. This is the end of the
    +
    103C> block. No unpacking takes place. NEXT is set to-2
    +
    104C> when internal (logic) errors have been detected.
    +
    105C> NEXT is set to -3 when data count check fails. In
    +
    106C> both of the latter cases some data (e.g., header
    +
    107C> information) may be unpacked into LOCRPT.
    +
    108C>
    +
    109C> @note After first reading and processing the office note 85
    +
    110C> (first) date record, the user's fortran program begins a read
    +
    111C> loop as follows. For each iteration a blocked input report is
    +
    112C> read into array COCBUF. Now test the first ten characters in
    +
    113C> COCBUF for the string 'endof file' (sic). This string signals
    +
    114C> the end of input. Otherwise, set the marker 'NEXT' to zero and
    +
    115C> begin the unpacking loop.
    +
    116C>
    +
    117C> Each iteration of the unpacking loop consists of a call to
    +
    118C> w3fi64() with the current value of 'NEXT'. If 'NEXT' is -1 upon
    +
    119C> returning from w3fi64(), it has reached the end of the input
    +
    120C> record, and the user's program should read the next record as
    +
    121C> above. If 'NEXT' is -2 or -3 upon returning, there is a grievous
    +
    122C> error in the current packed input record, and the user's program
    +
    123C> should print it for examination by automation division personnel.
    +
    124C> If 'NEXT' is positive, the output structure locrpt contains
    +
    125C> an unpacked report, and the user's program should process it at
    +
    126C> this point, subsequently repeating the unpacking loop.
    +
    127C>
    +
    128C> EXAMPLE:
    +
    129C> @code{.F}
    +
    130C> CHARACTER*10 COCBUF(644)
    +
    131C> CHARACTER*8 COCRPT(1608)
    +
    132C> CHARACTER*3 CQUMAN(20)
    +
    133C> INTEGER LOCRPT(1608)
    +
    134C> REAL ROCRPT(1608),GEOMAN(20),TMPMAN(20),DPDMAN(20),
    +
    135C> $ WDRMAN(20),WSPMAN(20)
    +
    136C> EQUIVALENCE (COCRPT,LOCRPT,ROCRPT)
    +
    137C>
    +
    138C> C READ AND PROCESS THE OFFICE NOTE 85 DATE RECORD
    +
    139C> ..........
    +
    140C> C --- BEGIN READ LOOP
    +
    141C> 10 CONTINUE
    +
    142C> READ (UNIT=INP, IOSTAT=IOS, NUM=NBUF) COCBUF
    +
    143C> IF(IOS .LT. 0) GO TO (END OF INPUT)
    +
    144C> IF(IOS .GT. 0) GO TO (INPUT ERROR)
    +
    145C> IF(NBUF .GT. 6432) GO TO (BUFFER OVERFLOW)
    +
    146C> IF(COCBUF(1).EQ.'ENDOF FILE') GO TO (END OF INPUT)
    +
    147C> NEXT = 0
    +
    148C> C ------ BEGIN UNPACKING LOOP
    +
    149C> 20 CONTINUE
    +
    150C> CALL W3FI64(COCBUF, LOCRPT, NEXT)
    +
    151C> IF(NEXT .EQ. -1) GO TO 10
    +
    152C> IF(NEXT .LT. -1) GO TO (OFFICE NOTE 29/124 ERROR)
    +
    153C> RLAT = 0.01 * ROCRPT(1) (LATITUDE)
    +
    154C> ..... ETC .....
    +
    155C> C --- BEGIN CATEGORY 1 FETCH -- MANDATORY LEVEL DATA
    +
    156C> IF(LOCRPT(13) .GT. 0) THEN
    +
    157C> NLVLS = MIN(20,LOCRPT(13))
    +
    158C> INDX = LOCRPT(14)
    +
    159C> DO 66 I = 1,NLVLS
    +
    160C> GEOMAN(I) = ROCRPT(INDX)
    +
    161C> TMPMAN(I) = 0.1 * ROCRPT(INDX+1)
    +
    162C> DPDMAN(I) = 0.1 * ROCRPT(INDX+2)
    +
    163C> WDRMAN(I) = ROCRPT(INDX+3)
    +
    164C> WSPMAN(I) = ROCRPT(INDX+4)
    +
    165C> CQUMAN(I) = COCRPT(INDX+5)
    +
    166C> INDX = INDX + 6
    +
    167C> 66 CONTINUE
    +
    168C> END IF
    +
    169C> ..... ETC .....
    +
    170C> GO TO 20
    +
    171C> ...............
    +
    172C> @endcode
    +
    173C>
    +
    174C> Data from the on29/124 record is unpacked into fixed locations
    +
    175C> in words 1-12 and into indexed locations in word 43 and
    +
    176C> following. Study on29 appendix c/on124 appendix s.2 carefully.
    +
    177C> Each category (or group of fields) in the packed report has a
    +
    178C> corresponding layout in locations in array LOCRPT that may be
    +
    179C> found by using the corresponding index amount from words 14, 16,
    +
    180C> ..., 34, in array LOCRPT. For instance, if a report contains
    +
    181C> one or more packed category 3 data groups (wind data at variable
    +
    182C> pressure levels) that data will be unpacked into binary and
    +
    183C> and character fields in one or more unpacked category 3 data
    +
    184C> groups as described below. The number of levels will be stored
    +
    185C> in word 17 and the index in fullwords of the first level of
    +
    186C> unpacked data in the output array will be stored in word 18.
    +
    187C> The second level, if any, will be stored beginning four words
    +
    188C> further on, and so forth until the count in word 17 is
    +
    189C> exhausted. The field layout in each category is given below...
    +
    190C>
    +
    191C> ***************************************************************
    +
    192C> - CATEGORY 1 - MANDATORY LEVEL DATA
    +
    193C> |WORD |PARAMETER |UNITS |FORMAT
    +
    194C> |:---- |:--------- |:----------------- |:-------------|
    +
    195C> | 1 |GEOPOTENTIAL |METERS |REAL|
    +
    196C> | 2 |TEMPERATURE |0.1 DEGREES C |REAL|
    +
    197C> | 3 |DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    198C> | 4 |WIND DIRECTION |DEGREES |REAL|
    +
    199C> | 5 |WIND SPEED |KNOTS |REAL|
    +
    200C> | 6 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    201C> | | |LEFT-JUSTIFIED| |
    +
    202C> | | GEOPOTENTIAL |ON29 TABLE Q.A| |
    +
    203C> | | TEMPERATURE |ON29 TABLE Q.A| |
    +
    204C> | | DEWPOINT DEPR. |ON29 TABLE Q.C| |
    +
    205C> | | WIND |ON29 TABLE Q.A| |
    +
    206C>
    +
    207C> ***************************************************************
    +
    208C> - CATEGORY 2 - TEMPERATURE AT VARIABLE PRESSURE
    +
    209C> |WORD |PARAMETER |UNITS | FORMAT|
    +
    210C> |---- |--------- |----------------- | -------------|
    +
    211C> | 1 |PRESSURE |0.1 MILLIBARS | REAL|
    +
    212C> | 2 |TEMPERATURE |0.1 DEGREES C | REAL|
    +
    213C> | 3 |DEWPOINT DEPRESSION |0.1 DEGREES C | REAL|
    +
    214C> | 4 |QUALITY MARKERS: |EACH 1-CHARACTER | CHAR*8|
    +
    215C> | | |LEFT-JUSTIFIED| |
    +
    216C> | | PRESSURE |ON29 TABLE Q.B| |
    +
    217C> | | TEMPERATURE |ON29 TABLE Q.A| |
    +
    218C> | | DEWPOINT DEPR. |ON29 TABLE Q.C| |
    +
    219C> | | NOT USED |BLANK| |
    +
    220C>
    +
    221C> ***************************************************************
    +
    222C> - CATEGORY 3 - WINDS AT VARIABLE PRESSURE
    +
    223C> |WORD |PARAMETER | UNITS | FORMAT|
    +
    224C> |---- |--------- | ----------------- | -------------|
    +
    225C> | 1 |PRESSURE | 0.1 MILLIBARS | REAL|
    +
    226C> | 2 |WIND DIRECTION | DEGREES | REAL|
    +
    227C> | 3 |WIND SPEED | KNOTS | REAL|
    +
    228C> | 4 |QUALITY MARKERS: | EACH 1-CHARACTER | CHAR*8|
    +
    229C> | | | LEFT-JUSTIFIED| |
    +
    230C> | | PRESSURE | ON29 TABLE Q.B| |
    +
    231C> | | WIND | ON29 TABLE Q.A| |
    +
    232C> | | NOT USED | BLANK| |
    +
    233C> | | NOT USED | BLANK| |
    +
    234C>
    +
    235C> ***************************************************************
    +
    236C> - CATEGORY 4 - WINDS AT VARIABLE HEIGHTS
    +
    237C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    238C> |---- |--------- |----------------- |-------------|
    +
    239C> | 1 |GEOPOTENTIAL |METERS |REAL|
    +
    240C> | 2 |WIND DIRECTION |DEGREES |REAL|
    +
    241C> | 3 |WIND SPEED |KNOTS |REAL|
    +
    242C> | 4 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    243C> | | |LEFT-JUSTIFIED| |
    +
    244C> | | GEOPOTENTIAL |ON29 TABLE Q.B| |
    +
    245C> | | WIND |ON29 TABLE Q.A| |
    +
    246C> | | NOT USED |BLANK| |
    +
    247C> | | NOT USED |BLANK| |
    +
    248C>
    +
    249C> ***************************************************************
    +
    250C> - CATEGORY 5 - TROPOPAUSE DATA
    +
    251C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    252C> |---- |--------- |----------------- |-------------|
    +
    253C> | 1 |GEOPOTENTIAL |METERS |REAL|
    +
    254C> | 2 |TEMPERATURE |0.1 DEGREES C |REAL|
    +
    255C> | 3 |DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    256C> | 4 |WIND DIRECTION |DEGREES |REAL|
    +
    257C> | 5 |WIND SPEED |KNOTS |REAL|
    +
    258C> | 6 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    259C> | | |LEFT-JUSTIFIED| |
    +
    260C> | | PRESSURE |ON29 TABLE Q.B| |
    +
    261C> | | TEMPERATURE |ON29 TABLE Q.A| |
    +
    262C> | | DEWPOINT DEPR. |ON29 TABLE Q.C| |
    +
    263C> | | WIND |ON29 TABLE Q.A| |
    +
    264C>
    +
    265C> ***************************************************************
    +
    266C> - CATEGORY 6 - CONSTANT-LEVEL DATA (AIRCRAFT, SAT. CLOUD-DRIFT)
    +
    267C> |WORD | PARAMETER |UNITS |FORMAT|
    +
    268C> |---- | --------- |----------------- |-------------|
    +
    269C> | 1 | PRESSURE ALTITUDE |METERS |REAL|
    +
    270C> | 2 | TEMPERATURE |0.1 DEGREES C |REAL|
    +
    271C> | 3 | DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    272C> | 4 | WIND DIRECTION |DEGREES |REAL|
    +
    273C> | 5 | WIND SPEED |KNOTS |REAL|
    +
    274C> | 6 | QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    275C> | | |LEFT-JUSTIFIED| |
    +
    276C> | | PRESSURE |ON29 TABLE Q.6| |
    +
    277C> | | TEMPERATURE |ON29 TABLE Q.6| |
    +
    278C> | | DEWPOINT DEPR. |ON29 TABLE Q.6| |
    +
    279C> | | WIND |ON29 TABLE Q.6C | |
    +
    280C>
    +
    281C> ***************************************************************
    +
    282C> - CATEGORY 7 - CLOUD COVER
    +
    283C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    284C> |---- |--------- |----------------- |-------------|
    +
    285C> | 1 |PRESSURE |0.1 MILLIBARS |REAL|
    +
    286C> | 2 |AMOUNT OF CLOUDS |PER CENT |REAL|
    +
    287C> | 3 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    288C> | | |LEFT-JUSTIFIED| |
    +
    289C> | | PRESSURE |ON29 TABLE Q.7| |
    +
    290C> | | CLOUD AMOUNT |ON29 TABLE Q.7| |
    +
    291C> | | NOT USED |BLANK| |
    +
    292C> | | NOT USED |BLANK| |
    +
    293C>
    +
    294C> ***************************************************************
    +
    295C> - CATEGORY 8 - ADDITIONAL DATA
    +
    296C> |WORD |PARAMETER | UNITS |FORMAT|
    +
    297C> |---- |--------- | ----------------- |-------------|
    +
    298C> | 1 |SPECIFIED IN ON29 | VARIABLE |REAL|
    +
    299C> | |TABLE 101.1 OR | | |
    +
    300C> | |ON124 TABLE SM.8A.1 | | |
    +
    301C> | 2 |FORM OF ADD'L DATA |CODE FIGURE FROM |REAL|
    +
    302C> | | |ON29 TABLE 101 OR | |
    +
    303C> | | |ON124 TABLE SM.8A | |
    +
    304C> | 3 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    305C> | | |LEFT-JUSTIFIED | |
    +
    306C> | | VALUE 1 |ON29 TABLE Q.8 OR | |
    +
    307C> | | |ON124 TABLE SM.8B | |
    +
    308C> | | VALUE 2 |ON29 TABLE Q.8A OR | |
    +
    309C> | | |ON124 TABLE SM.8C | |
    +
    310C> | | NOT USED |BLANK | |
    +
    311C> | | NOT USED |BLANK | |
    +
    312C>
    +
    313C> ***************************************************************
    +
    314C> - CATEGORY 51 - SURFACE DATA
    +
    315C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    316C> |---- |--------- |----------------- |-------------|
    +
    317C> | 1 |SEA-LEVEL PRESSURE |0.1 MILLIBARS |REAL|
    +
    318C> | 2 |STATION PRESSURE |0.1 MILLIBARS |REAL|
    +
    319C> | 3 |WIND DIRECTION |DEGREES |REAL|
    +
    320C> | 4 |WIND SPEED |KNOTS |REAL|
    +
    321C> | 5 |AIR TEMPERATURE |0.1 DEGREES C |REAL|
    +
    322C> | 6 |DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    323C> | 7 |MAXIMUM TEMPERATURE |0.1 DEGREES C |REAL|
    +
    324C> | 8 |MINIMUM TEMPERATURE |0.1 DEGREES C |REAL|
    +
    325C> | 9 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    326C> | | |LEFT-JUSTIFIED| |
    +
    327C> | | S-LEVEL PRESS. |ON124 TABLE SM.51| |
    +
    328C> | | STATION PRESS. |ON124 TABLE SM.51| |
    +
    329C> | | WIND |ON124 TABLE SM.51| |
    +
    330C> | | AIR TEMPERATURE |ON124 TABLE SM.51| |
    +
    331C> | 10 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    332C> | | |LEFT-JUSTIFIED| |
    +
    333C> | | DEWPOINT DEPR. |ON124 TABLE SM.51| |
    +
    334C> | | NOT USED |BLANK| |
    +
    335C> | | NOT USED |BLANK| |
    +
    336C> | | NOT USED |BLANK| |
    +
    337C> | 11 |HORIZ. VISIBILITY |WMO CODE TABLE 4300 |INTEGER|
    +
    338C> | 12 |PRESENT WEATHER |WMO CODE TABLE 4677 |INTEGER|
    +
    339C> | 13 |PAST WEATHER |WMO CODE TABLE 4561 |INTEGER|
    +
    340C> | 14 |TOTAL CLOUD COVER N |WMO CODE TABLE 2700 |INTEGER|
    +
    341C> | 15 |CLOUD COVER OF C/LN |WMO CODE TABLE 2700 |INTEGER|
    +
    342C> | 16 |CLOUD TYPE OF C/L |WMO CODE TABLE 0513 |INTEGER|
    +
    343C> | 17 |CLOUD HEIGHT OF C/L |WMO CODE TABLE 1600 |INTEGER|
    +
    344C> | 18 |CLOUD TYPE OF C/M |WMO CODE TABLE 0515 |INTEGER|
    +
    345C> | 19 |CLOUD TYPE OF C/H |WMO CODE TABLE 0509 |INTEGER|
    +
    346C> | 20 |CHARACTERISTIC OF |WMO CODE TABLE 0200 |INTEGER|
    +
    347C> | |3-HR PRESS TENDENCY | | |
    +
    348C> | 21 |AMT. PRESS TENDENCY |0.1 MILLIBARS | REAL|
    +
    349C> | |(50.0 WILL BE ADDED TO INDICATE 24-HR TENDENCY)| | |
    +
    350C>
    +
    351C> ***************************************************************
    +
    352C> - CATEGORY 52 - ADDITIONAL SURFACE DATA
    +
    353C> |WORD | PARAMETER |UNITS |FORMAT|
    +
    354C> |---- | --------- |----------------- |-------------|
    +
    355C> | 1 | 6-HR PRECIPITATION |0.01 INCH |INTEGER|
    +
    356C> | 2 | SNOW DEPTH |INCH |INTEGER|
    +
    357C> | 3 | 24-HR PRECIPITATION |0.01 INCH |INTEGER|
    +
    358C> | 4 | DURATION OF PRECIP. |NO. 6-HR PERIODS |INTEGER|
    +
    359C> | 5 | PERIOD OF WAVES |SECONDS |INTEGER|
    +
    360C> | 6 | HEIGHT OF WAVES |0.5 METERS |INTEGER|
    +
    361C> | 7 | SWELL DIRECTION |WMO CODE TABLE 0877 |INTEGER|
    +
    362C> | 8 | SWELL PERIOD |SECONDS |INTEGER|
    +
    363C> | 9 | SWELL HEIGHT |0.5 METERS |INTEGER|
    +
    364C> | 10 | SEA SFC TEMPERATURE |0.1 DEGREES C |INTEGER|
    +
    365C> | 11 | SPECIAL PHEN, GEN'L | |INTEGER|
    +
    366C> | 12 | SPECIAL PHEN, DET'L | |INTEGER|
    +
    367C> | 13 | SHIP'S COURSE |WMO CODE TABLE 0700 |INTEGER|
    +
    368C> | 14 | SHIP'S AVERAGE SPEED |WMO CODE TABLE 4451 |INTEGER|
    +
    369C> | 15 | WATER EQUIVALENT OF 0.01 INCH | |INTEGER|
    +
    370C> | | SNOW AND/OR ICE| | |
    +
    371C>
    +
    372C> ***************************************************************
    +
    373C> - CATEGORY 9 - PLAIN LANGUAGE DATA (ALPHANUMERIC TEXT)
    +
    374C> |WORD |BYTES |PARAMETER |FORMAT |
    +
    375C> |---- |----- |--------------------------------------- |-------- |
    +
    376C> | 1 | 1 |INDICATOR OF CONTENT (ON124 TABLE SM.9) |CHAR*8 |
    +
    377C> | | | (1 CHARACTER)| |
    +
    378C> | | 2-4 |PLAIN LANGUAGE DATA, TEXT CHARACTERS 1-3| |
    +
    379C> | | 4-8 |NOT USED (BLANK) | |
    +
    380C> | 2 | 1-4 |PLAIN LANGUAGE DATA, TEXT CHARACTERS 4-7 |CHAR*8 |
    +
    381C> | | 4-8 |NOT USED (BLANK)| |
    +
    382C> | 3 | 1-4 |PLAIN LANGUAGE DATA, TEXT CHARACTERS 8-11 |CHAR*8 |
    +
    383C> | | 4-8 |NOT USED (BLANK)| |
    +
    384C>
    +
    385C> @note One report may unpack into more than one category having
    +
    386C> multiple levels. The unused portion of LOCRPT is not cleared.
    +
    387C>
    +
    388C> @note Entry w3ai02() duplicates processing in w3fi64() since no
    +
    389C> assembly language code in cray w3lib.
    +
    390C>
    +
    391C> @author L. Marx @date 1990-01
    +
    +
    392 SUBROUTINE w3fi64(COCBUF,LOCRPT,NEXT)
    +
    393C
    +
    394 CHARACTER*12 HOLD
    +
    395 CHARACTER*10 COCBUF(*)
    +
    396 CHARACTER*7 CNINES
    +
    397 CHARACTER*4 COCRPT(10000),BLANK
    +
    398 CHARACTER*2 KAT(11)
    +
    399C
    +
    400 INTEGER LOCRPT(*),KATGC(20,11),KATGL(20,11),KATL(11),KATO(11),
    +
    401 $ MOCRPT(5000)
    +
    402C
    +
    403 REAL ROCRPT(5000)
    +
    404C
    +
    405 equivalence(rocrpt,mocrpt,cocrpt)
    +
    406C
    +
    407 SAVE
    +
    408C
    +
    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/
    +
    421C
    +
    422 entry w3ai02(cocbuf,locrpt,next)
    +
    423C
    +
    424 IF (lwflag.EQ.0) THEN
    +
    425C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY)
    +
    426C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT
    +
    427C EITHER AS 1,2,3...I FOR LW = 4 OR
    +
    428C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE
    +
    429C 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
    +
    439C
    +
    440 IF(cocbuf(n).EQ.'END RECORD'.OR.cocbuf(n).EQ.'XXXXXXXXXX') THEN
    +
    441C 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
    +
    447C 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) = ' '
    +
    460C INITIALIZE CATEGORY WORD PAIRS AS ZEROES
    +
    461 DO 100 mb = 13,42
    +
    462 mocrpt(mb) = 0
    +
    463 100 CONTINUE
    +
    464C 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)
    +
    467C 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)
    +
    470C WORD 3 IS RESERVED (KEEP AS A REAL NUMBER OF 0.)
    +
    471C WRITE OUT STATION ID TO WORDS 11 AND 12 (CHAR*8)
    +
    472C (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)//' '
    +
    478C 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)
    +
    481C 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)
    +
    485C 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)//' '
    +
    488C WRITE OUT REPORT TYPE INTO WORD 9 (INTEGER)
    +
    489 m = 9
    +
    490 READ(cocbuf(n)(8:10),30) mocrpt(m)
    +
    491C 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)
    +
    495C 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)
    +
    498C READ IN NWDS, THE TOTAL NO. OF 10-CHARACTER WORDS IN ENTIRE REPORT
    +
    499 READ(cocbuf(n)(8:10),30) nwds
    +
    500C '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
    +
    505C-----------------------------------------------------------------------
    +
    506C HAVE HIT THE END OF THE REPORT
    +
    507 IF(n-nexto.EQ.nwds) THEN
    +
    508C EVERYTHING LOOKS GOOD, RETURN WITH NEXT SET TO LAST BYTE IN REPORT
    +
    509 next = n * 10
    +
    510 ELSE
    +
    511C 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
    +
    522C-----------------------------------------------------------------------
    +
    523 END IF
    +
    524C READ IN NWDSC, THE RELATIVE POSITION IN RPT OF THE NEXT CATEGORY
    +
    525 READ(cocbuf(n)(3:5),30) nwdsc
    +
    526C READ IN LVLS, THE NUMBER OF LEVELS IN THE CURRENT CATEGORY
    +
    527 READ(cocbuf(n)(6:7),20) lvls
    +
    528C 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
    +
    532C-----------------------------------------------------------------------
    +
    533C 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
    +
    538C-----------------------------------------------------------------------
    +
    539 1000 CONTINUE
    +
    540C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS WILL BE WRITTEN
    +
    541 m = kato(ncat)
    +
    542C WRITE THIS CATEGORY WORD PAIR OUT
    +
    543 mocrpt(m) = lvls
    +
    544 mocrpt(m+1) = mo
    +
    545 n = n + 1
    +
    546 i = 1
    +
    547C***********************************************************************
    +
    548C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY
    +
    549C***********************************************************************
    +
    550 DO 2000 l = 1,lvls
    +
    551C NDG IS NO. OF OUTPUT PARAMETERS PER LEVEL IN THIS CATEGORY
    +
    552 ndg = katl(ncat)
    +
    553C-----------------------------------------------------------------------
    +
    554C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL
    +
    555C-----------------------------------------------------------------------
    +
    556 DO 1800 k = 1,ndg
    +
    557C 'LL' IS THE NUMBER OF INPUT CHARACTERS PER PARAMETER FOR THIS CATEGORY
    +
    558 ll = katgl(k,ncat)
    +
    559C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR NEXT PARAMETER
    +
    560C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR NEXT PARAMETER
    +
    561 j = i + ll - 1
    +
    562 IF(j.GT.10) THEN
    +
    563C 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
    +
    579C KATGC IS AN INDICATOR FOR THE OUTPUT FORMAT OF EACH INPUT PARAMETER
    +
    580C (=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
    +
    583C.......................................................................
    +
    584C 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
    +
    588C.......................................................................
    +
    589 END IF
    +
    590 IF(hold(1:ll).EQ.cnines(1:ll)) THEN
    +
    591C 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
    +
    597C 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
    +
    601C 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
    +
    605C 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
    +
    609C 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
    +
    613C 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
    +
    617C 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
    +
    621C 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
    +
    625C.......................................................................
    +
    626C 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
    +
    630C.......................................................................
    +
    631 END IF
    +
    632 GO TO 1750
    +
    633 1500 CONTINUE
    +
    634C.......................................................................
    +
    635C OUTPUT CHARACTER (MARKER) PROCESSING COMES HERE
    +
    636 IF(ll.LT.4) THEN
    +
    637C 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
    +
    640C THERE ARE FOUR MARKERS IN THE INPUT WORD
    +
    641 cocrpt(lw2*mo-lw1)(1:4) = hold(1:ll)
    +
    642 ELSE
    +
    643C 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
    +
    648C 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
    +
    654C FILL FOUR REMAINING MARKERS TO NEXT OUTPUT WORD
    +
    655 cocrpt(lw2*mo-lw1)(1:4) = hold(ip:jp)
    +
    656 ELSE
    +
    657C 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
    +
    661C.......................................................................
    +
    662 1750 CONTINUE
    +
    663 mo = mo + 1
    +
    664 1800 CONTINUE
    +
    665C-----------------------------------------------------------------------
    +
    666 2000 CONTINUE
    +
    667C***********************************************************************
    +
    668 IF(i.GT.1) n = n + 1
    +
    669 IF(n-nexto.NE.nwdsc) THEN
    +
    670C-----------------------------------------------------------------------
    +
    671C PROBLEM, REL. LOCATION OF NEXT CAT. NOT WHAT'S EXPECTED; MAY EXIT
    +
    672C WITH NEXT = -3
    +
    673C 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
    +
    679C-----------------------------------------------------------------------
    +
    680 END IF
    +
    681C GO ON TO NEXT CATEGORY
    +
    682 GO TO 700
    +
    683C-----------------------------------------------------------------------
    +
    684C ALL OF THE PROBLEM REPORTS END UP HERE -- ATTEMPT TO MOVE AHEAD TO
    +
    685C NEXT REPORT, IF NOT POSSIBLE THEN EXIT WITH NEXT = -2 OR -3 MEANING
    +
    686C 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
    +
    693C WE'VE MADE IT TO THE END OF THIS PROBLEM REPORT - START OVER WITH
    +
    694C NEXT ONE
    +
    695 print 106
    +
    696 next = n * 10
    +
    697 GO TO 7000
    +
    698 END IF
    +
    699 98 CONTINUE
    +
    700 97 CONTINUE
    +
    701C COULDN'T GET TO THE END OF THIS PROBLEM REPORT - RETURN WITH ORIGINAL
    +
    702C 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
    +
    710C-----------------------------------------------------------------------
    +
    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
    +
    w3fi01
    subroutine w3fi01(lw)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition w3fi01.f:19
    +
    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/w3fi65_8f.html b/w3fi65_8f.html index b674e6a4..4db73c68 100644 --- a/w3fi65_8f.html +++ b/w3fi65_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi65.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi65.f File Reference
    +
    w3fi65.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    NMC office note 29 report packer.

    @@ -107,8 +113,8 @@

    Definition in file w3fi65.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi65()

    + +

    ◆ w3fi65()

    @@ -117,13 +123,13 @@

    subroutine w3fi65 ( integer, dimension(*)  - LOCRPT, + locrpt, character*10, dimension(*)  - COCBUF  + cocbuf  @@ -134,7 +140,7 @@

    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.

    +

    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.
      • @@ -151,15 +157,15 @@

      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.
      +
      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.
      +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.
      +Entry w3ai03() duplicates processing in w3fi65() since no assembly language code in cray w3lib.
      Author
      L. Marx
      Date
      1990-01
      @@ -173,7 +179,7 @@

    diff --git a/w3fi65_8f.js b/w3fi65_8f.js index 6bb60734..313d099f 100644 --- a/w3fi65_8f.js +++ b/w3fi65_8f.js @@ -1,4 +1,4 @@ var w3fi65_8f = [ - [ "w3fi65", "w3fi65_8f.html#a1651042ec008fbdb77f6b66ee9643d0e", null ] + [ "w3fi65", "w3fi65_8f.html#a04761367dc026f8b456d586d186a5dcd", null ] ]; \ No newline at end of file diff --git a/w3fi65_8f_source.html b/w3fi65_8f_source.html index 65ba4b4a..5268f9b5 100644 --- a/w3fi65_8f_source.html +++ b/w3fi65_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi65.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,406 +81,414 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi65.f
    +
    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
    -
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief NMC office note 29 report packer.
    +
    3C> @author L. Marx @date 1990-01
    +
    4
    +
    5C> Packs an array of upper-air reports into the format
    +
    6C> described by NMC office note 29, or packs an array of surface
    +
    7C> reports into the format described by NMC office note 124. Input
    +
    8C> integer, real or character type as specified in the category
    +
    9C> tables in the write-up for w3fi64() (the office note 29 report
    +
    10C> packer) are converted to character data. Missing character data
    +
    11C> are specified as strings of 9's except for that converted from
    +
    12C> input character type which are generally specified as blanks.
    +
    13C> This library is similar to w3ai03() except w3ai03() was written in
    +
    14C> assembler.
    +
    15C>
    +
    16C> Program history log:
    +
    17C> - L. Marx 1990-01 Converted code from assembler
    +
    18C> to vs fortran.
    +
    19C> - Dennis Keyser 1991-08-23 Use same arguments as w3ai03() ;
    +
    20C> Streamlined code; Docblocked and commented.
    +
    21C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    22C> - Dennis Keyser 1992-07-09 Checks the number of characters
    +
    23C> used by each variable prior to conversion from
    +
    24C> integer to character format; If this number is
    +
    25C> greater than the number of characters allocated for
    +
    26C> the variable the variable is packed as "missing"
    +
    27C> (i.e., stores as all 9's).
    +
    28C> - Dennis Keyser 1993-06-28 Initializes number of words in
    +
    29C> report to 42 in case "strange" report with no data
    +
    30C> in any category encountered (used to be zero, but
    +
    31C> such "strange" reports caused code to fail).
    +
    32C> - Dennis Keyser 1993-12-22 Corrected error which resulted
    +
    33C> in storage of 0's in place of actual data in a
    +
    34C> category when that category was the only one with
    +
    35C> data.
    +
    36C> - Dennis Keyser 1998-08-07 Fortran 90-compliant - split an
    +
    37C> if statement into 2-parts to prevent f90 floating
    +
    38C> point exception error that can now occur in some
    +
    39C> cases (did not occur in f77).
    +
    40C>
    +
    41C> @param[in] LOCRPT Integer array containing one unpacked report.
    +
    42C> LOCRPT must begin on a fullword boundary. Format
    +
    43C> is mixed, user must equivalence real and character
    +
    44C> arrays to this array (see w3fi64 write-up for
    +
    45C> content).
    +
    46C> @param[out] COCBUF CHARACTER*10 Array containing a packed report in
    +
    47C> NMC office note 29/124 format.
    +
    48C>
    +
    49C> @note After first creating and writing out the office note 85
    +
    50C> (first) date record, the user's fortran program begins a packing
    +
    51C> loop as follows.. Each iteration of the packing loop consists of
    +
    52C> a call first to w3fi65() to pack the report into COCBUF, then a call
    +
    53C> to w3fi66() with the current value of 'NFLAG' (set to zero for first
    +
    54C> call) to block the packed report into a record (see w3fi66() write-
    +
    55C> up). if 'NFLAG' is -1 upon returning from w3fi66(), the remaining
    +
    56C> portion of the record is not large enough to hold the current
    +
    57C> packed report. The user should write out the record, set 'NFLAG'
    +
    58C> to zero, call w3fi66() to write the packed report to the beginning
    +
    59C> of the next record, and repeat the packing loop. If 'NFLAG' is
    +
    60C> positive, a packed report has been blocked into the record and
    +
    61C> the user should continue the packing loop.
    +
    62C> When all reports have been packed and blocked, the user
    +
    63C> should write out this last record (which is not full but contains
    +
    64C> fill information supplied by w3fi66()). One final record containing
    +
    65C> the string 'endof file' (sic) followed by blank fill must be
    +
    66C> written out to signal the end of the data set.
    +
    67C>
    +
    68C> @note 1: The packed report will have the categories ordered as
    +
    69C> follows: 1, 2, 3, 4, 5, 6, 7, 51, 52, 8, 9.
    +
    70C> @note 2: The input unpacked report must be in the format spec-
    +
    71C> ified in the w3fi64() office note 29 report unpacker write-up.
    +
    72C> @note 3: The unused porion of cocbuf is not cleared.
    +
    73
    +
    74C> @note Entry w3ai03() duplicates processing in w3fi65() since no
    +
    75C> assembly language code in cray w3lib.
    +
    76C>
    +
    77C> @author L. Marx @date 1990-01
    +
    +
    78 SUBROUTINE w3fi65(LOCRPT,COCBUF)
    +
    79C
    +
    80 CHARACTER*12 HOLD
    +
    81 CHARACTER*10 COCBUF(*),FILL
    +
    82 CHARACTER*7 CNINES
    +
    83 CHARACTER*4 COCRPT(10000)
    +
    84 CHARACTER*2 KAT(11)
    +
    85C
    +
    86 INTEGER LOCRPT(*),KATL(11),KATO(11),KATGC(20,11),KATGL(20,11),
    +
    87 $ MOCRPT(5000),KATLL(11)
    +
    88C
    +
    89 REAL ROCRPT(5000)
    +
    90C
    +
    91 equivalence(rocrpt,mocrpt,cocrpt)
    +
    92C
    +
    93 SAVE
    +
    94C
    +
    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/
    +
    107C
    +
    108 entry w3ai03(locrpt,cocbuf)
    +
    109C
    +
    110 IF (lwflag.EQ.0) THEN
    +
    111C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY)
    +
    112C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT
    +
    113C EITHER AS 1,2,3...I FOR LW = 4 OR
    +
    114C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE
    +
    115C 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
    +
    124C 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
    +
    134cvvvvvy2k
    +
    135cdak MBYTES = LW * ((MI - 1) + (LVLS * KATLL(KK)))
    +
    136 mwords = (mi - 1) + (lvls * katll(kk))
    +
    137C TRANSFER LOCRPT TO MOCRPT IN ORDER TO EQUIVALENCE TO REAL AND CHAR.
    +
    138cdak CALL XMOVEX(MOCRPT,LOCRPT,MBYTES)
    +
    139 mocrpt(1:mwords) = locrpt(1:mwords)
    +
    140caaaaay2k
    +
    141C 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'
    +
    146C READ IN LATITUDE FROM WORD 1 (REAL)
    +
    147C 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
    +
    154C READ IN LONGITUDE FROM WORD 2 (REAL)
    +
    155C 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
    +
    161C READ IN STATION ID FROM WORDS 11 AND 12 (C*8)
    +
    162C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.)
    +
    163C 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)
    +
    168C READ IN OBSERVATION TIME FROM WORD 4 (REAL)
    +
    169C 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))
    +
    172C READ IN RESERVED CHARACTERS FROM WORDS 5 AND 6 (C*8)
    +
    173C (4 CHAR., LEFT-JUSTIF.)
    +
    174C 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)
    +
    179C READ IN OFFICE NOTE 29 REPORT TYPE FROM WORD 9 (INTEGER)
    +
    180C 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)
    +
    183C READ IN STATION ELEVATION FROM WORD 7 (REAL)
    +
    184C 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
    +
    191C READ IN INSTRUMENT TYPE FROM WORD 8 (INTEGER)
    +
    192C 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
    +
    197CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    198C LOOP THROUGH ALL THE CATEGORIES WHICH HAVE VALID DATA
    +
    199CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    200 DO 3000 ncat = 1,11
    +
    201C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS IS READ FROM
    +
    202 m = kato(ncat)
    +
    203 lvls = mocrpt(m)
    +
    204C '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
    +
    207C CATEGORY WITH VALID CATEGORY ENCOUNTERED - WRITE OUT IN FIRST 2
    +
    208C CHARACTERS OF CATEGORY/COUNTER GROUP FOR THIS CATEGORY (C*2)
    +
    209 cocbuf(n)(1:2) = kat(ncat)
    +
    210C 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
    +
    214C NWDSC COUNTS THE NUMBER OF 10-CHAR. WORDS IN THIS CATEGORY
    +
    215 nwdsc = 1
    +
    216 i = 1
    +
    217C***********************************************************************
    +
    218C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY
    +
    219C***********************************************************************
    +
    220 DO 2000 l = 1,lvls
    +
    221C NDG IS NO. OF INPUT PARAMETERS PER LEVEL IN THIS CATEGORY
    +
    222 ndg = katl(ncat)
    +
    223C-----------------------------------------------------------------------
    +
    224C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL
    +
    225C-----------------------------------------------------------------------
    +
    226 DO 1800 k = 1,ndg
    +
    227C 'LL' IS THE NUMBER OF OUTPUT CHARACTERS PER PARAMETER FOR THIS CAT.
    +
    228 ll = katgl(k,ncat)
    +
    229C KATGC IS AN INDICATOR FOR THE INPUT FORMAT OF EACH OUTPUT PARAMETER
    +
    230C (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8)
    +
    231 IF(katgc(k,ncat).EQ.4) GO TO 1500
    +
    232C 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)
    +
    236C 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)
    +
    243C 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))
    +
    250C INITIALIZE ALL OUTPUT PARAMETERS HERE AS MISSING
    +
    251C (WILL REMAIN MISSING IF "IVALUE" SOMEHOW WOULD FILL-UP TOO
    +
    252C MANY CHARACTERS)
    +
    253 hold(1:ll) = cnines(1:ll)
    +
    254 IF(ll.EQ.1) THEN
    +
    255C 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
    +
    259C 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
    +
    265C 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
    +
    271C 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
    +
    277C 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
    +
    283C 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
    +
    289C 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
    +
    297C.......................................................................
    +
    298C INPUT CHARACTER (MARKER) PROCESSING COMES HERE
    +
    299 IF(ll.LE.4) THEN
    +
    300C THERE ARE BETWEEN ONE AND FOUR MARKERS IN OUTPUT PARAMETER
    +
    301 hold(1:ll) = cocrpt(lw2*mi-lw1)(1:ll)
    +
    302 ELSE
    +
    303C 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
    +
    308C 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
    +
    314C GET FOUR REMAINING MARKERS FROM NEXT INPUT WORD
    +
    315 hold(ip:jp) = cocrpt(lw2*mi-lw1)(1:4)
    +
    316 ELSE
    +
    317C 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
    +
    321C.......................................................................
    +
    322 1750 CONTINUE
    +
    323C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR OUTPUT PARAMETER
    +
    324C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR OUTPUT PARAMETER
    +
    325 j = i + ll - 1
    +
    326 IF(j.GT.10) THEN
    +
    327C 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
    +
    342C GO ON TO NEXT INPUT WORD IN THIS LEVEL
    +
    343 mi = mi + 1
    +
    344 1800 CONTINUE
    +
    345C-----------------------------------------------------------------------
    +
    346 2000 CONTINUE
    +
    347C***********************************************************************
    +
    348C 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)
    +
    350C TOTAL NO. CHARACTERS IN CATEGORY (EXCL. FILLS) (NCHAR) WRITTEN OUT TO
    +
    351C 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
    +
    355C RELATIVE POSITION IN REPORT OF NEXT CAT/CNTR GROUP (N) WRITTEN OUT TO
    +
    356C CHAR. 3 - 5 OF CURRENT CATEGORY/COUNTER GROUP (C*3)
    +
    357 WRITE(cocbuf(nc)(3:5),30) n
    +
    358C GO ON TO THE NEXT CATEGORY
    +
    359 3000 CONTINUE
    +
    360CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    361C WRITE OUT THE TOTAL LENGTH OF THE REPORT -- NO. OF 10-CHARACTER WORDS
    +
    362C -- (N) IN LAST THREE CHARACTERS OF WORD 4 (C*3)
    +
    363 WRITE(cocbuf(no)(8:10),30) n
    +
    364C 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
    +
    w3fi01
    subroutine w3fi01(lw)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition w3fi01.f:19
    +
    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
    diff --git a/w3fi66_8f.html b/w3fi66_8f.html index 89c3c92f..4c4b4eca 100644 --- a/w3fi66_8f.html +++ b/w3fi66_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi66.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi66.f File Reference
    +
    w3fi66.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi66 (cocbuf, cocblk, nflag, nsize)
     Blocks reports which have been packed into nmc office note 29 character format into fixed-length records.
     

    Detailed Description

    Office note 29 report blocker.

    @@ -107,8 +113,8 @@

    Definition in file w3fi66.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi66()

    + +

    ◆ w3fi66()

    @@ -117,25 +123,25 @@

    subroutine w3fi66 ( character*10, dimension(*)  - COCBUF, + cocbuf, character*10, dimension(*)  - COCBLK, + cocblk,   - NFLAG, + nflag,   - NSIZE  + nsize  @@ -155,17 +161,17 @@

    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]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)
    [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.

    +
    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.
    +
    Note
    Entry w3ai05() duplicates processing in w3fi66() since no assembly language code in cray w3lib.
    Author
    L. Marx
    Date
    1990-01
    @@ -179,7 +185,7 @@

    diff --git a/w3fi66_8f.js b/w3fi66_8f.js index 66695d8a..e886638b 100644 --- a/w3fi66_8f.js +++ b/w3fi66_8f.js @@ -1,4 +1,4 @@ var w3fi66_8f = [ - [ "w3fi66", "w3fi66_8f.html#af8839a41e56c22bda1be01a7f877eb5e", null ] + [ "w3fi66", "w3fi66_8f.html#a70b3cfe6a9e87d8b292ab36cfe2e2811", null ] ]; \ No newline at end of file diff --git a/w3fi66_8f_source.html b/w3fi66_8f_source.html index a10ab6f6..728c2a71 100644 --- a/w3fi66_8f_source.html +++ b/w3fi66_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi66.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,147 +81,155 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi66.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Office note 29 report blocker.
    +
    3C> @author L. Marx @date 1990-01
    +
    4
    +
    5C> Blocks reports which have been packed into nmc office
    +
    6C> note 29 character format into fixed-length records. A report
    +
    7C> cannot span two records; If there is not enough room to fit
    +
    8C> the current report in the record, the subroutine returns to
    +
    9C> the calling program without any movement of data.
    +
    10C>
    +
    11C> Program history log:
    +
    12C> - L. Marx 1990-01 Converted code from assembler
    +
    13C> to vs fortran; Expanded error return codes in 'NFLAG'.
    +
    14C> - Dennis Keyser 1991-08-23 Use same arguments as w3ai05();
    +
    15C> streamlined code; Docblocked and commented; diag-
    +
    16C> nostic print for errors.
    +
    17C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    18C>
    +
    19C> @param[in] COCBUF Array containing a single packed report
    +
    20C> in office note 29/124 format.
    +
    21C> @param[in] NFLAG Marker indicating relative location (in bytes)
    +
    22C> of end of last report in COCBLK. Exception:
    +
    23C> NFLAG must be set to zero prior to blocking the first
    +
    24C> packed report into a new block. Subsequently, the
    +
    25C> value of NFLAG returned by the previous call to w3fi66()
    +
    26C> should be used as input. (see output argument list
    +
    27C> below.) If NFLAG is negative, w3fi66() will return
    +
    28C> immediately without action.
    +
    29C> @param[in] NSIZE Maximum number of characters in COCBLK array
    +
    30C> (should be a multiple of 4)
    +
    31C> @param[inout] COCBLK Array holding a block of packed reports
    +
    32C> up to and including the previous (IN) / current (OUT) one
    +
    33C> ag marker indicating relative location (in bytes)
    +
    34C> of end of current report in COCBLK. NFLAG
    +
    35C> will be set to -1 if w3fi66() cannot fit the current
    +
    36C> packed report into the remainder of the block (i.e.,
    +
    37C> the block is full). NFLAG will not change from its
    +
    38C> input argument value if the string "end report" is
    +
    39C> not found at the end of the current report. (current
    +
    40C> packed report has invalid length and is not blocked)
    +
    41C>
    +
    42C> @note The user must set NFLAG to zero each time the array is
    +
    43C> to be filled with packed reports in office note 29/124 format.
    +
    44C> w3fi66() will then insert the first report and fill the remainder
    +
    45C> of the output array COCBLK with the string 'end record'.
    +
    46C>
    +
    47C> An attempt is made to insert a report in the output array
    +
    48C> each time w3fi66() is called. If the remaining portion of the
    +
    49C> output array is not large enough to hold the current report,
    +
    50C> w3fi66() sets NFLAG to -1. The user should then output the
    +
    51C> blocked record, set NFLAG to zero, and call w3fi66() again with
    +
    52C> the same report in the input array.
    +
    53C>
    +
    54C> After a given report is successfully blocked into COCBLK,
    +
    55C> w3fi66() sets NFLAG as a pointer for the next report to be blocked.
    +
    56C> this pointer is a relative address and a character count.
    +
    57C>
    +
    58C> The three characters specifying the length of the report
    +
    59C> are checked for valid character numbers and the value is tested
    +
    60C> for pointing to the end of the report (string "end report"). If
    +
    61C> invalid, the report is not inserted into the block and there is
    +
    62C> an immediate return to the user. In this case, the value of
    +
    63C> NFLAG does not change from its input value.
    +
    64C>
    +
    65C> @note Entry w3ai05() duplicates processing in w3fi66() since no
    +
    66C> assembly language code in cray w3lib.
    +
    67C>
    +
    68C> @author L. Marx @date 1990-01
    +
    +
    69 SUBROUTINE w3fi66(COCBUF,COCBLK,NFLAG,NSIZE)
    +
    70C
    +
    71 CHARACTER*10 COCBUF(*),COCBLK(*)
    +
    72C
    +
    73 SAVE
    +
    74C
    +
    75 entry w3ai05(cocbuf,cocblk,nflag,nsize)
    +
    76C
    +
    77 IF (nflag.LT.0) THEN
    +
    78 print 101
    +
    79 RETURN
    +
    80 END IF
    +
    81C N10WRD IS THE MAXIMUM NUMBER OF 10-CHARACTER WORDS AVAILABLE IN BLOCK
    +
    82 n10wrd = nsize/10
    +
    83C-----------------------------------------------------------------------
    +
    84 IF (nflag.EQ.0) THEN
    +
    85C 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
    +
    90C-----------------------------------------------------------------------
    +
    91C READ IN THE NUMBER OF 10-CHARACTER WORDS IN THIS REPORT (NWDS)
    +
    92 READ(cocbuf(4)(8:10),30) nwds
    +
    93 30 FORMAT(i3)
    +
    94C NOW GET THE NUMBER OF CHARACTERS IN THIS REPORT (NCHARS)
    +
    95 nchars = nwds * 10
    +
    96C N01BYT IS THE MAXIMUM NUMBER OF CHARACTERS AVAILABLE FOR DATA IN BLOCK
    +
    97 n01byt = (n10wrd * 10) - 10
    +
    98 IF (nflag+nchars.GT.n01byt) THEN
    +
    99C THE REMAINING PORTION OF THE BLOCK IS NOT LARGE ENOUGH TO HOLD THIS
    +
    100C REPORT, RETURN WITH NFLAG = -1
    +
    101 nflag = -1
    +
    102 RETURN
    +
    103 END IF
    +
    104 IF (cocbuf(nwds).NE.'END REPORT') THEN
    +
    105C LAST 10-CHARACTER WORD IN REPORT IS NOT SET TO THE STRING "END REPORT"
    +
    106C -- 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
    +
    110C TRANSFER PACKED REPORT INTO BLOCK
    +
    111 DO 100 n = 1,nwds
    +
    112 cocblk((nflag/10)+n) = cocbuf(n)
    +
    113 100 CONTINUE
    +
    114C 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/w3fi67_8f.html b/w3fi67_8f.html index 95bd9d9e..0acb0a03 100644 --- a/w3fi67_8f.html +++ b/w3fi67_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi67.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi67.f File Reference
    +
    w3fi67.f File Reference
    @@ -94,41 +100,41 @@

    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...
     
    subroutine fi6701 (iptr, ident, msga, istack, iwork, aname, kdata, ivals, mstack, aunits, kdesc, mwidth, mref, mscale, knr, index)
     Data extraction.
     
    subroutine fi6702 (iptr, ident, msga, kdata, kdesc, ll, mstack, aunits, mwidth, mref, mscale, jdesc, ivals, j)
     Process standard descriptor.
     
    subroutine fi6703 (iptr, ident, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, jdesc)
     Process compressed data and place individual elements into output array.
     
    subroutine fi6704 (iptr, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, ll, jdesc)
     Process data that is not compressed.
     
    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.
     
    subroutine fi6706 (iptr, lx, ly, ident, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, ll, kdesc, iwork, jdesc)
     Process operator descriptors.
     
    subroutine fi6707 (iptr, iwork, itbld, jdesc)
     Substitute descriptor queue for queue descriptor.
     
    subroutine fi6708 (iptr, iwork, lf, lx, ly, jdesc)
     Subroutine FI6708.
     
    subroutine fi6709 (ident, mstack, kdata, iptr)
     Reformat decoded profiler data to show heights instead of height increments.
     
    subroutine fi6710 (ident, mstack, kdata, iptr)
     Reformat profiler edition 2 data.
     
    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.
     

    Detailed Description

    BUFR message decoder.

    @@ -137,8 +143,8 @@

    Definition in file w3fi67.f.

    Function/Subroutine Documentation

    - -

    ◆ fi6701()

    + +

    ◆ fi6701()

    @@ -147,97 +153,97 @@

    subroutine fi6701 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(*)  - ISTACK, + istack, integer, dimension(*)  - IWORK, + iwork, character*40, dimension(*)  - ANAME, + aname, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,*)  - MSTACK, + mstack, character*24, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - KDESC, + kdesc, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer, dimension(*)  - KNR, + knr, integer  - INDEX  + index  @@ -293,8 +299,8 @@

    -

    ◆ fi6702()

    + +

    ◆ fi6702()

    @@ -303,85 +309,85 @@

    subroutine fi6702 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - KDESC, + kdesc,   - LL, + ll, integer, dimension(2,*)  - MSTACK, + mstack, character*24, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer  - JDESC, + jdesc, integer, dimension(*)  - IVALS, + ivals, integer  - J  + j  @@ -425,8 +431,8 @@

    -

    ◆ fi6703()

    + +

    ◆ fi6703()

    @@ -435,67 +441,67 @@

    subroutine fi6703 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,*)  - MSTACK, + mstack, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer  - J, + j, integer  - JDESC  + jdesc  @@ -516,8 +522,8 @@

    Parameters
    - - + + @@ -538,8 +544,8 @@

    -

    ◆ fi6704()

    + +

    ◆ fi6704()

    @@ -548,67 +554,67 @@

    subroutine fi6704

    - + - + - + - + - + - + - + - + - + - + - + @@ -654,8 +660,8 @@

    -

    ◆ fi6705()

    + +

    ◆ fi6705()

    @@ -664,61 +670,61 @@

    subroutine fi6705

    - + - + - + - + - + - + - + - + - + - + @@ -764,8 +770,8 @@

    -

    ◆ fi6706()

    + +

    ◆ fi6706()

    @@ -774,97 +780,97 @@

    subroutine fi6706

    - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -915,8 +921,8 @@

    -

    ◆ fi6707()

    + +

    ◆ fi6707()

    @@ -925,25 +931,25 @@

    subroutine fi6707

    - + - + - + - + @@ -977,8 +983,8 @@

    -

    ◆ fi6708()

    + +

    ◆ fi6708()

    @@ -987,37 +993,37 @@

    subroutine fi6708

    - + - + - + - + - + - + @@ -1035,7 +1041,7 @@

    Parameters

    [in]IPTRSee w3fi67() routine docblock.
    [in]IDENTSee w3fi67() routine docblock.
    [in]IPTRSee w3fi67() routine docblock.
    [in]IDENTSee w3fi67() routine docblock.
    [in]MSGAArray containing bufr message, mstack.
    [in]MSTACK
    [in]IVALSArray of single parameter values.
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) MSGA, msga,
    integer, dimension(500,*) KDATA, kdata,
    integer, dimension(*) IVALS, ivals,
    integer, dimension(2,*) MSTACK, mstack,
    integer, dimension(*) MWIDTH, mwidth,
    integer, dimension(700,3) MREF, mref,
    integer, dimension(*) MSCALE, mscale,
    integer J, j,
    integer LL, ll,
    integer JDESC jdesc 
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) IDENT, ident,
    integer, dimension(*) MSGA, msga,
    integer, dimension(*) IWORK, iwork,
    integer LX, lx,
    integer LY, ly,
    integer, dimension(500,*) KDATA, kdata,
    integer LL, ll,
    integer, dimension(*) KNR, knr,
    integer, dimension(2,*) MSTACK mstack 
    ( integer, dimension(*) IPTR, iptr,
    integer LX, lx,
    integer LY, ly,
    integer, dimension(*) IDENT, ident,
    integer, dimension(*) MSGA, msga,
    integer, dimension(500,*) KDATA, kdata,
    integer, dimension(*) IVALS, ivals,
    integer, dimension(2,*) MSTACK, mstack,
    integer, dimension(*) MWIDTH, mwidth,
    integer, dimension(700,3) MREF, mref,
    integer, dimension(*) MSCALE, mscale,
    integer J, j,
    integer LL, ll,
    integer, dimension(*) KDESC, kdesc,
    integer, dimension(*) IWORK, iwork,
    integer JDESC jdesc 
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) IWORK, iwork,
    integer, dimension(500,11) ITBLD, itbld,
    integer JDESC jdesc 
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) IWORK, iwork,
    integer LF, lf,
    integer LX, lx,
    integer LY, ly,
    integer JDESC jdesc 
    - + @@ -1052,8 +1058,8 @@

    -

    ◆ fi6709()

    + +

    ◆ fi6709()

    @@ -1062,25 +1068,25 @@

    subroutine fi6709

    - + - + - + - + @@ -1131,8 +1137,8 @@

    -

    ◆ fi6710()

    + +

    ◆ fi6710()

    @@ -1141,25 +1147,25 @@

    subroutine fi6710

    - + - + - + - + @@ -1209,8 +1215,8 @@

    -

    ◆ w3fi67()

    + +

    ◆ w3fi67()

    @@ -1219,49 +1225,49 @@

    subroutine w3fi67

    - + - + - + - + - + - + - + - + @@ -1286,8 +1292,8 @@

    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 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.
    • @@ -1303,7 +1309,7 @@

    fi6710() to permit reformatting profiler data in BUFR edition 2. +
  • Bill Cavanaugh 1993-01-26 Added routine fi6710() to permit reformatting profiler data in BUFR edition 2.
    • Parameters

    [in,out]IPTRSee w3fi67() routine docblock.
    [in,out]IPTRSee w3fi67() routine docblock.
    [in]IWORKWorking descriptor list.
    LF
    LX
    ( integer, dimension(*) IDENT, ident,
    integer, dimension(2,*) MSTACK, mstack,
    integer, dimension(500,*) KDATA, kdata,
    integer, dimension(*) IPTR iptr 
    ( integer, dimension(*) IDENT, ident,
    integer, dimension(2,1600) MSTACK, mstack,
    integer, dimension(500,1600) KDATA, kdata,
    integer, dimension(*) IPTR iptr 
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) IDENT, ident,
    integer, dimension(*) MSGA, msga,
    integer, dimension(*) ISTACK, istack,
    integer, dimension(2,*) MSTACK, mstack,
    integer, dimension(500,*) KDATA, kdata,
    integer, dimension(*) KNR, knr,
    integer INDEX index 
    @@ -1443,14 +1449,14 @@

    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.

    +

    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. @@ -1475,7 +1481,7 @@

      diff --git a/w3fi67_8f.js b/w3fi67_8f.js index 343e5ae0..52ad20c7 100644 --- a/w3fi67_8f.js +++ b/w3fi67_8f.js @@ -1,14 +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 ] + [ "fi6701", "w3fi67_8f.html#a129e4781542ae749c23dc0a8961110ce", null ], + [ "fi6702", "w3fi67_8f.html#ae78fbedd62a4b1dc408e12a56f269d2e", null ], + [ "fi6703", "w3fi67_8f.html#aa4d148d976e36638d4499d8f1d24bb55", null ], + [ "fi6704", "w3fi67_8f.html#adf36991a9797826ba0e6af26bc047a22", null ], + [ "fi6705", "w3fi67_8f.html#a18dfd077ec80be85e96192fb2627ce38", null ], + [ "fi6706", "w3fi67_8f.html#a8f8a60d99fe5feb50640a40f9e869c08", null ], + [ "fi6707", "w3fi67_8f.html#a7657ec760cf65383ff753091f47be6ad", null ], + [ "fi6708", "w3fi67_8f.html#ad5e2e788e8e08893f9e72880bf462d07", null ], + [ "fi6709", "w3fi67_8f.html#a08e6952dbff783ad8064c86284b7338b", null ], + [ "fi6710", "w3fi67_8f.html#a7d30a98528a6c8cedc7b76c112862ea7", null ], + [ "w3fi67", "w3fi67_8f.html#a7d0d66e5c01d134ce7e40a6f33e54479", null ] ]; \ No newline at end of file diff --git a/w3fi67_8f_source.html b/w3fi67_8f_source.html index 4c97658d..d3f35032 100644 --- a/w3fi67_8f_source.html +++ b/w3fi67_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi67.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,2691 +81,2719 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi67.f
    +
    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
    -
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    -
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    -
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    -
    w3fc05
    subroutine w3fc05(U, V, DIR, SPD)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition: w3fc05.f:29
    -
    fi6707
    subroutine fi6707(IPTR, IWORK, ITBLD, JDESC)
    Substitute descriptor queue for queue descriptor.
    Definition: w3fi67.f:1815
    -
    fi6710
    subroutine fi6710(IDENT, MSTACK, KDATA, IPTR)
    Reformat profiler edition 2 data.
    Definition: w3fi67.f:2361
    -
    fi6709
    subroutine fi6709(IDENT, MSTACK, KDATA, IPTR)
    Reformat decoded profiler data to show heights instead of height increments.
    Definition: w3fi67.f:1974
    -
    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
    -
    fi6702
    subroutine fi6702(IPTR, IDENT, MSGA, KDATA, KDESC, LL, MSTACK, AUNITS, MWIDTH, MREF, MSCALE, JDESC, IVALS, J)
    Process standard descriptor.
    Definition: w3fi67.f:942
    -
    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
    -
    fi6704
    subroutine fi6704(IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC)
    Process data that is not compressed.
    Definition: w3fi67.f:1349
    -
    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
    -
    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
    -
    fi6708
    subroutine fi6708(IPTR, IWORK, LF, LX, LY, JDESC)
    Subroutine FI6708.
    Definition: w3fi67.f:1922
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief BUFR message decoder.
    +
    3C> @author Bill Cavanaugh @date 1988-08-31
    +
    4
    +
    5C> This set of routines will decode a BUFR message and
    +
    6C> place information extracted from the BUFR message into selected
    +
    7C> arrays for the user. Those arrays are described in the output
    +
    8C> argument list. This routine does not include ifod processing.
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Bill Cavanaugh 1988-08-31
    +
    12C> - Bill Cavanaugh 1990-12-07 Now utilizing gbyte routines to gather
    +
    13C> and separate bit fields. This should improve
    +
    14C> (decrease) the time it takes to decode any
    +
    15C> BUFR message. Have entered coding that will
    +
    16C> permit processing BUFR editions 1 and 2.
    +
    17C> Improved and corrected the conversion into
    +
    18C> ifod format of decoded BUFR messages.
    +
    19C> - Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle
    +
    20C> serial profiler data.
    +
    21C> - Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru
    +
    22C> descriptor 2 05 yyy.
    +
    23C> - Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data
    +
    24C> corrected. Improved handling of nested queue descriptors is added.
    +
    25C> - Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8
    +
    26C> to better contain very large numbers more accurately. The preious size
    +
    27C> real*4 could not contain sufficient significant digits. Coding has been
    +
    28C> introduced to process new table c descriptor 2 06 yyy which permits in
    +
    29C> line processing of a local descriptor even if the descriptor is not
    +
    30C> contained in the users table b. A second routine to process ifod messages
    +
    31C> (ifod0) has been removed in favor of the improved processing of the one
    +
    32C> remaining (ifod1). New coding has been introduced to permit processing of
    +
    33C> BUFR messages based on BUFR edition up to and including edition 2. Please
    +
    34C> note increased size requirements for arrays ident(20) and iptr(40).
    +
    35C> - Bill Cavanaugh 1991-07-26 Add array mtime to calling sequence to
    +
    36C> permit inclusion of receipt/transfer times to ifod messages.
    +
    37C> - Bill Cavanaugh 1991-09-25 All processing of decoded BUFR data into
    +
    38C> ifod (a local use reformat of BUFR data) has been isolated from this set of
    +
    39C> routines. For those interested in the ifod form, see w3fl05 in the w3lib
    +
    40C> routines.
    +
    41C> - Processing of BUFR messages containing delayed replication has been
    +
    42C> altered so that single subsets (reports) and and a matching descriptor list
    +
    43C> for that particular subset will be passed to the user will be passed to the
    +
    44C> user one at a time to assure that each subset can be fully defined with a
    +
    45C> minimum of reprocessing.
    +
    46C> - Processing of associated fields has been tested with messages containing
    +
    47C> non-compressed data.
    +
    48C> - In order to facilitate user processing a matching list of scale factors
    +
    49C> are included with the expanded descriptor list (mstack).
    +
    50C> - Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy
    +
    51C> has corrected to agree with fm94 standards.
    +
    52C> - Bill Cavanaugh 1991-12-19 Calls to fi6703() and fi6704() have been
    +
    53C> corrected to agree called program argument list. Some additional entries
    +
    54C> have been included for communicating with data access routines. Additional
    +
    55C> error exit provided for the case where table b is damaged.
    +
    56C> - Bill Cavanaugh 1992-01-24 Routines fi6701(), fi6703() and fi6704()
    +
    57C> have been modified to handle associated fields all descriptors are set to
    +
    58C> echo to mstack(1,n)
    +
    59C> - Bill Cavanaugh 1992-05-21 Further expansion of information collected from
    +
    60C> within upper air soundings has produced the necessity to expand some of the
    +
    61C> processing and output arrays. (see remarks below)
    +
    62C> - Bill Cavanaugh 1992-06-29 Corrected descriptor denoting height of
    +
    63C> each wind level for profiler conversions.
    +
    64C> - Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment
    +
    65C> of arrays to contain table b values needed to assist in the decoding process.
    +
    66C> - Arrays containing data from table b:
    +
    67C> - kdesc descriptor
    +
    68C> - aname descriptor name
    +
    69C> - aunits units for descriptor
    +
    70C> - mscale scale for value of descriptor
    +
    71C> - mref reference value for descriptor
    +
    72C> - mwidth bit width for value of descriptor
    +
    73C> - Bill Cavanaugh 1992-09-09 First encounter with operator descriptor
    +
    74C> 2 05 yyy showed error in decoding. That error is corrected with this
    +
    75C> implementation. Further testing of upper air data has encountered the
    +
    76C> condition of large (many level) soundings arrays in the decoder have been
    +
    77C> expanded (again) to allow for this condition.
    +
    78C> - Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data
    +
    79C> (fi6709) to show descriptors, scale value and data in proper order.
    +
    80C> Corrected an error that prevented user from assigning the second dimension
    +
    81C> of kdata(500,*).
    +
    82C> - Bill Cavanaugh 1992-10-20 Removed error that prevented full implementation
    +
    83C> of previous corrections and made corrections to table b to bring it up to
    +
    84C> date. Changes include proper reformat of profiler data and user capability
    +
    85C> for assigning second dimension of kdata array.
    +
    86C> - Bill Cavanaugh 1993-01-26 Added routine fi6710() to permit reformatting
    +
    87C> profiler data in BUFR edition 2.
    +
    88C>
    +
    89C> @param[in] MSGA Array containing supposed bufr message.
    +
    90C> @param[out] ISTACK Original array of descriptors extracted from
    +
    91C> source bufr message.
    +
    92C> @param[out] MSTACK (A,B)
    +
    93C> - LEVEL B - Descriptor number
    +
    94C> - LEVEL A = 1 Descriptor
    +
    95C> - = 2 10**N Scaling to return to original value
    +
    96C> @param[out] IPTR Utility array.
    +
    97C> - IPTR( 1)- Error return.
    +
    98C> - IPTR( 2)- Byte count section 1.
    +
    99C> - IPTR( 3)- Pointer to start of section 1.
    +
    100C> - IPTR( 4)- Byte count section 2.
    +
    101C> - IPTR( 5)- Pointer to start of section 2.
    +
    102C> - IPTR( 6)- Byte count section 3.
    +
    103C> - IPTR( 7)- Pointer to start of section 3.
    +
    104C> - IPTR( 8)- Byte count section 4.
    +
    105C> - IPTR( 9)- Pointer to start of section 4.
    +
    106C> - IPTR(10)- Start of requested subset, reserved for dar.
    +
    107C> - IPTR(11)- Current descriptor ptr in iwork.
    +
    108C> - IPTR(12)- Last descriptor pos in iwork.
    +
    109C> - IPTR(13)- Last descriptor pos in istack.
    +
    110C> - IPTR(14)- Number of table b entries.
    +
    111C> - IPTR(15)- Requested subset pointer, reserved for dar.
    +
    112C> - IPTR(16)- Indicator for existance of section 2.
    +
    113C> - IPTR(17)- Number of reports processed.
    +
    114C> - IPTR(18)- Ascii/text event.
    +
    115C> - IPTR(19)- Pointer to start of bufr message.
    +
    116C> - IPTR(20)- Number of lines from table d.
    +
    117C> - IPTR(21)- Table b switch.
    +
    118C> - IPTR(22)- Table d switch.
    +
    119C> - IPTR(23)- Code/flag table switch.
    +
    120C> - IPTR(24)- Aditional words added by text info.
    +
    121C> - IPTR(25)- Current bit number.
    +
    122C> - IPTR(26)- Data width change.
    +
    123C> - IPTR(27)- Data scale change.
    +
    124C> - IPTR(28)- Data reference value change.
    +
    125C> - IPTR(29)- Add data associated field.
    +
    126C> - IPTR(30)- Signify characters.
    +
    127C> - IPTR(31)- Number of expanded descriptors in mstack.
    +
    128C> - IPTR(32)- Current descriptor segment f.
    +
    129C> - IPTR(33)- Current descriptor segment x.
    +
    130C> - IPTR(34)- Current descriptor segment y.
    +
    131C> - IPTR(35)- Unused.
    +
    132C> - IPTR(36)- Next descriptor may be undecipherable.
    +
    133C> - IPTR(37)- Unused.
    +
    134C> - IPTR(38)- Unused.
    +
    135C> - IPTR(39)- Delayed replication flag.
    +
    136C> - 0 - No delayed replication.
    +
    137C> - 1 - Message contains delayed replication.
    +
    138C> - IPTR(40)- Number of characters in text for curr descriptor.
    +
    139C> @param[out] IDENT Array contains message information extracted from bufr message
    +
    140C> - IDENT( 1)-Edition number (byte 4, section 1).
    +
    141C> - IDENT( 2)-Originating center (bytes 5-6, section 1).
    +
    142C> - IDENT( 3)-Update sequence (byte 7, section 1).
    +
    143C> - IDENT( 4)-Optional section (byte 8, section 1).
    +
    144C> - IDENT( 5)-Bufr message type (byte 9, section 1).
    +
    145C> - 0 = Surface (land)
    +
    146C> - 1 = Surface (ship)
    +
    147C> - 2 = Vertical soundings other than satellite
    +
    148C> - 3 = Vertical soundings (satellite)
    +
    149C> - 4 = Sngl lvl upper-air other than satellite
    +
    150C> - 5 = Sngl lvl upper-air (satellite)
    +
    151C> - 6 = Radar
    +
    152C> - IDENT( 6)-Bufr msg sub-type (byte 10, section 1)
    +
    153C> | type | sbtyp |
    +
    154C> | :--- | :---- |
    +
    155C> | 2 | 7 = profiler |
    +
    156C> - IDENT(7) - bytes 11-12, section 1).
    +
    157C> - IDENT(8) - Year of century (byte 13, section 1).
    +
    158C> - IDENT(9) - Month of year (byte 14, section 1).
    +
    159C> - IDENT(10) - Day of month (byte 15, section 1).
    +
    160C> - IDENT(11) - Hour of day (byte 16, section 1).
    +
    161C> - IDENT(12) - Minute of hour (byte 17, section 1).
    +
    162C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1).
    +
    163C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3).
    +
    164C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3).
    +
    165C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3).
    +
    166C> - IDENT(17) - Master table number (byte 4, section 1, ed 2 or gtr).
    +
    167C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    168C> @param[in] KNR
    +
    169C> kdata(report number,parameter number) arrays containing data from table b
    +
    170C> - ANAME Descriptor name.
    +
    171C> - AUNITS Units for descriptor.
    +
    172C> - MSCALE Scale for value of descriptor.
    +
    173C> - MREF Reference value for descriptor.
    +
    174C> - MWIDTH Bit width for value of descriptor.
    +
    175C> @param[out] INDEX Pointer to available subset.
    +
    176C>
    +
    177C> @note Error returns:
    +
    178C> - IPTR(1):
    +
    179C> - = 1 'BUFR' Not found in first 125 characters.
    +
    180C> - = 2 '7777' Not found in location determined by
    +
    181C> by using counts found in each section. one or
    +
    182C> more sections have an erroneous byte count or
    +
    183C> characters '7777' are not in test message.
    +
    184C> - = 3 Message contains a descriptor with f=0 that does
    +
    185C> not exist in table b.
    +
    186C> - = 4 Message contains a descriptor with f=3 that does
    +
    187C> not exist in table d.
    +
    188C> - = 5 Message contains a descriptor with f=2 with the
    +
    189C> value of x outside the range 1-5.
    +
    190C> - = 6 Descriptor element indicated to have a flag value
    +
    191C> does not have an entry in the flag table
    +
    192C> (to be activated).
    +
    193C> - = 7 Descriptor indicated to have a code value does
    +
    194C> not have an entry in the code table
    +
    195C> (to be activated).
    +
    196C> - = 8 Error reading table d.
    +
    197C> - = 9 Error reading table b.
    +
    198C> - = 10 Error reading code/flag table.
    +
    199C> - = 11 Descriptor 2 04 004 not followed by 0 31 021.
    +
    200C> - = 12 Data descriptor operator qualifier does not follow
    +
    201C> delayed replication descriptor.
    +
    202C> - = 13 Bit width on ascii characters not a multiple of 8.
    +
    203C> - = 14 Subsets = 0, no content bulletin.
    +
    204C> - = 20 Exceeded count for delayed replication pass.
    +
    205C> - = 21 Exceeded count for non-delayed replication pass.
    +
    206C> - = 22 Section 1 count exceeds 10000.
    +
    207C> - = 23 Section 2 count exceeds 10000.
    +
    208C> - = 24 Section 3 count exceeds 10000.
    +
    209C> - = 25 Section 4 count exceeds 10000.
    +
    210C> - = 27 Non zero lowest on text data.
    +
    211C> - = 28 Nbinc not nr of characters.
    +
    212C> - = 29 Table b appears to be damaged.
    +
    213C> - = 99 No more subsets (reports) available in current
    +
    214C> bufr mesage.
    +
    215C> - = 400 Number of subsets exceeds capability of routine.
    +
    216C> - = 401 Number of parameters (and associated fields)
    +
    217C> exceeds limits of this program.
    +
    218C> - = 500 Value for nbinc has been found that exceeds
    +
    219C> standard width plus any bit width change
    +
    220C> check all bit widths up to point of error.
    +
    221C> - = 501 Corrected width for descriptor is 0 or less.
    +
    222C>
    +
    223C> On the initial call to w3fi67() with a bufr message the argument
    +
    224C> index must be set to zero (index = 0). on the return from w3fi67()
    +
    225C> 'index' will be set to the next available subset/report. when
    +
    226C> there are no more subsets available a 99 err return will occur.
    +
    227C>
    +
    228C> If the original bufr message does not contain delayed replication
    +
    229C> the bufr message will be completely decoded and 'index' will point
    +
    230C> to the first decoded subset. The users will then have the option
    +
    231C> of indexing through the subsets on their own or by recalling this
    +
    232C> routine (without resetting 'index') to have the routine do the
    +
    233C> indexing.
    +
    234C>
    +
    235C> If the original bufr message does contain delayed replication
    +
    236C> one subset/report will be decoded at a time and passed back to
    +
    237C> the user. this is not an option.
    +
    238C>
    +
    239C> =============================================
    +
    240C> TO USE THIS ROUTINE
    +
    241C> --------------------------------
    +
    242C> 1. READ IN BUFR MESSAGE
    +
    243C> 2. SET INDEX = 0
    +
    244C> 3. CALL W3FI67( )
    +
    245C> 4. IF (IPTR(1).EQ.99) THEN
    +
    246C> NO MORE SUBSETS
    +
    247C> EITHER GO TO 1
    +
    248C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    249C> END IF
    +
    250C> 5. IF (IPTR(1).NE.0) THEN
    +
    251C> ERROR CONDITION
    +
    252C> EITHER GO TO 1
    +
    253C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    254C> END IF
    +
    255C> 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO
    +
    256C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
    +
    257C> CALL W3FL05 ( )
    +
    258C> ELSE
    +
    259C> PROCESS DECODED INFORMATION AS REQUIRED
    +
    260C> END IF
    +
    261C> 7. GO TO 3
    +
    262C>
    +
    263C> =============================================
    +
    264C> THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED
    +
    265C> AS FOLLOWS:
    +
    266C> KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE)
    +
    267C> WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS
    +
    268C> (FOR THIS VERSION OF THE DECODER A=500)
    +
    269C> THAT MAY BE CONTAINED IN THE BUFR MESSAGE, AND
    +
    270C> WHERE B IS THE MAXIMUM NUMBER OF DESCRIPTOR
    +
    271C> COMBINATIONS THAT MAY BE PROCESSED.
    +
    272C> UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE
    +
    273C> A VALUE FOR B OF 1600, BUT FOR MOST OTHER DATA
    +
    274C> A VALUE FOR B OF 500 WILL SUFFICE
    +
    275C> MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE
    +
    276C> DATA ENTRY
    +
    277C> MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO
    +
    278C> THE DATA
    +
    279C>
    +
    280C> ATTRIBUTES:
    +
    281C> LANGUAGE: FORTRAN 77
    +
    282C> MACHINE: NAS
    +
    283C>
    +
    +
    284 SUBROUTINE w3fi67(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX)
    +
    285C
    +
    286 CHARACTER*40 ANAME(700)
    +
    287 CHARACTER*24 AUNITS(700)
    +
    288C
    +
    289C
    +
    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
    +
    300C
    +
    301 CHARACTER*4 DIRID(2)
    +
    302C
    +
    303 LOGICAL SEC2
    +
    304C
    +
    305 SAVE
    +
    306C
    +
    307C PRINT *,' W3FI67 DECODER'
    +
    308C INITIALIZE ERROR RETURN
    +
    309 iptr(1) = 0
    +
    310 IF (index.GT.0) THEN
    +
    311C HAVE RE-ENTRY
    +
    312 index = index + 1
    +
    313C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
    +
    314 IF (index.GT.ident(14)) THEN
    +
    315C 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
    +
    328C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
    +
    329 END IF
    +
    330 iptr(39) = 0
    +
    331C 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
    +
    340C 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
    +
    351C TEST FOR EDITION NUMBER
    +
    352C ======================
    +
    353 CALL gbyte (msga,ident(1),inofst+24,8)
    +
    354C 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
    +
    361C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
    +
    362 inofst = inofst + 32
    +
    363 END IF
    +
    364 iptr(3) = inofst
    +
    365C SECTION 1 COUNT
    +
    366 CALL gbyte (msga,ivals,inofst,24)
    +
    367C 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
    +
    374C GET BUFR MASTER TABLE
    +
    375 CALL gbyte (msga,ivals,inofst,8)
    +
    376 inofst = inofst + 8
    +
    377 ident(17) = ivals(1)
    +
    378C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
    +
    379 ELSE
    +
    380 iptr(3) = inofst
    +
    381C SECTION 1 COUNT
    +
    382 CALL gbyte (msga,ivals,inofst,24)
    +
    383C 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
    +
    391C ======================
    +
    392C ORIGINATING CENTER
    +
    393 CALL gbyte (msga,ivals,inofst,16)
    +
    394 inofst = inofst + 16
    +
    395 ident(2) = ivals(1)
    +
    396C UPDATE SEQUENCE
    +
    397 CALL gbyte (msga,ivals,inofst,8)
    +
    398 inofst = inofst + 8
    +
    399 ident(3) = ivals(1)
    +
    400C 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
    +
    406C PRINT *,' NO OPTIONAL SECTION 2'
    +
    407 sec2 = .false.
    +
    408 END IF
    +
    409 inofst = inofst + 8
    +
    410C MESSAGE TYPE
    +
    411 CALL gbyte (msga,ivals,inofst,8)
    +
    412 ident(5) = ivals(1)
    +
    413 inofst = inofst + 8
    +
    414C MESSAGE SUB-TYPE
    +
    415 CALL gbyte (msga,ivals,inofst,8)
    +
    416 ident(6) = ivals(1)
    +
    417 inofst = inofst + 8
    +
    418C IF BUFR EDITION 0 OR 1 THEN
    +
    419C NEXT 2 BYTES ARE BUFR TABLE VERSION
    +
    420C ELSE
    +
    421C BYTE 11 IS VER NR OF MASTER TABLE
    +
    422C 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
    +
    428C BYTE 11 IS VER NR OF MASTER TABLE
    +
    429 CALL gbyte (msga,ivals,inofst,8)
    +
    430 ident(18) = ivals(1)
    +
    431 inofst = inofst + 8
    +
    432C 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
    +
    438C YEAR OF CENTURY
    +
    439 CALL gbyte (msga,ivals,inofst,8)
    +
    440 ident(8) = ivals(1)
    +
    441 inofst = inofst + 8
    +
    442C MONTH
    +
    443 CALL gbyte (msga,ivals,inofst,8)
    +
    444 ident(9) = ivals(1)
    +
    445 inofst = inofst + 8
    +
    446C DAY
    +
    447 CALL gbyte (msga,ivals,inofst,8)
    +
    448 ident(10) = ivals(1)
    +
    449 inofst = inofst + 8
    +
    450C HOUR
    +
    451 CALL gbyte (msga,ivals,inofst,8)
    +
    452 ident(11) = ivals(1)
    +
    453 inofst = inofst + 8
    +
    454C MINUTE
    +
    455 CALL gbyte (msga,ivals,inofst,8)
    +
    456 ident(12) = ivals(1)
    +
    457C RESET POINTER (INOFST) TO START OF
    +
    458C NEXT SECTION
    +
    459C (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
    +
    465C SECTION 2 COUNT
    +
    466 CALL gbyte (msga,iptr(4),inofst,24)
    +
    467 inofst = inofst + 32
    +
    468C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
    +
    469 kentry = (iptr(4) - 4) / 14
    +
    470C 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
    +
    485C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
    +
    486 2000 CONTINUE
    +
    487 END IF
    +
    488C RESET POINTER (INOFST) TO START OF
    +
    489C SECTION 3
    +
    490 inofst = iptr(5) + iptr(4) * 8
    +
    491 END IF
    +
    492C BIT OFFSET TO START OF SECTION 3
    +
    493 iptr( 7) = inofst
    +
    494C SECTION 3 COUNT
    +
    495 CALL gbyte (msga,iptr(6),inofst,24)
    +
    496C 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
    +
    503C 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
    +
    514C OBSERVED DATA FLAG
    +
    515 CALL gbyte (msga,ivals,inofst,1)
    +
    516 ident(15) = ivals(1)
    +
    517 inofst = inofst + 1
    +
    518C COMPRESSED DATA FLAG
    +
    519 CALL gbyte (msga,ivals,inofst,1)
    +
    520 ident(16) = ivals(1)
    +
    521 inofst = inofst + 7
    +
    522C CALCULATE NUMBER OF DESCRIPTORS
    +
    523 nrdesc = (iptr( 6) - 8) / 2
    +
    524 iptr(12) = nrdesc
    +
    525 iptr(13) = nrdesc
    +
    526C EXTRACT DESCRIPTORS
    +
    527 CALL gbytes (msga,istack,inofst,16,0,nrdesc)
    +
    528C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
    +
    529 DO 10 l = 1, nrdesc
    +
    530 iwork(l) = istack(l)
    +
    531C PRINT *,L,ISTACK(L)
    +
    532 10 CONTINUE
    +
    533 iptr(13) = nrdesc
    +
    534C RESET POINTER TO START OF SECTION 4
    +
    535 inofst = iptr(7) + iptr(6) * 8
    +
    536C BIT OFFSET TO START OF SECTION 4
    +
    537 iptr( 9) = inofst
    +
    538C 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
    +
    544C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    545 iptr( 8) = ivals(1)
    +
    546 inofst = inofst + 32
    +
    547C SET FOR STARTING BIT OF DATA
    +
    548 iptr(25) = inofst
    +
    549C FIND OUT IF '7777' TERMINATOR IS THERE
    +
    550 inofst = iptr(9) + iptr(8) * 8
    +
    551 CALL gbyte (msga,ivals,inofst,32)
    +
    552C 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)
    +
    562C PRINT *,'HAVE RETURNED FROM FI6701'
    +
    563 IF (iptr(1).NE.0) THEN
    +
    564 RETURN
    +
    565 END IF
    +
    566C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
    +
    567 IF (ident(5).EQ.2) THEN
    +
    568 IF (ident(6).EQ.7) THEN
    +
    569C DO 151 I = 1, 40
    +
    570C IF (I.LE.20) THEN
    +
    571C PRINT *,'IPTR(',I,')=',IPTR(I),
    +
    572C * ' IDENT(',I,')= ',IDENT(I)
    +
    573C ELSE
    +
    574C PRINT *,'IPTR(',I,')=',IPTR(I)
    +
    575C END IF
    +
    576C 151 CONTINUE
    +
    577C DO 153 I = 1, KNR(INDEX)
    +
    578C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    579C 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
    +
    589C DO 154 I = 1, KNR(INDEX)
    +
    590C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    591C 154 CONTINUE
    +
    592 END IF
    +
    593 END IF
    +
    594 RETURN
    +
    +
    595 END
    +
    596
    +
    597C> @brief Data extraction.
    +
    598C> @author Bill Cavanaugh @date 1988-09-01
    +
    599
    +
    600C> Control the extraction of data from section 4 based on
    +
    601C> data descriptors.
    +
    602C>
    +
    603C> Program history log:
    +
    604C> - Bill Cavanaugh 1988-09-01
    +
    605C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
    +
    606C> data.
    +
    607C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
    +
    608C> delayed replication.
    +
    609C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
    +
    610C>
    +
    611C> @param[in] IPTR See w5fi67 routine docblock.
    +
    612C> @param[in] IDENT See w3fi67 routine docblock.
    +
    613C> @param[in] MSGA Array containing bufr message.
    +
    614C> @param[inout] ISTACK [in] Original array of descriptors extracted from
    +
    615C> source bufr message. [out] Arrays containing data from table b.
    +
    616C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
    +
    617C> factor.
    +
    618C> @param[inout] KDESC Image of current descriptor.
    +
    619C> @param[in] INDEX
    +
    620C> @param KNR
    +
    621C> @param[out] IWORK Working descriptor list
    +
    622C> @param IVALS
    +
    623C> @param[out] KDATA Array containing decoded reports from bufr message
    +
    624C> kdata(report number,parameter number).
    +
    625C> @param[out] ANAME Descriptor name..
    +
    626C> @param[out] AUNITS Units for descriptor.
    +
    627C> @param[out] MSCALE Scale for value of descriptor.
    +
    628C> @param[out] MREF Reference value for descriptor.
    +
    629C> @param[out] MWIDTH Bit width for value of descriptor.
    +
    630C>
    +
    631C> @note Error return:
    +
    632C> - IPTR(1)
    +
    633C> - = 8 ERROR READING TABLE B
    +
    634C> - = 9 ERROR READING TABLE D
    +
    635C> - = 11 ERROR OPENING TABLE B
    +
    636C>
    +
    637C> @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
    +
    642C
    +
    643 CHARACTER*40 ANAME(*)
    +
    644 CHARACTER*24 AUNITS(*)
    +
    645C
    +
    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)
    +
    661C
    +
    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/
    +
    668C
    +
    669C PRINT *,' DECOLL FI6701'
    +
    670 IF (index.GT.1) THEN
    +
    671 GO TO 1000
    +
    672 END IF
    +
    673C --------- 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
    +
    681C INITIALIZE OUTPUT AREA
    +
    682C SET POINTER TO BEGINNING OF DATA
    +
    683C SET BIT
    +
    684 iptr(17) = 1
    +
    685 1000 CONTINUE
    +
    686C IPTR(12) = IPTR(13)
    +
    687 ll = 0
    +
    688 iptr(11) = 1
    +
    689 IF (iptr(10).EQ.0) THEN
    +
    690C RE-ENTRY POINT FOR MULTIPLE
    +
    691C 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
    +
    699C PRINT *,'FI6701 - RPT',IPTR(17),' STARTS AT',IPTR(25)
    +
    700 iptr(24) = 0
    +
    701 iptr(31) = 0
    +
    702C POINTING AT NEXT AVAILABLE DESCRIPTOR
    +
    703 mm = 0
    +
    704 IF (iptr(21).EQ.0) THEN
    +
    705C 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
    +
    721C PRINT *,I
    +
    722C WRITE(6,21) MF,MX,MY,KDESC(I),
    +
    723C * (ANAME(I)(K:K),K=1,40),
    +
    724C * (AUNITS(I)(K:K),K=1,24),
    +
    725C * 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
    +
    732C CLOSE(UNIT=20,STATUS='KEEP')
    +
    733 iptr(21) = 1
    +
    734 END IF
    +
    735C DO WHILE MM <= 500
    +
    736 10 CONTINUE
    +
    737C PROCESS THRU THE FOLLOWING
    +
    738C 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
    +
    744C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
    +
    745 IF (iptr(11).GT.iptr(12)) THEN
    +
    746C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
    +
    747 IF (ident(16).NE.0) THEN
    +
    748C PRINT *,' PROCESSING COMPRESSED REPORTS'
    +
    749C REFORMAT DATA FROM DESCRIPTOR
    +
    750C FORM TO USER FORM
    +
    751 RETURN
    +
    752 ELSE
    +
    753C WRITE (6,1)
    +
    754C 1 FORMAT (1H1)
    +
    755C 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
    +
    764C RESET POINTERS
    +
    765 ll = 0
    +
    766 iptr(1) = 0
    +
    767 iptr(11) = 1
    +
    768 iptr(12) = iptr(13)
    +
    769C IS THIS LAST REPORT ?
    +
    770C PRINT *,'READY',IPTR(39),INDEX
    +
    771 IF (iptr(39).GT.0) THEN
    +
    772 IF (index.GT.0) THEN
    +
    773C 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
    +
    781C GET NEXT DESCRIPTOR
    +
    782 CALL fi6708 (iptr,iwork,lf,lx,ly,jdesc)
    +
    783C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
    +
    784C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
    +
    785C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
    +
    786C * ' FOR LOC',IPTR(17),IPTR(25)
    +
    787 IF (iptr(11).GT.1600) THEN
    +
    788 iptr(1) = 401
    +
    789 RETURN
    +
    790 END IF
    +
    791C
    +
    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
    +
    800C REPLICATION PROCESSING
    +
    801 IF (lf.EQ.1) THEN
    +
    802C ---------- 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
    +
    808C PRINT *,'FI6701-1',KPRM,MSTACK(1,KPRM),
    +
    809C * 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
    +
    817C
    +
    818C 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
    +
    827C PRINT *,'FI6701-2',KPRM,MSTACK(1,KPRM),
    +
    828C * 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
    +
    836C DESCRIPTOR SEQUENCE STRINGS
    +
    837 ELSE IF (lf.EQ.3) THEN
    +
    838C PRINT *,'F3 SEQUENCE DESCRIPTOR'
    +
    839 IF (iptr(22).EQ.0) THEN
    +
    840C READ IN TABLE D, BUT JUST ONCE
    +
    841 ierr = 0
    +
    842C 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
    +
    853C PRINT 16,(ITBLD(I,L),L=1,11)
    +
    854 GO TO 50
    +
    855 END IF
    +
    856 25 CONTINUE
    +
    857C 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
    +
    869C
    +
    870C STANDARD DESCRIPTOR PROCESSING
    +
    871 ELSE
    +
    872C 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)
    +
    876C 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
    +
    891C END IF
    +
    892C END DO WHILE
    +
    893 200 CONTINUE
    +
    894 IF (ident(16).NE.0) THEN
    +
    895C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
    +
    896 ELSE
    +
    897C 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
    +
    909C> @brief Process standard descriptor.
    +
    910C> @author Bill Cavanaugh @date 1988-09-01
    +
    911
    +
    912C> Process a standard descriptor (f = 0) and store data
    +
    913C> in output array.
    +
    914C>
    +
    915C> Program history log:
    +
    916C> - Bill Cavanaugh 1988-09-01
    +
    917C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes.
    +
    918C>
    +
    919C> @param[in] IPTR See w3fi67 routine docblock.
    +
    920C> @param[in] IDENT See w3fi67 routine docblock.
    +
    921C> @param[in] MSGA Array containing bufr message.
    +
    922C> @param[inout] KDATA Array containing decoded reports from bufr message.
    +
    923C> KDATA(Report number, parameter number)
    +
    924C> @param[inout] KDESC Image of current descriptor.
    +
    925C> @param[in] MSTACK
    +
    926C> @param LL
    +
    927C> @param[out] AUNITS Units for descriptor.
    +
    928C> @param[out] MSCALE Scale for value of descriptor.
    +
    929C> @param[out] MREF Reference value for descriptor.
    +
    930C> @param[out] MWIDTH Bit width for value of descriptor.
    +
    931C> @param JDESC
    +
    932C> @param[in] IVALS Array of single parameter values.
    +
    933C> @param J
    +
    934C>
    +
    935C> @note Error return:
    +
    936C> IPTR(1) = 3 - Message contains a descriptor with f=0
    +
    937C> that does not exist in table b.
    +
    938C>
    +
    939C> @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
    +
    944C TABLE B ENTRY
    +
    945 CHARACTER*24 ASKEY
    +
    946 CHARACTER*24 AUNITS(*)
    +
    947C 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(*)
    +
    956C TABLE B ENTRY
    +
    957C
    +
    958 DATA askey /'CCITT IA5 '/
    +
    959C
    +
    960C PRINT *,' FI6702 - STANDARD DESCRIPTOR PROCESSOR'
    +
    961C GET A MATCH BETWEEN CURRENT
    +
    962C DESCRIPTOR (JDESC) AND
    +
    963C TABLE B ENTRY
    +
    964C IF (KDESC(356).EQ.0) THEN
    +
    965C PRINT *,'FI6702 - KDESC(356) WENT TO ZER0'
    +
    966C IPTR(1) = 600
    +
    967C RETURN
    +
    968C 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
    +
    977C HAVE SKIP FLAG
    +
    978 IF (ident(16).NE.0) THEN
    +
    979C SKIP OVER COMPRESSED DATA
    +
    980C LOWEST
    +
    981 iptr(25) = iptr(25) + iptr(36)
    +
    982C 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
    +
    992C 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
    +
    1003C SKIP OVER NON-COMPRESSED DATA
    +
    1004C 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
    +
    1038C HAVE A MATCH
    +
    1039C 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
    +
    1047C 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
    +
    1054C NOT COMPRESSED
    +
    1055 CALL fi6704(iptr,msga,kdata,ivals,mstack,
    +
    1056 * mwidth,mref,mscale,j,ll,jdesc)
    +
    1057 END IF
    +
    1058 RETURN
    +
    +
    1059 END
    +
    1060C> @brief Process compressed data and place individual elements into output
    +
    1061C> array
    +
    1062C> @author Bill Cavanaugh @date 1988-09-01
    +
    1063
    +
    1064C> Program history log:
    +
    1065C> - Bill Cavanaugh 1988-09-01
    +
    1066C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1067C> modified to hanle width of fields in bytes.
    +
    1068C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1069C> and uncompressed form gave different results. This has been corrected.
    +
    1070C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
    +
    1071C> provide exact reproduction of all characters.
    +
    1072C>
    +
    1073C> @param[in] IPTR See w3fi67() routine docblock.
    +
    1074C> @param[in] IDENT See w3fi67() routine docblock.
    +
    1075C> @param[in] MSGA Array containing bufr message, mstack.
    +
    1076C> @param[in] MSTACK
    +
    1077C> @param[in] IVALS Array of single parameter values.
    +
    1078C> @param[inout] J
    +
    1079C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1080C> kdata(report number,parameter number).
    +
    1081C> @param JDESC
    +
    1082C> Arrays Containing data from table b.
    +
    1083C> @param[out] MSCALE Scale for value of descriptor.
    +
    1084C> @param[out] MREF Reference value for descriptor.
    +
    1085C> @param[out] MWIDTH Bit width for value of descriptor.
    +
    1086C>
    +
    1087C> @note List caveats, other helpful hints or information.
    +
    1088C>
    +
    1089C> @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
    +
    1094C
    +
    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)
    +
    1104C
    +
    1105 LOGICAL TEXT
    +
    1106C
    +
    1107 INTEGER MSK(28)
    +
    1108C
    +
    1109C
    +
    1110 DATA msk /1,3,7,15,31,63,127,
    +
    1111C 1 2 3 4 5 6 7
    +
    1112 * 255,511,1023,2047,4095,
    +
    1113C 8 9 10 11 12
    +
    1114 * 8191,16383,32767,65535,
    +
    1115C 13 14 15 16
    +
    1116 * 131071,262143,524287,
    +
    1117C 17 18 19
    +
    1118 * 1048575,2097151,4194303,
    +
    1119C 20 21 22
    +
    1120 * 8388607,16777215,33554431,
    +
    1121C 23 24 25
    +
    1122 * 67108863,134217727,268435455/
    +
    1123C 26 27 28
    +
    1124C
    +
    1125C PRINT *,' FI6703 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
    +
    1126C * ' 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
    +
    1132C PRINT *,'DESCRIPTOR',KPRM
    +
    1133 IF (.NOT.text) THEN
    +
    1134 IF (iptr(29).GT.0) THEN
    +
    1135C WORKING WITH ASSOCIATED FIELDS HERE
    +
    1136 iptr(31) = iptr(31) + 1
    +
    1137 kprm = iptr(31) + iptr(24)
    +
    1138C GET LOWEST
    +
    1139 CALL gbyte (msga,lowest,iptr(25),iptr(29))
    +
    1140 iptr(25) = iptr(25) + iptr(29)
    +
    1141C GET NBINC
    +
    1142 CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1143 iptr(25) = iptr(25) + 6
    +
    1144C 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
    +
    1164C SET PARAMETER
    +
    1165C ISOLATE STANDARD BIT WIDTH
    +
    1166 jwide = mwidth(j) + iptr(26)
    +
    1167C SINGLE VALUE FOR LOWEST
    +
    1168 nrvals = 1
    +
    1169C LOWEST
    +
    1170C PRINT *,'PARAM',KPRM
    +
    1171 CALL gbyte (msga,lowest,iptr(25),jwide)
    +
    1172C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
    +
    1173 iptr(25) = iptr(25) + jwide
    +
    1174C ISOLATE COMPRESSED BIT WIDTH
    +
    1175 CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1176C 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
    +
    1180C PRINT *,'FOR DESCRIPTOR',JDESC
    +
    1181C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
    +
    1182C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
    +
    1183C DO 110 I = 1, KPRM
    +
    1184C WRITE (6,111)I,(KDATA(J,I),J=1,6)
    +
    1185C 110 CONTINUE
    +
    1186 111 FORMAT (1x,5hdata ,i3,6(2x,i10))
    +
    1187 iptr(1) = 500
    +
    1188C 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
    +
    1194C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
    +
    1195C IF TEXT EVENT, PROCESS TEXT
    +
    1196C GET COMPRESSED VALUES
    +
    1197C 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
    +
    1204C RECALCULATE TO ORIGINAL VALUES
    +
    1205 DO 100 i = 1, nrvals
    +
    1206C 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
    +
    1217C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3)
    +
    1218C 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
    +
    1235C 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
    +
    1242C WRITE (6,80) (DATA(I,KPRM),I=1,10)
    +
    1243C 80 FORMAT(2X,10(F10.2,1X))
    +
    1244 ELSE IF (text) THEN
    +
    1245C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
    +
    1246C GET LOWEST
    +
    1247C 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
    +
    1257C GET NBINC
    +
    1258 CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1259C 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
    +
    1266C 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
    +
    1276C 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
    +
    1281C CONVERTS ASCII TO EBCIDIC
    +
    1282C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1283C PRINT *,IDATA
    +
    1284 CALL w3ai39 (idata,4)
    +
    1285 mstack(1,kprm) = jdesc
    +
    1286 mstack(2,kprm) = 0
    +
    1287 kdata(n,kprm) = idata
    +
    1288C SET FOR NEXT PART
    +
    1289 kprm = kprm + 1
    +
    1290 iptr(24) = iptr(24) + 1
    +
    1291C 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
    +
    1303C CONVERTS ASCII TO EBCIDIC
    +
    1304C 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
    +
    1309C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
    +
    1310 nbits = 0
    +
    1311 END IF
    +
    1312C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
    +
    1313C1800 FORMAT (2X,I4,2X,3A4)
    +
    1314 1900 CONTINUE
    +
    1315 END IF
    +
    1316 RETURN
    +
    +
    1317 END
    +
    1318C> @brief Process data that is not compressed.
    +
    1319C> @author Bill Cavanaugh @date 1988-09-01
    +
    1320
    +
    1321C> Program history log:
    +
    1322C> - Bill Cavanaugh 1988-09-01
    +
    1323C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
    +
    1324C> data.
    +
    1325C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1326C> modified to handle field width in bytes.
    +
    1327C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1328C> and uncompressed form gave different results. This has been corrected.
    +
    1329C>
    +
    1330C> @param[in] IPTR See w3fi67 routine docblock
    +
    1331C> @param[in] MSGA Array containing bufr message
    +
    1332C> @param[inout] IVALS Array of single parameter values
    +
    1333C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1334C> kdata(report number,parameter number)
    +
    1335C> @param[inout] J [in] ? [out] arrays containing data from table b
    +
    1336C> @param[out] MSCALE Scale for value of descriptor
    +
    1337C> @param[in] MSTACK
    +
    1338C> @param LL
    +
    1339C> @param JDESC
    +
    1340C> @param[out] MREF Reference value for descriptor
    +
    1341C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1342C>
    +
    1343C> @note Error return:
    +
    1344C> - IPTR(1) = 13 - Bit width on ASCII chars not a multiple of 8.
    +
    1345C>
    +
    1346C> @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
    +
    1351C
    +
    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
    +
    1360C
    +
    1361C
    +
    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/
    +
    1369C
    +
    1370C 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
    +
    1375C -------- NOCMP --------
    +
    1376C ISOLATE BIT WIDTH
    +
    1377 jwide = mwidth(j) + iptr(26)
    +
    1378C IF NOT TEXT EVENT, PROCESS
    +
    1379 IF (iptr(18).NE.1) THEN
    +
    1380C 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)
    +
    1390C PRINT *,'FI6704-A',KPRM,MSTACK(1,KPRM),
    +
    1391C * 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
    +
    1402C GET VALUES
    +
    1403C CALL TO GET DATA OF GIVEN BIT WIDTH
    +
    1404 CALL gbyte (msga,ivals,iptr(25),jwide)
    +
    1405C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
    +
    1406 iptr(25) = iptr(25) + jwide
    +
    1407C 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
    +
    1417C PRINT *,'FI6704-B',KPRM,MSTACK(1,KPRM),
    +
    1418C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1419C IF(JDESC.EQ.2049) THEN
    +
    1420C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
    +
    1421C END IF
    +
    1422C PRINT *,'FI6704 ',KPRM,MSTACK(1,KPRM),
    +
    1423C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1424 ELSE
    +
    1425C IF TEXT EVENT, PROCESS TEXT
    +
    1426C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
    +
    1427 nrchrs = iptr(40)
    +
    1428 nrbits = nrchrs * 8
    +
    1429C 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)
    +
    1436C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
    +
    1437C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
    +
    1438C CONVERTS ASCII TO EBCIDIC
    +
    1439C 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
    +
    1445C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1446C * 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
    +
    1452C PRINT *,'LAST TEXT WORD'
    +
    1453 CALL gbyte (msga,idata,iptr(25),nrbits)
    +
    1454 iptr(25) = iptr(25) + nrbits
    +
    1455C CONVERTS ASCII TO EBCIDIC
    +
    1456C 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
    +
    1464C PRINT 1723,IDATA
    +
    1465 1723 FORMAT (12x,z8)
    +
    1466 1722 CONTINUE
    +
    1467 END IF
    +
    1468 kdata(iptr(17),kprm) = idata
    +
    1469C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
    +
    1470 mstack(1,kprm) = jdesc
    +
    1471 mstack(2,kprm) = 0
    +
    1472C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1473C * KDATA(IPTR(17),KPRM)
    +
    1474 END IF
    +
    1475C TURN OFF TEXT
    +
    1476 iptr(18) = 0
    +
    1477 END IF
    +
    1478 RETURN
    +
    +
    1479 END
    +
    1480C> @brief Process a replication descriptor, must extract number
    +
    1481C> of replications of n descriptors from the data stream.
    +
    1482C> @author Bill Cavanaugh @date 1988-09-01
    +
    1483
    +
    1484C> Process a replication descriptor, must extract number
    +
    1485C> of replications of n descriptors from the data stream.
    +
    1486C>
    +
    1487C> Program history log:
    +
    1488C> - Bill Cavanaugh 1988-09-01
    +
    1489C>
    +
    1490C> @param[in] IWORK Working descriptor list
    +
    1491C> @param[in] IPTR See w3fi67 routine docblock
    +
    1492C> @param[in] IDENT See w3fi67 routine docblock
    +
    1493C> @param[inout] LX X portion of current descriptor
    +
    1494C> @param[inout] LY Y portion of current descriptor
    +
    1495C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1496C> kdata(report number,parameter number)
    +
    1497C> @param LL
    +
    1498C> @param KNR
    +
    1499C> @param MSTACK
    +
    1500C> @param MSGA
    +
    1501C>
    +
    1502C> @note Error return:
    +
    1503C> - IPTR(1)
    +
    1504C> - = 12 Data descriptor qualifier does not follow
    +
    1505C> delayed replication descriptor.
    +
    1506C> - = 20 Exceeded count for delayed replication pass.
    +
    1507C>
    +
    1508C> @author Bill Cavanaugh @date 1988-09-01
    +
    +
    1509 SUBROUTINE fi6705(IPTR,IDENT,MSGA,IWORK,LX,LY,
    +
    1510 * KDATA,LL,KNR,MSTACK)
    +
    1511
    +
    1512 SAVE
    +
    1513C
    +
    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(*)
    +
    1523C
    +
    1524C PRINT *,' REPLICATION FI6705'
    +
    1525C DO 100 I = 1, IPTR(13)
    +
    1526C PRINT *,I,IWORK(I)
    +
    1527C 100 CONTINUE
    +
    1528C NUMBER OF DESCRIPTORS
    +
    1529 nrset = lx
    +
    1530C NUMBER OF REPLICATIONS
    +
    1531 nrreps = ly
    +
    1532 icurr = iptr(11) - 1
    +
    1533 ipick = iptr(11) - 1
    +
    1534C
    +
    1535 IF (nrreps.EQ.0) THEN
    +
    1536 iptr(39) = 1
    +
    1537C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
    +
    1538C IPTR(31) = IPTR(31) + 1
    +
    1539C KPRM = IPTR(31) + IPTR(24)
    +
    1540C MSTACK(1,KPRM) = JDESC
    +
    1541C MSTACK(2,KPRM) = 0
    +
    1542C KDATA(IPTR(17),KPRM) = 0
    +
    1543C PRINT *,'FI6705-1',KPRM,MSTACK(1,KPRM),
    +
    1544C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1545C DELAYED REPLICATION - MUST GET NUMBER OF
    +
    1546C REPLICATIONS FROM DATA.
    +
    1547C GET NEXT DESCRIPTOR
    +
    1548 CALL fi6708(iptr,iwork,lf,lx,ly,jdesc)
    +
    1549C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
    +
    1550C MUST BE DATA DESCRIPTION
    +
    1551C 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
    +
    1561C SET SINGLE VALUE FOR SEQUENTIAL,
    +
    1562C MULTIPLE VALUES FOR COMPRESSED
    +
    1563 IF (ident(16).EQ.0) THEN
    +
    1564C NON COMPRESSED
    +
    1565 CALL gbyte (msga,kvals,iptr(25),jwide)
    +
    1566C 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)
    +
    1574C PRINT *,'FI6705-2',KPRM,MSTACK(1,KPRM),
    +
    1575C * 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
    +
    1591C PRINT *,'NOT DELAYED REPLICATION'
    +
    1592 END IF
    +
    1593C RESTRUCTURE WORKING STACK W/REPLICATIONS
    +
    1594C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
    +
    1595C 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
    +
    1599C PRINT *,'REPLICATION ',I,ITEMP(I)
    +
    1600 1000 CONTINUE
    +
    1601C MOVE TRAILING DESCRIPTORS TO HOLD AREA
    +
    1602 lax = iptr(12) - iptr(11) + 1
    +
    1603C 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
    +
    1607C PRINT *,' ',I,KTEMP(I)
    +
    1608 2000 CONTINUE
    +
    1609C REPLICATIONS INTO ISTACK
    +
    1610C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
    +
    1611C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
    +
    1612 DO 4000 i = 1, nrreps
    +
    1613 DO 3000 j = 1, nrset
    +
    1614 iwork(icurr) = itemp(j)
    +
    1615C PRINT *,'FI6705 A',ICURR,IWORK(ICURR)
    +
    1616 icurr = icurr + 1
    +
    1617 3000 CONTINUE
    +
    1618 4000 CONTINUE
    +
    1619C PRINT *,' TO LOC',ICURR-1
    +
    1620C RESTORE TRAILING DESCRIPTORS
    +
    1621C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
    +
    1622 DO 5000 i = 1, lax
    +
    1623 iwork(icurr) = ktemp(i)
    +
    1624C 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
    +
    1632C> @brief Process operator descriptors.
    +
    1633C> @author Bill Cavanaugh @date 1988-09-01
    +
    1634
    +
    1635C> Extract and save indicated change values for use
    +
    1636C> until changes are rescinded, or extract text strings indicated
    +
    1637C> through 2 05 yyy.
    +
    1638C>
    +
    1639C> Program history log:
    +
    1640C> - Bill Cavanaugh 1988-09-01
    +
    1641C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
    +
    1642C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
    +
    1643C> table c descriptor 2 06 yyy.
    +
    1644C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
    +
    1645C> table c descriptor 2 03 yyy, the change
    +
    1646C> to new reference value for selected
    +
    1647C> descriptors.
    +
    1648C>
    +
    1649C> @param[in] IPTR See w3fi67 routine docblock.
    +
    1650C> @param[in] LX X portion of current descriptor.
    +
    1651C> @param[in] LY Y portion of current descriptor.
    +
    1652C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1653C> kdata(report number,parameter number)
    +
    1654C> arrays containing data from table b
    +
    1655C> @param[out] MSCALE Scale for value of descriptor
    +
    1656C> @param[out] MREF Reference value for descriptor
    +
    1657C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1658C> @param IDENT
    +
    1659C> @param MSGA
    +
    1660C> @param IVALS
    +
    1661C> @param MSTACK
    +
    1662C> @param J
    +
    1663C> @param LL
    +
    1664C> @param KDESC
    +
    1665C> @param IWORK
    +
    1666C> @param JDESC
    +
    1667C>
    +
    1668C> @note Error return:
    +
    1669C> - IPTR(1) = 5 - Erroneous x value in data descriptor operator
    +
    1670C>
    +
    1671C> @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
    +
    1685C
    +
    1686C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
    +
    1687 IF (lx.EQ.1) THEN
    +
    1688C CHANGE BIT WIDTH
    +
    1689 IF (ly.EQ.0) THEN
    +
    1690C PRINT *,' RETURN TO NORMAL WIDTH'
    +
    1691 iptr(26) = 0
    +
    1692 ELSE
    +
    1693C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
    +
    1694 iptr(26) = ly - 128
    +
    1695 END IF
    +
    1696 ELSE IF (lx.EQ.2) THEN
    +
    1697C CHANGE SCALE
    +
    1698 IF (ly.EQ.0) THEN
    +
    1699C RESET TO STANDARD SCALE
    +
    1700 iptr(27) = 0
    +
    1701 ELSE
    +
    1702C SET NEW SCALE
    +
    1703 iptr(27) = ly - 128
    +
    1704 END IF
    +
    1705 ELSE IF (lx.EQ.3) THEN
    +
    1706C CHANGE REFERENCE VALUE
    +
    1707C FOR EACH OF THOSE DESCRIPTORS BETWEEN
    +
    1708C 2 03 YYY WHERE Y LT 255 AND
    +
    1709C 2 03 255, EXTRACT THE NEW REFERENCE
    +
    1710C VALUE (BIT WIDTH YYY) AND PLACE
    +
    1711C IN TERTIARY TABLE B REF VAL POSITION,
    +
    1712C SET FLAG IN SECONDARY REFVAL POSITION
    +
    1713C THOSE DESCRIPTORS DO NOT HAVE DATA
    +
    1714C ASSOCIATED WITH THEM, BUT ONLY
    +
    1715C IDENTIFY THE TABLE B ENTRIES THAT
    +
    1716C ARE GETTING NEW REFERENCE VALUES.
    +
    1717 kyyy = ly
    +
    1718 IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
    +
    1719C START CYCLING THRU DESCRIPTORS UNTIL
    +
    1720C TERMINATE NEW REF VALS IS FOUND
    +
    1721 300 CONTINUE
    +
    1722 CALL fi6708 (iptr,iwork,lf,lx,ly,jdesc)
    +
    1723 IF (jdesc.EQ.33791) THEN
    +
    1724C IF 2 03 255 THEN RETURN
    +
    1725 RETURN
    +
    1726 ELSE
    +
    1727C FIND MATCHING TABLE B ENTRY
    +
    1728 DO 500 lj = 1, iptr(14)
    +
    1729 IF (jdesc.EQ.kdesc(lj)) THEN
    +
    1730C TURN ON NEW REF VAL FLAG
    +
    1731 mref(lj,2) = 1
    +
    1732C INSERT NEW REF VAL
    +
    1733 CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
    +
    1734C GO GET NEXT DESCRIPTOR
    +
    1735 GO TO 300
    +
    1736 END IF
    +
    1737 500 CONTINUE
    +
    1738C 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
    +
    1743C MUST TURN OFF ALL NEW
    +
    1744C REFERENCE VALUES
    +
    1745 DO 400 i = 1, iptr(14)
    +
    1746 mref(i,2) = 0
    +
    1747 400 CONTINUE
    +
    1748 END IF
    +
    1749C LX = 3
    +
    1750C MUST BE CONCLUDED WITH Y=255
    +
    1751 ELSE IF (lx.EQ.4) THEN
    +
    1752C ASSOCIATED VALUES
    +
    1753 IF (ly.EQ.0) THEN
    +
    1754 iptr(29) = 0
    +
    1755C 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
    +
    1762C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
    +
    1763 END IF
    +
    1764 ELSE IF (lx.EQ.5) THEN
    +
    1765C PROCESS TEXT DATA
    +
    1766 iptr(40) = ly
    +
    1767 iptr(18) = 1
    +
    1768 IF (ident(16).EQ.0) THEN
    +
    1769C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE'
    +
    1770 CALL fi6704(iptr,msga,kdata,ivals,mstack,
    +
    1771 * mwidth,mref,mscale,j,ll,jdesc)
    +
    1772 ELSE
    +
    1773C 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
    +
    1782C SKIP NEXT DESCRIPTOR
    +
    1783C SET TO PASS OVER DESCRIPTOR AND DATA
    +
    1784C IF DESCRIPTOR NOT IN TABLE B
    +
    1785 iptr(36) = ly
    +
    1786C 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
    +
    1797C> @brief Substitute descriptor queue for queue descriptor
    +
    1798C> @author Bill Cavanaugh @date 1988-09-01
    +
    1799
    +
    1800C> Substitute descriptor queue for queue descriptor
    +
    1801C>
    +
    1802C> Program history log:
    +
    1803C> - Bill Cavanaugh 1988-09-01
    +
    1804C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
    +
    1805C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
    +
    1806C> based on tests with live data.
    +
    1807C>
    +
    1808C> @param[in] IWORK Working descriptor list.
    +
    1809C> @param[in] IPTR See w3fi67 routine docblock.
    +
    1810C> @param[in] ITBLD Array containing descriptor queues.
    +
    1811C> @param[in] JDESC Queue descriptor to be expanded.
    +
    1812C>
    +
    1813C> @author Bill Cavanaugh @date 1988-09-01
    +
    +
    1814 SUBROUTINE fi6707(IPTR,IWORK,ITBLD,JDESC)
    +
    1815
    +
    1816 SAVE
    +
    1817C
    +
    1818 INTEGER IPTR(*),JDESC
    +
    1819 INTEGER IWORK(*),IHOLD(1600)
    +
    1820 INTEGER ITBLD(500,11)
    +
    1821C
    +
    1822C PRINT *,' FI6707 F3 ENTRY',IPTR(11),IPTR(12)
    +
    1823C SET FOR BINARY SEARCH IN TABLE D
    +
    1824C DO 2020 I = 1, IPTR(12)
    +
    1825C PRINT *,'ENTRY IWORK',I,IWORK(I)
    +
    1826C2020 CONTINUE
    +
    1827 jlo = 1
    +
    1828 jhi = iptr(20)
    +
    1829C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
    +
    1830 10 CONTINUE
    +
    1831 jmid = (jlo + jhi) / 2
    +
    1832C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
    +
    1833C
    +
    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
    +
    1862C HAVE TABLE D MATCH
    +
    1863C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
    +
    1864C 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)
    +
    1871C 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
    +
    1879C NOTHING MORE TO APPEND
    +
    1880C PRINT *,'NOTHING MORE TO APPEND'
    +
    1881 ELSE
    +
    1882C APPEND TRAILING IWORK TO IHOLD
    +
    1883C 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
    +
    1889C RESET IHOLD TO IWORK
    +
    1890C 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
    +
    1897C PRINT *,' FI6707 F3 EXIT ',IPTR(11),IPTR(12)
    +
    1898C DO 2000 I = 1, IPTR(12)
    +
    1899C PRINT *,'EXIT IWORK',I,IWORK(I)
    +
    1900C2000 CONTINUE
    +
    1901C RESET POINTERS
    +
    1902 iptr(11) = iptr(11) - 1
    +
    1903 RETURN
    +
    +
    1904 END
    +
    1905C> @brief Subroutine FI6708
    +
    1906C> @author Bill Cavanaugh @date 1989-01-17
    +
    1907
    +
    1908C> Program history log:
    +
    1909C> - Bill Cavanaugh 1988-09-01
    +
    1910C>
    +
    1911C> @param[inout] IPTR See w3fi67() routine docblock.
    +
    1912C> @param[in] IWORK Working descriptor list.
    +
    1913C> @param LF
    +
    1914C> @param LX
    +
    1915C> @param LY
    +
    1916C> @param[in] JDESC Queue descriptor to be expanded.
    +
    1917C>
    +
    1918C> @note List caveats, other helpful hints or information.
    +
    1919C>
    +
    1920C> @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
    +
    1925C
    +
    1926C 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
    +
    1934C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
    +
    1935 iptr(11) = iptr(11) + 1
    +
    1936 RETURN
    +
    +
    1937 END
    +
    1938C> @brief Reformat decoded profiler data to show heights instead of
    +
    1939C> height increments.
    +
    1940C> @author Bill Cavanaugh @date 1990-02-14
    +
    1941
    +
    1942C> Reformat decoded profiler data to show heights instead of
    +
    1943C> height increments.
    +
    1944C>
    +
    1945C> Program history log:
    +
    1946C> - Bill Cavanaugh 1990-02-14
    +
    1947C>
    +
    1948C> @param[in] IDENT Array contains message information extracted from
    +
    1949C> BUFR message:
    +
    1950C> - IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1)
    +
    1951C> - IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1)
    +
    1952C> - IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1)
    +
    1953C> - IDENT( 4)- (BYTE 8, SECTION 1)
    +
    1954C> - IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
    +
    1955C> - IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
    +
    1956C> - IDENT( 7)- (BYTES 11-12, SECTION 1)
    +
    1957C> - IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1)
    +
    1958C> - IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1)
    +
    1959C> - IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
    +
    1960C> - IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
    +
    1961C> - IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
    +
    1962C> - IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
    +
    1963C> - IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
    +
    1964C> - IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
    +
    1965C> - IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
    +
    1966C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    1967C> @param[in] KDATA Array containing decoded reports
    +
    1968C> @param[in] IPTR See w3fi67
    +
    1969C>
    +
    1970C> @note List caveats, other helpful hints or information.
    +
    1971C>
    +
    1972C> @author Bill Cavanaugh @date 1990-02-14
    +
    +
    1973 SUBROUTINE fi6709(IDENT,MSTACK,KDATA,IPTR)
    +
    1974
    +
    1975 SAVE
    +
    1976C ----------------------------------------------------------------
    +
    1977C
    +
    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)
    +
    1984C
    +
    1985C ----------------------------------------------------------
    +
    1986C LOOP FOR NUMBER OF SUBSETS/REPORTS
    +
    1987 DO 3000 i = 1, ident(14)
    +
    1988C INIT FOR DATA INPUT ARRAY
    +
    1989 mk = 1
    +
    1990C INIT FOR DESC OUTPUT ARRAY
    +
    1991 jk = 0
    +
    1992C LOCATION
    +
    1993 isw = 0
    +
    1994 DO 200 j = 1, 3
    +
    1995C LATITUDE
    +
    1996 IF (mstack(1,mk).EQ.1282) THEN
    +
    1997 isw = isw + 1
    +
    1998 GO TO 100
    +
    1999C LONGITUDE
    +
    2000 ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2001 isw = isw + 2
    +
    2002 GO TO 100
    +
    2003C 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
    +
    2012C SAVE DESCRIPTOR
    +
    2013 kprofl(jk) = mstack(1,mk)
    +
    2014C SAVE SCALE
    +
    2015 kprof2(jk) = mstack(2,mk)
    +
    2016C 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
    +
    2025C TIME
    +
    2026 isw = 0
    +
    2027 DO 400 j = 1, 7
    +
    2028C YEAR
    +
    2029 IF (mstack(1,mk).EQ.1025) THEN
    +
    2030 isw = isw + 1
    +
    2031 GO TO 300
    +
    2032C MONTH
    +
    2033 ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2034 isw = isw + 2
    +
    2035 GO TO 300
    +
    2036C DAY
    +
    2037 ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2038 isw = isw + 4
    +
    2039 GO TO 300
    +
    2040C HOUR
    +
    2041 ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2042 isw = isw + 8
    +
    2043 GO TO 300
    +
    2044C MINUTE
    +
    2045 ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2046 isw = isw + 16
    +
    2047 GO TO 300
    +
    2048C 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
    +
    2059C SAVE DESCRIPTOR
    +
    2060 kprofl(jk) = mstack(1,mk)
    +
    2061C SAVE SCALE
    +
    2062 kprof2(jk) = mstack(2,mk)
    +
    2063C 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
    +
    2072C SURFACE DATA
    +
    2073 krg = 0
    +
    2074 isw = 0
    +
    2075 DO 600 j = 1, 10
    +
    2076C WIND SPEED
    +
    2077 IF (mstack(1,mk).EQ.2818) THEN
    +
    2078 isw = isw + 1
    +
    2079 GO TO 500
    +
    2080C WIND DIRECTION
    +
    2081 ELSE IF (mstack(1,mk).EQ.2817) THEN
    +
    2082 isw = isw + 2
    +
    2083 GO TO 500
    +
    2084C PRESS REDUCED TO MSL
    +
    2085 ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2086 isw = isw + 4
    +
    2087 GO TO 500
    +
    2088C TEMPERATURE
    +
    2089 ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2090 isw = isw + 8
    +
    2091 GO TO 500
    +
    2092C RAINFALL RATE
    +
    2093 ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2094 isw = isw + 16
    +
    2095 GO TO 500
    +
    2096C RELATIVE HUMIDITY
    +
    2097 ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2098 isw = isw + 32
    +
    2099 GO TO 500
    +
    2100C 1ST RANGE GATE OFFSET
    +
    2101 ELSE IF (mstack(1,mk).EQ.1982.OR.
    +
    2102 * mstack(1,mk).EQ.1983) THEN
    +
    2103C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
    +
    2104C 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
    +
    2114C PRINT *,'INITIAL INCR =',INCRHT
    +
    2115 ELSE
    +
    2116 lhgt = 500 + ihgt - kdata(i,mk)
    +
    2117 isw = isw + 64
    +
    2118C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
    +
    2119 END IF
    +
    2120 END IF
    +
    2121C MODE #1
    +
    2122 ELSE IF (mstack(1,mk).EQ.8128) THEN
    +
    2123 isw = isw + 128
    +
    2124 GO TO 500
    +
    2125C 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
    +
    2132C SAVE DESCRIPTOR
    +
    2133 jk = jk + 1
    +
    2134 kprofl(jk) = mstack(1,mk)
    +
    2135C SAVE SCALE
    +
    2136 kprof2(jk) = mstack(2,mk)
    +
    2137C SAVE DATA
    +
    2138 kset2(jk) = kdata(i,mk)
    +
    2139C IF (I.EQ.1) THEN
    +
    2140C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2141C 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
    +
    2150C 43 LEVELS
    +
    2151 DO 2000 l = 1, 43
    +
    2152 2020 CONTINUE
    +
    2153 isw = 0
    +
    2154C HEIGHT INCREMENT
    +
    2155 IF (mstack(1,mk).EQ.1982) THEN
    +
    2156C 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
    +
    2165C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
    +
    2166C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
    +
    2167 lhgt = lhgt + incrht
    +
    2168C PRINT *,'LEVEL ',L,LHGT
    +
    2169 IF (l.EQ.37) THEN
    +
    2170 lhgt = lhgt + incrht
    +
    2171 END IF
    +
    2172 jk = jk + 1
    +
    2173C SAVE DESCRIPTOR
    +
    2174 kprofl(jk) = 1798
    +
    2175C SAVE SCALE
    +
    2176 kprof2(jk) = 0
    +
    2177C SAVE DATA
    +
    2178 kset2(jk) = lhgt
    +
    2179C IF (I.EQ.10) THEN
    +
    2180C PRINT *,' '
    +
    2181C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
    +
    2182C 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
    +
    2188C 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
    +
    2198C 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
    +
    2207C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
    +
    2208C DESCRIPTORS AND DATA
    +
    2209 IF (iand(isw,1).NE.0) THEN
    +
    2210 IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2211C SAVE DD DESCRIPTOR
    +
    2212 jk = jk + 1
    +
    2213 kprofl(jk) = 2817
    +
    2214C SAVE SCALE
    +
    2215 kprof2(jk) = 0
    +
    2216C SAVE DD DATA
    +
    2217 kset2(jk) = 32767
    +
    2218C SAVE FFF DESCRIPTOR
    +
    2219 jk = jk + 1
    +
    2220 kprofl(jk) = 2818
    +
    2221C SAVE SCALE
    +
    2222 kprof2(jk) = 1
    +
    2223C SAVE FFF DATA
    +
    2224 kset2(jk) = 32767
    +
    2225 ELSE
    +
    2226C GENERATE DDFFF
    +
    2227 CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2228 ndir = dir
    +
    2229 spd = spd
    +
    2230 nspd = spd
    +
    2231C PRINT *,' ',NDIR,NSPD
    +
    2232C SAVE DD DESCRIPTOR
    +
    2233 jk = jk + 1
    +
    2234 kprofl(jk) = 2817
    +
    2235C SAVE SCALE
    +
    2236 kprof2(jk) = 0
    +
    2237C SAVE DD DATA
    +
    2238 kset2(jk) = dir
    +
    2239C IF (I.EQ.1) THEN
    +
    2240C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2241C END IF
    +
    2242C SAVE FFF DESCRIPTOR
    +
    2243 jk = jk + 1
    +
    2244 kprofl(jk) = 2818
    +
    2245C SAVE SCALE
    +
    2246 kprof2(jk) = 1
    +
    2247C SAVE FFF DATA
    +
    2248 kset2(jk) = spd
    +
    2249C IF (I.EQ.1) THEN
    +
    2250C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2251C END IF
    +
    2252 END IF
    +
    2253 END IF
    +
    2254 GO TO 800
    +
    2255C W VECTOR VALUE
    +
    2256 ELSE IF (mstack(1,mk).EQ.3010) THEN
    +
    2257 isw = isw + 4
    +
    2258 GO TO 700
    +
    2259C Q/C TEST RESULTS
    +
    2260 ELSE IF (mstack(1,mk).EQ.8130) THEN
    +
    2261 isw = isw + 8
    +
    2262 GO TO 700
    +
    2263C 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
    +
    2267C 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
    +
    2271C SPECTRAL PEAK POWER
    +
    2272 ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2273 isw = isw + 64
    +
    2274 GO TO 700
    +
    2275C U,V VARIABILITY
    +
    2276 ELSE IF (mstack(1,mk).EQ.3011) THEN
    +
    2277 isw = isw + 128
    +
    2278 GO TO 700
    +
    2279C 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
    +
    2290C SAVE DESCRIPTOR
    +
    2291 kprofl(jk) = mstack(1,mk)
    +
    2292C SAVE SCALE
    +
    2293 kprof2(jk) = mstack(2,mk)
    +
    2294C SAVE DATA
    +
    2295 kset2(jk) = kdata(i,mk)
    +
    2296 mk = mk + 1
    +
    2297C IF (I.EQ.1) THEN
    +
    2298C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2299C 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
    +
    2308C MOVE DATA BACK INTO KDATA ARRAY
    +
    2309 DO 4000 ll = 1, jk
    +
    2310 kdata(i,ll) = kset2(ll)
    +
    2311 4000 CONTINUE
    +
    2312 3000 CONTINUE
    +
    2313C PRINT *,'REBUILT ARRAY'
    +
    2314 DO 5000 ll = 1, jk
    +
    2315C DESCRIPTOR
    +
    2316 mstack(1,ll) = kprofl(ll)
    +
    2317C SCALE
    +
    2318 mstack(2,ll) = kprof2(ll)
    +
    2319C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
    +
    2320 5000 CONTINUE
    +
    2321C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
    +
    2322 iptr(31) = jk
    +
    2323 RETURN
    +
    +
    2324 END
    +
    2325C> @brief Reformat profiler edition 2 data
    +
    2326C> @author Bill Cavanaugh @date 1993-01-27
    +
    2327
    +
    2328C> Reformat profiler data in edition 2
    +
    2329C>
    +
    2330C> Program history log:
    +
    2331C> - Bill Cavanaugh 1993-01-27
    +
    2332C>
    +
    2333C> @param[in] IDENT Array contains message information extracted from
    +
    2334C> BUFR message:
    +
    2335C> - IDENT( 1)-Edition number (byte 4, section 1)
    +
    2336C> - IDENT( 2)-Originating center (bytes 5-6, section 1)
    +
    2337C> - IDENT( 3)-Update sequence (byte 7, section 1)
    +
    2338C> - IDENT( 4)- (byte 8, section 1)
    +
    2339C> - IDENT( 5)-BUFR message type (byte 9, section 1)
    +
    2340C> - IDENT( 6)-BUFR msg sub-type (byte 10, section 1)
    +
    2341C> - IDENT( 7)- (bytes 11-12, section 1)
    +
    2342C> - IDENT( 8)-Year of century (byte 13, section 1)
    +
    2343C> - IDENT( 9)-Month of year (byte 14, section 1)
    +
    2344C> - IDENT(10)-Day of month (byte 15, section 1)
    +
    2345C> - IDENT(11)-Hour of day (byte 16, section 1)
    +
    2346C> - IDENT(12)-Minute of hour (byte 17, section 1)
    +
    2347C> - IDENT(13)-Rsvd by adp centers(byte 18, section 1)
    +
    2348C> - IDENT(14)-Nr of data subsets (byte 5-6, section 3)
    +
    2349C> - IDENT(15)-Observed flag (byte 7, bit 1, section 3)
    +
    2350C> - IDENT(16)-Compression flag (byte 7, bit 2, section 3)
    +
    2351C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2352C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2353C> kdata(report number,parameter number)
    +
    2354C> (report number limited to value of input argument
    +
    2355C> maxr and parameter number limited to value of input
    +
    2356C> argument maxd)
    +
    2357C> @param[in] IPTR See w3fi67
    +
    2358C>
    +
    2359C> @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)
    +
    2368C 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
    +
    2375C BLOCK NUMBER
    +
    2376 isw = isw + 1
    +
    2377 ELSE IF (mstack(1,mk).EQ.258) THEN
    +
    2378C STATION NUMBER
    +
    2379 isw = isw + 2
    +
    2380 ELSE IF (mstack(1,mk).EQ.1282) THEN
    +
    2381C LATITUDE
    +
    2382 isw = isw + 4
    +
    2383 ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2384C LONGITUDE
    +
    2385 isw = isw + 8
    +
    2386 ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2387C 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)
    +
    2398C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2399 mk = mk + 1
    +
    2400 200 CONTINUE
    +
    2401C PRINT *,'LOCATION ',ISW
    +
    2402 IF (isw.NE.31) THEN
    +
    2403 print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2404 iptr(10) = 200
    +
    2405 RETURN
    +
    2406 END IF
    +
    2407C PROCESS TIME ELEMENTS
    +
    2408 isw = 0
    +
    2409 DO 400 j = 1, 7
    +
    2410 IF (mstack(1,mk).EQ.1025) THEN
    +
    2411C YEAR
    +
    2412 isw = isw + 1
    +
    2413 ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2414C MONTH
    +
    2415 isw = isw + 2
    +
    2416 ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2417C DAY
    +
    2418 isw = isw + 4
    +
    2419 ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2420C HOUR
    +
    2421 isw = isw + 8
    +
    2422 ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2423C MINUTE
    +
    2424 isw = isw + 16
    +
    2425 ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2426C TIME SIGNIFICANCE
    +
    2427 isw = isw + 32
    +
    2428 ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2429C 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)
    +
    2439C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2440 mk = mk + 1
    +
    2441 400 CONTINUE
    +
    2442C PRINT *,'TIME ',ISW
    +
    2443 IF (isw.NE.127) THEN
    +
    2444 print *,'TIME ERROR PROCESSING PROFILER'
    +
    2445 iptr(1) = 201
    +
    2446 RETURN
    +
    2447 END IF
    +
    2448C SURFACE DATA
    +
    2449 isw = 0
    +
    2450C 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
    +
    2467C 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)
    +
    2480C 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
    +
    2493C MUST SAVE THIS HEIGHT VALUE
    +
    2494 lhgt = 500 + ihgt - kdata(i,mk)
    +
    2495C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
    +
    2496 mk = mk + 1
    +
    2497C PROCESS LEVEL DATA
    +
    2498 DO 2000 l = 1, 43
    +
    2499 2020 CONTINUE
    +
    2500 isw = 0
    +
    2501C HEIGHT INCREMENT
    +
    2502 IF (mstack(1,mk).EQ.1797) THEN
    +
    2503 incrht = kdata(i,mk)
    +
    2504C 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
    +
    2512C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
    +
    2513C AT THIS POINT
    +
    2514 lhgt = lhgt + incrht
    +
    2515C PRINT *,'LEVEL ',L,LHGT
    +
    2516 IF (l.EQ.37) THEN
    +
    2517 lhgt = lhgt + incrht
    +
    2518 END IF
    +
    2519 jk = jk + 1
    +
    2520C SAVE DESCRIPTOR
    +
    2521 kprofl(jk) = 1798
    +
    2522C SAVE SCALE
    +
    2523 kprof2(jk) = 0
    +
    2524C SAVE DATA
    +
    2525 kset2(jk) = lhgt
    +
    2526C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2527 isw = 0
    +
    2528 icon = 1
    +
    2529 DO 800 j = 1, 10
    +
    2530750 CONTINUE
    +
    2531 IF (mstack(1,mk).EQ.1797) THEN
    +
    2532 GO TO 2020
    +
    2533 ELSE IF (mstack(1,mk).EQ.6432) THEN
    +
    2534C HI/LO MODE
    +
    2535 isw = isw + 1
    +
    2536 ELSE IF (mstack(1,mk).EQ.6434) THEN
    +
    2537C Q/C TEST
    +
    2538 isw = isw + 2
    +
    2539 ELSE IF (mstack(1,mk).EQ.2070) THEN
    +
    2540 IF (icon.EQ.1) THEN
    +
    2541C FIRST PASS - U,V CONSENSUS
    +
    2542 isw = isw + 4
    +
    2543 icon = icon + 1
    +
    2544 ELSE
    +
    2545C SECOND PASS - W CONSENSUS
    +
    2546 isw = isw + 64
    +
    2547 END IF
    +
    2548 ELSE IF (mstack(1,mk).EQ.2819) THEN
    +
    2549C 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
    +
    2559C 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
    +
    2568C SAVE DD DESCRIPTOR
    +
    2569 jk = jk + 1
    +
    2570 kprofl(jk) = 2817
    +
    2571 kprof2(jk) = 0
    +
    2572 kset2(jk) = 32767
    +
    2573C 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
    +
    2583C PRINT *,' ',NDIR,NSPD
    +
    2584C SAVE DD DESCRIPTOR
    +
    2585 jk = jk + 1
    +
    2586 kprofl(jk) = 2817
    +
    2587 kprof2(jk) = 0
    +
    2588 kset2(jk) = ndir
    +
    2589C IF (I.EQ.1) THEN
    +
    2590C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2591C ENDIF
    +
    2592C SAVE FFF DESCRIPTOR
    +
    2593 jk = jk + 1
    +
    2594 kprofl(jk) = 2818
    +
    2595 kprof2(jk) = 1
    +
    2596 kset2(jk) = nspd
    +
    2597C IF (I.EQ.1) THEN
    +
    2598C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2599C ENDIF
    +
    2600 END IF
    +
    2601 mk = mk + 1
    +
    2602 GO TO 800
    +
    2603 END IF
    +
    2604 ELSE IF (mstack(1,mk).EQ.2866) THEN
    +
    2605C SPEED STD DEVIATION
    +
    2606 isw = isw + 32
    +
    2607C -- A CHANGE BY KEYSER : POWER DESC. BACK TO 5568
    +
    2608 ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2609C SIGNAL POWER
    +
    2610 isw = isw + 128
    +
    2611 ELSE IF (mstack(1,mk).EQ.2822) THEN
    +
    2612C W COMPONENT
    +
    2613 isw = isw + 256
    +
    2614 ELSE IF (mstack(1,mk).EQ.2867) THEN
    +
    2615C VERT STD DEVIATION
    +
    2616 isw = isw + 512
    +
    2617 ELSE
    +
    2618 mk = mk + 1
    +
    2619 GO TO 750
    +
    2620 END IF
    +
    2621 jk = jk + 1
    +
    2622C SAVE DESCRIPTOR
    +
    2623 kprofl(jk) = mstack(1,mk)
    +
    2624C SAVE SCALE
    +
    2625 kprof2(jk) = mstack(2,mk)
    +
    2626C SAVE DATA
    +
    2627 kset2(jk) = kdata(i,mk)
    +
    2628 mk = mk + 1
    +
    2629C 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
    +
    2642C MOVE DATA BACK INTO KDATA ARRAY
    +
    2643 DO 5000 ll = 1, jk
    +
    2644C DESCRIPTOR
    +
    2645 mstack(1,ll) = kprofl(ll)
    +
    2646C SCALE
    +
    2647 mstack(2,ll) = kprof2(ll)
    +
    2648C DATA
    +
    2649C 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
    +
    gbyte
    subroutine gbyte(ipackd, iunpkd, noff, nbits)
    This is the fortran version of gbyte.
    Definition gbyte.f:27
    +
    gbytes
    subroutine gbytes(ipackd, iunpkd, noff, nbits, iskip, iter)
    Program history log:
    Definition gbytes.f:26
    +
    w3ai39
    subroutine w3ai39(nfld, n)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition w3ai39.f:26
    +
    w3fc05
    subroutine w3fc05(u, v, dir, spd)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition w3fc05.f:29
    +
    fi6709
    subroutine fi6709(ident, mstack, kdata, iptr)
    Reformat decoded profiler data to show heights instead of height increments.
    Definition w3fi67.f:1974
    +
    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
    +
    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
    +
    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
    +
    fi6710
    subroutine fi6710(ident, mstack, kdata, iptr)
    Reformat profiler edition 2 data.
    Definition w3fi67.f:2361
    +
    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
    +
    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
    +
    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
    +
    fi6702
    subroutine fi6702(iptr, ident, msga, kdata, kdesc, ll, mstack, aunits, mwidth, mref, mscale, jdesc, ivals, j)
    Process standard descriptor.
    Definition w3fi67.f:942
    diff --git a/w3fi68_8f.html b/w3fi68_8f.html index 7c6f2081..22b16b4a 100644 --- a/w3fi68_8f.html +++ b/w3fi68_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi68.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi68.f File Reference
    +
    w3fi68.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Convert 25 word array to GRIB pds.

    @@ -107,8 +113,8 @@

    Definition in file w3fi68.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi68()

    + +

    ◆ w3fi68()

    @@ -117,13 +123,13 @@

    subroutine w3fi68 ( integer, dimension(*)  - ID, + id, character * 1, dimension(*)  - PDS  + pds  @@ -224,7 +230,7 @@

    diff --git a/w3fi68_8f.js b/w3fi68_8f.js index b7fd956a..67eb077c 100644 --- a/w3fi68_8f.js +++ b/w3fi68_8f.js @@ -1,4 +1,4 @@ var w3fi68_8f = [ - [ "w3fi68", "w3fi68_8f.html#a627b0d3ff494874dd3fb243e39cfa991", null ] + [ "w3fi68", "w3fi68_8f.html#a2f103e1d1423a0f9585dbf5633758020", null ] ]; \ No newline at end of file diff --git a/w3fi68_8f_source.html b/w3fi68_8f_source.html index 9c94e2d5..abb6ee73 100644 --- a/w3fi68_8f_source.html +++ b/w3fi68_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi68.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,196 +81,204 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi68.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert 25 word array to GRIB pds.
    +
    3C> @author Ralph Jones @date 1991-05-08
    +
    4
    +
    5C> Converts an array of 25, or 27 integer words into a
    +
    6C> grib product definition section (pds) of 28 bytes , or 30 bytes.
    +
    7C> if pds bytes > 30, they are set to zero.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Ralph Jones 1991-05-08
    +
    11C> - Ralph Jones 1992-09-25 Change to 25 words of input, level
    +
    12C> can be in two words. (10,11)
    +
    13C> - Ralph Jones 1993-01-08 Change for time range indicator if 10,
    +
    14C> store time p1 in pds bytes 19-20.
    +
    15C> - Ralph Jones 1993-01-26 Correction for fixed height above
    +
    16C> ground level
    +
    17C> - Ralph Jones 1993-03-29 Add save statement
    +
    18C> - Bill Cavanaugh 1993-06-24 Modified program to allow for generation
    +
    19C> of pds greater than 28 bytes (the desired
    +
    20C> pds size is in id(1).
    +
    21C> - Farley 1993-09-30 Change to allow for subcenter id; put
    +
    22C> id(24) into pds(26).
    +
    23C> - Ralph Jones 1993-10-12 Changes for on388 rev. oct 9,1993, new
    +
    24C> levels 125, 200, 201.
    +
    25C> - Ralph Jones 1994-02-23 Take out sbytes, replace with do loop
    +
    26C> - Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new
    +
    27C> levels 115,116.
    +
    28C> - Ralph Jones 1994-12-04 Change to add id words 26, 27 for pds
    +
    29C> bytes 29 and 30.
    +
    30C> - Ralph Jones 1995-09-07 Change for new level 117, 119.
    +
    31C> - Mark Iredell 1995-10-31 REmoved saves and prints
    +
    32C> - Ebisuzaki 1998-06-30 Linux port
    +
    33C> - Stephen Gilbert 2001-06-05 Changed fortran intrinsic function OR() to
    +
    34C> f90 standard intrinsic IOR().
    +
    35C> - Mark Iredell 2003-02-25 Recognize level type 126
    +
    36C> - D. C. Stokes 2005-05-06 Recognize level types 235, 237, 238
    +
    37C>
    +
    38C> @param[in] ID 25,27 word integer array.
    +
    39C> @param[out] PDS 28 30 or greater character pds for edition 1.
    +
    40C>
    +
    41C> @note Layout of 'id' array:
    +
    42C> - ID(1) = Number of bytes in product definition section (pds)
    +
    43C> - ID(2) = Parameter table version number
    +
    44C> - ID(3) = Identification of originating center
    +
    45C> - ID(4) = Model identification (allocated by originating center)
    +
    46C> - ID(5) = Grid identification
    +
    47C> - ID(6) = 0 if no gds section, 1 if gds section is included
    +
    48C> - ID(7) = 0 if no bms section, 1 if bms section is included
    +
    49C> - ID(8) = Indicator of parameter and units (table 2)
    +
    50C> - ID(9) = Indicator of type of level (table 3)
    +
    51C> - ID(10) = Value 1 of level (0 for 1-100,102,103,105,107
    +
    52C> 109,111,113,115,117,119,125,126,160,200,201,235,237,238
    +
    53C> level is in id word 11)
    +
    54C> - ID(11) = Value 2 of level
    +
    55C> - ID(12) = Year of century
    +
    56C> - ID(13) = Month of year
    +
    57C> - ID(14) = Day of month
    +
    58C> - ID(15) = Hour of day
    +
    59C> - ID(16) = Minute of hour (in most cases set to 0)
    +
    60C> - ID(17) = Fcst time unit
    +
    61C> - ID(18) = P1 period of time
    +
    62C> - ID(19) = P2 period of time
    +
    63C> - ID(20) = Time range indicator
    +
    64C> - ID(21) = Number included in average
    +
    65C> - ID(22) = Number missing from averages
    +
    66C> - ID(23) = Century (20, change to 21 on jan. 1, 2001)
    +
    67C> - ID(24) = Subcenter identification
    +
    68C> - ID(25) = Scaling power of 10
    +
    69C> - ID(26) = Flag byte, 8 on/off flags
    +
    70C> |BIT NUMBER |VALUE |ID(26) | DEFINITION|
    +
    71C> | :--------- | :--- | :--- | : ----------- |
    +
    72C> |1 |0 |0 |FULL FCST FIELD|
    +
    73C> | |1 |128 |FCST ERROR FIELD|
    +
    74C> |2 |0 |0 |ORIGINAL FCST FIELD|
    +
    75C> | |1 |64 |BIAS CORRECTED FCST FIELD|
    +
    76C> |3 |0 |0 |ORIGINAL RESOLUTION RETAINED|
    +
    77C> | |1 |32 |SMOOTHED FIELD|
    +
    78C> @note ID(26) can be the sum of bits 1, 2, 3.
    +
    79C> bits 4-8 not used, set to zero
    +
    80C> if ID(1) is 28, you do not need ID(26) and ID(27).
    +
    81C> - ID(27) = unused, set to 0 so pds byte 30 is set to zero.
    +
    82C>
    +
    83C> @author Ralph Jones @date 1991-05-08
    +
    +
    84 SUBROUTINE w3fi68 (ID, PDS)
    +
    85C
    +
    86 INTEGER ID(*)
    +
    87C
    +
    88 CHARACTER * 1 PDS(*)
    +
    89C
    +
    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)
    +
    105C
    +
    106C TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO
    +
    107C WORDS OR ONE
    +
    108C
    +
    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))
    +
    133C
    +
    134C TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10
    +
    135C IF SO PUT TIME P1 IN PDS BYTES 19-20.
    +
    136C
    +
    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
    +
    161C
    +
    162C SET PDS 31-?? TO ZERO
    +
    163C
    +
    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
    +
    170C
    +
    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/w3fi69_8f.html b/w3fi69_8f.html index ed2a9380..7ecbe3a0 100644 --- a/w3fi69_8f.html +++ b/w3fi69_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi69.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi69.f File Reference
    +
    w3fi69.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi69 (pds, id)
     Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array.
     

    Detailed Description

    Convert pds to 25, or 27 word array.

    @@ -107,8 +113,8 @@

    Definition in file w3fi69.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi69()

    + +

    ◆ w3fi69()

    @@ -117,13 +123,13 @@

    subroutine w3fi69 ( character * 1, dimension(*)  - PDS, + pds, integer, dimension(*)  - ID  + id  @@ -166,7 +172,7 @@

    diff --git a/w3fi69_8f.js b/w3fi69_8f.js index 3f8f0cc2..0a7f5cc7 100644 --- a/w3fi69_8f.js +++ b/w3fi69_8f.js @@ -1,4 +1,4 @@ var w3fi69_8f = [ - [ "w3fi69", "w3fi69_8f.html#a725f7f35c86515ca113aa3a36ac133e0", null ] + [ "w3fi69", "w3fi69_8f.html#adcd583a43ddb3397dc354375ca5e5029", null ] ]; \ No newline at end of file diff --git a/w3fi69_8f_source.html b/w3fi69_8f_source.html index ca4dbb75..9998eb72 100644 --- a/w3fi69_8f_source.html +++ b/w3fi69_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi69.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,163 +81,171 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi69.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert pds to 25, or 27 word array.
    +
    3C> @author Ralph Jones @date 1991-05-14
    +
    4
    +
    5C> Converts an edition 1 grib produce definition section (pds)
    +
    6C> to a 25, or 27 word integer array.
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - Ralph Jones 1991-05-14
    +
    10C> - Ralph Jones 1992-09-25 Change level to use one or two words
    +
    11C> - Ralph Jones 1993-01-08 Change for time range indicator if 10
    +
    12C> - Ralph Jones 1993-03-29 Add save statement
    +
    13C> - Ralph Jones 1993-10-21 Changes for on388 rev. oct 9,1993, new
    +
    14C> levels 125, 200, 201.
    +
    15C> - Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new
    +
    16C> levels 115, 116.
    +
    17C> - Ralph Jones 1994-12-04 Changes for 27 word integer array if
    +
    18C> pds is greater than 28 bytes.
    +
    19C> - Ralph Jones 1995-09-07 Changes for level 117, 119.
    +
    20C> - Stephen Gilbert 1998-12-21 Replaced Function ICHAR with mova2i.
    +
    21C>
    +
    22C> @param[in] PDS 28 to 100 character product definition section (pds) .
    +
    23C> @param[out] ID 25, or 27 word integer array.
    +
    24C>
    +
    25C> @note List caveats, other helpful hints or information.
    +
    26C>
    +
    27C> @author Ralph Jones @date 1991-05-14
    +
    +
    28 SUBROUTINE w3fi69 (PDS, ID)
    +
    29C
    +
    30 INTEGER ID(*)
    +
    31C
    +
    32 CHARACTER * 1 PDS(*)
    +
    33C
    +
    34 SAVE
    +
    35C
    +
    36C ID(1) = NUMBER OF BYTES IN PDS
    +
    37C ID(2) = PARAMETER TABLE VERSION NUMBER
    +
    38C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
    +
    39C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
    +
    40C ID(5) = GRID IDENTIFICATION
    +
    41C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
    +
    42C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
    +
    43C ID(8) = INDICATOR OF PARAMETER AND UNITS
    +
    44C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER
    +
    45C ID(10) = LEVEL 1
    +
    46C ID(11) = LEVEL 2
    +
    47C ID(12) = YEAR OF CENTURY
    +
    48C ID(13) = MONTH OF YEAR
    +
    49C ID(14) = DAY OF MONTH
    +
    50C ID(15) = HOUR OF DAY
    +
    51C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
    +
    52C ID(17) = FCST TIME UNIT
    +
    53C ID(18) = P1 PERIOD OF TIME
    +
    54C ID(19) = P2 PERIOD OF TIME
    +
    55C ID(20) = TIME RANGE INDICATOR
    +
    56C ID(21) = NUMBER INCLUDED IN AVERAGE
    +
    57C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS
    +
    58C ID(23) = CENTURY
    +
    59C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2)
    +
    60C ID(25) = SCALING POWER OF 10
    +
    61C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS
    +
    62C BIT NUMBER VALUE ID(26) DEFINITION
    +
    63C 1 0 0 FULL FCST FIELD
    +
    64C 1 128 FCST ERROR FIELD
    +
    65C 2 0 0 ORIGINAL FCST FIELD
    +
    66C 1 64 BIAS CORRECTED FCST FIELD
    +
    67C 3 0 0 ORIGINAL RESOLUTION RETAINED
    +
    68C 1 32 SMOOTHED FIELD
    +
    69C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3.
    +
    70C BITS 4-8 NOT USED, SET TO ZERO.
    +
    71C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27).
    +
    72C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO.$
    +
    73C
    +
    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))
    +
    85C
    +
    86C TEST ID(9) FOR 1-100, 102,103, 105, 107, 109,
    +
    87C 111,113,115,117,119,160,200,201, IF TRUE, SET ID(10) TO 0,
    +
    88C AND STORE 16 BIT VALUE (BYTES 11 & 12) THE LEVEL IN ID(11).
    +
    89C
    +
    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))
    +
    115C
    +
    116C IF TIME RANGE IDICATOR IS 10, P1 IS PACKED INTO
    +
    117C PDS BYTES 19-20. PUT THEM IN P1 AND SET P2 TO ZERO.
    +
    118C
    +
    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
    +
    136C
    +
    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/w3fi70_8f.html b/w3fi70_8f.html index d9c3cecb..827822b3 100644 --- a/w3fi70_8f.html +++ b/w3fi70_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi70.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi70.f File Reference
    +
    w3fi70.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Computes scaling constants used by grdprt().

    @@ -107,8 +113,8 @@

    Definition in file w3fi70.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi70()

    + +

    ◆ w3fi70()

    @@ -117,19 +123,19 @@

    subroutine w3fi70 ( character * 1, dimension(28)  - PDS, + pds, real, dimension(4)  - CNST, + cnst,   - IER  + ier  @@ -149,7 +155,7 @@

    Parameters
    - +
    [in]PDS28 byte (pds) grib product definition section.
    [out]CNST4 constant's used by grdprt(), w3fp05(), or w3fp03().
    [out]CNST4 constant's used by grdprt(), w3fp05(), or w3fp03().
    [out]IER0 = normal return | 1 = .
    @@ -167,7 +173,7 @@

    diff --git a/w3fi70_8f.js b/w3fi70_8f.js index 3a46fd4d..c79aed43 100644 --- a/w3fi70_8f.js +++ b/w3fi70_8f.js @@ -1,4 +1,4 @@ var w3fi70_8f = [ - [ "w3fi70", "w3fi70_8f.html#a15c47f82fe6330c213820e90fbe63a92", null ] + [ "w3fi70", "w3fi70_8f.html#a804adf2c4205b93098ecb914e5a138ba", null ] ]; \ No newline at end of file diff --git a/w3fi70_8f_source.html b/w3fi70_8f_source.html index 763890cb..e5c14f46 100644 --- a/w3fi70_8f_source.html +++ b/w3fi70_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi70.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,859 +81,867 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi70.f
    +
    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
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes scaling constants used by grdprt().
    +
    3C> @author Ralph Jones @date 1991-10-26
    +
    4C
    +
    5C> Computes the four scaling constants used by grdprt, w3fp03,
    +
    6C> or w3fp05 from the 28 byte (pds) product definition section of
    +
    7C> grib edition one.
    +
    8C>
    +
    9C> Program history log:
    +
    10C> - Ralph Jones 1991-10-26
    +
    11C> - Ralph Jones 1993-03-29 Add save statement
    +
    12C> - Ralph Jones 1993-08-08 Add 156 (cin), 158 (tke) to tables
    +
    13C> - Ralph Jones 1993-10-16 Changes for o.n. 388 ver. oct. 8,1993
    +
    14C>
    +
    15C> @param[in] PDS 28 byte (pds) grib product definition section.
    +
    16C> @param[out] CNST 4 constant's used by grdprt(), w3fp05(), or w3fp03().
    +
    17C> @param[out] IER 0 = normal return | 1 = .
    +
    18C>
    +
    19C> @author Ralph Jones @date 1991-10-26
    +
    +
    20 SUBROUTINE w3fi70(PDS,CNST,IER)
    +
    21C
    +
    22C SET DEFAULT VALUES FOR NMC FIELDS GRID PRINTING
    +
    23C
    +
    24 REAL CNST(4)
    +
    25C
    +
    26 INTEGER ID(25)
    +
    27 INTEGER Q
    +
    28C
    +
    29 CHARACTER * 1 PDS(28)
    +
    30C
    +
    31 SAVE
    +
    32C
    +
    33C UNPACK 28 BYTE (PDS) INTO 25 INTEGER WORDS
    +
    34C
    +
    35 CALL w3fi69(pds,id)
    +
    36C
    +
    37 ier = 0
    +
    38C
    +
    39C INDICATOR OF PARAMETER AND UNITS
    +
    40C
    +
    41 q = id(8)
    +
    42C
    +
    43C INDICATOR OF LEVEL OR LAYERS
    +
    44C
    +
    45 itypes = id(9)
    +
    46 i9 = id(9)
    +
    47C
    +
    48C HEIGHTS, PRESSURE, ETC. OF THE LEVEL OR LAYER
    +
    49C
    +
    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
    +
    61C
    +
    62C*** PRESSURE, PRESSURE REDUCED TO MSL, PRESSURE ANOMALY (Pa)
    +
    63C
    +
    64 cnst(1) = 0.0
    +
    65 cnst(2) = 0.01
    +
    66 cnst(3) = 4.0
    +
    67 cnst(4) = 0.0
    +
    68C*** 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
    +
    71C
    +
    72 ELSE IF (q.EQ.3) THEN
    +
    73C
    +
    74C*** PRESSURE TENDENCY (Pa/s)
    +
    75C
    +
    76 cnst(1) = 0.0
    +
    77 cnst(2) = 1.0
    +
    78 cnst(3) = 4.0
    +
    79 cnst(4) = 0.0
    +
    80C
    +
    81 ELSE IF (q.EQ.6) THEN
    +
    82C
    +
    83C*** GEOPOTENTIAL (m**2/s**2)
    +
    84C
    +
    85 cnst(1) = 0.0
    +
    86 cnst(2) = 1.0
    +
    87 cnst(3) = 4.0
    +
    88 cnst(4) = 0.0
    +
    89C
    +
    90 ELSE IF (q.EQ.7.OR.q.EQ.8.OR.q.EQ.27.OR.q.EQ.222) THEN
    +
    91C
    +
    92C*** GEOPOTENTIAL, GEOPOTENTIAL HEIGHT, ANOMALY
    +
    93C*** 5-WAVE GEOPOTENTIAL HEIGHT ............
    +
    94C
    +
    95 cnst(3) = 60.
    +
    96 IF (ilvl.LT.500) cnst(3) = 120.
    +
    97C*** 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
    +
    105C
    +
    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
    +
    109C
    +
    110
    +
    111C*** TEMPERATURES (deg. K)
    +
    112C*** VIRTUAL TEMPERATURE (deg. K)
    +
    113C*** POTENTIAL TEMPERATURE (deg. K)
    +
    114C*** PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (deg. K)
    +
    115C*** MAXIMUN TEMPERATURE (deg. K)
    +
    116C*** MINUMUN TEMPERATURE (deg. K)
    +
    117C*** DEW POINT TEMPERATURE (deg. K)
    +
    118C*** DEW POINT DEPRESSION (OR DEFICIT) (deg. K)
    +
    119C
    +
    120C*** TEMP (DEG K) CONVERT TO DEG C, EXCEPT POTENTIAL TEMPERATURE
    +
    121C
    +
    122C 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
    +
    128C
    +
    129 ELSE IF (q.EQ.19) THEN
    +
    130C
    +
    131C*** LAPSE RATE, deg. K/m ...............
    +
    132C
    +
    133 cnst(1) = 0.0
    +
    134 cnst(2) = 1.0
    +
    135 cnst(3) = 4.0
    +
    136 cnst(4) = 0.0
    +
    137C
    +
    138 ELSE IF (q.EQ.21.OR.q.EQ.22.OR.q.EQ.23) THEN
    +
    139C
    +
    140C*** RADAR SPECTRA (1), (2), (3) ...............
    +
    141C
    +
    142 cnst(1) = 0.0
    +
    143 cnst(2) = 1.0
    +
    144 cnst(3) = 10.0
    +
    145 cnst(4) = 0.0
    +
    146C
    +
    147 ELSE IF (q.EQ.28.OR.q.EQ.29.OR.q.EQ.30) THEN
    +
    148C
    +
    149C*** WAVE SPECTRA (1), (2), (3) ...............
    +
    150C
    +
    151 cnst(1) = 0.0
    +
    152 cnst(2) = 1.0
    +
    153 cnst(3) = 10.0
    +
    154 cnst(4) = 0.0
    +
    155C
    +
    156 ELSE IF (q.EQ.31) THEN
    +
    157C
    +
    158C*** WIND DIRECTION (deg. true)
    +
    159C
    +
    160 cnst(1) = 0.0
    +
    161 cnst(2) = 1.0
    +
    162 cnst(3) = 10.0
    +
    163 cnst(4) = 0.0
    +
    164C
    +
    165 ELSE IF (q.EQ.32.OR.q.EQ.33.OR.q.EQ.34) THEN
    +
    166C
    +
    167C*** WIND SPEED, U-COMPONENT OF WIND,
    +
    168C*** V-COMPONENT OF WIND m/s -------------------
    +
    169C
    +
    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
    +
    176C
    +
    177 ELSE IF (q.EQ.35.OR.q.EQ.36) THEN
    +
    178C
    +
    179C*** STREAM FUNCTION, VELOCITY POTENTIAL (m**2/s)
    +
    180C*** STREAM FUNCTION OR VELOCITY POTENTIAL (m**2/s) CONVERTED TO M.
    +
    181C*** CONVERT TO METERS. (M*M/SEC * FOG)
    +
    182C
    +
    183 cnst(1) = 0.
    +
    184 cnst(2) = 1.03125e-4 / 9.8
    +
    185 cnst(3) = 60.
    +
    186 cnst(4) = 0.
    +
    187C
    +
    188 ELSE IF (q.EQ.37) THEN
    +
    189C
    +
    190C*** MONTGOMERY STREAM FUNCTION (m**2/s**2)
    +
    191C
    +
    192 cnst(1) = 0.0
    +
    193 cnst(2) = 1.0
    +
    194 cnst(3) = 2.0
    +
    195 cnst(4) = 0.0
    +
    196C
    +
    197 ELSE IF (q.EQ.38) THEN
    +
    198C
    +
    199C*** SIGMA COORD. VERTICAL VELOCITY (/s) TO MICROBARS/SEC
    +
    200C
    +
    201 cnst(1) = 0.0
    +
    202 cnst(2) = 1.0
    +
    203 cnst(3) = 2.0
    +
    204 cnst(4) = 0.0
    +
    205C
    +
    206 ELSE IF (q.EQ.39) THEN
    +
    207C
    +
    208C*** VERTICAL VELOCITY (Pa/s) TO MICROBARS/SEC
    +
    209C*** SIGN CHANGED SUCH THAT POSITIVE VALUES INDICATE UPWARD MOTION.
    +
    210C
    +
    211 cnst(1) = 0.0
    +
    212 cnst(2) = -1.e1
    +
    213 cnst(3) = 2.0
    +
    214 cnst(4) = 0.0
    +
    215C
    +
    216 ELSE IF (q.EQ.40) THEN
    +
    217C
    +
    218C*** GEOMETRIC VERTICAL VELOCITY -DZDT- (m/s)
    +
    219C
    +
    220 cnst(1) = 0.0
    +
    221 cnst(2) = 1.0
    +
    222 cnst(3) = 10.0
    +
    223 cnst(4) = 0.0
    +
    224C
    +
    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
    +
    227C
    +
    228C*** ABSOLUTE VORTICITY -ABS-V (/s)
    +
    229C*** ABSOLUTE DIVERGENCE -ABS-V (/s)
    +
    230C*** RELATIVE VORTICITY -REL-V (/s)
    +
    231C*** RELATIVE DIVERGENCE -REL-D (/s)
    +
    232C*** VERTICAL U-COMPONENT SHEAR -VUCSH (/s)
    +
    233C*** VERTICAL V-COMPONENT SHEAR -VVCSH (/s)
    +
    234C
    +
    235 cnst(1) = 0.0
    +
    236 cnst(2) = 1.0e+6
    +
    237 cnst(3) = 40.0
    +
    238 cnst(4) = 0.0
    +
    239C
    +
    240 ELSE IF (q.EQ.47) THEN
    +
    241C
    +
    242C*** DIRECTION OF CURRENT -DIR-C (deg. true)
    +
    243C
    +
    244 cnst(1) = 0.0
    +
    245 cnst(2) = 1.0
    +
    246 cnst(3) = 10.0
    +
    247 cnst(4) = 0.0
    +
    248C
    +
    249 ELSE IF (q.EQ.48.OR.q.EQ.49.OR.q.EQ.50) THEN
    +
    250C
    +
    251C*** SPEED OF CURRENT (m/s)
    +
    252C*** U AND V COMPONENTS OF CURRENT (m/s)
    +
    253C
    +
    254 cnst(1) = 0.
    +
    255 cnst(2) = 1.
    +
    256 cnst(3) = 2.
    +
    257 cnst(4) = 0.
    +
    258C
    +
    259 ELSE IF (q.EQ.51.OR.q.EQ.53) THEN
    +
    260C
    +
    261C*** SPECIFIC HUMIDITY SPF H (kg/kg)
    +
    262C*** HUMIDITY MIXING RATIO MIXR (kg/kg)
    +
    263C
    +
    264 cnst(1) = 0.0
    +
    265 cnst(2) = 1.e+3
    +
    266 cnst(3) = 2.0
    +
    267 cnst(4) = 0.0
    +
    268C
    +
    269 ELSE IF (q.EQ.52) THEN
    +
    270C
    +
    271C*** RELATIVE HUMIDITY R H (%)
    +
    272C
    +
    273 cnst(1) = 0.0
    +
    274 cnst(2) = 1.0
    +
    275 cnst(3) = 20.0
    +
    276 cnst(4) = 0.0
    +
    277C
    +
    278 ELSE IF (q.EQ.54.OR.q.EQ.57.OR.q.EQ.58) THEN
    +
    279C
    +
    280C*** PRECIPITABLE WATER (kg/m**2) OR .1 GRAM/CM*CM OR MILLIMETERS/CM*CM
    +
    281C*** CHANGE TO CENTI-INCHES/CM*CM
    +
    282C*** EVAPERATION
    +
    283C*** CLOUD ICE (kg/m**2)
    +
    284C
    +
    285 cnst(1) = 0.0
    +
    286 cnst(2) = 3.937
    +
    287 cnst(3) = 10.0
    +
    288 cnst(4) = 0.0
    +
    289C
    +
    290 ELSE IF (q.EQ.55.OR.q.EQ.56) THEN
    +
    291C
    +
    292C*** VAPOR PRESSURE VAPP, SATURATION DEFICIT SAT D (Pa)
    +
    293C
    +
    294 cnst(1) = 0.0
    +
    295 cnst(2) = 1.0
    +
    296 cnst(3) = 10.0
    +
    297 cnst(4) = 0.0
    +
    298C
    +
    299 ELSE IF (q.EQ.59) THEN
    +
    300C
    +
    301C*** PRECIPITATION RATE (kg/m**2/s)
    +
    302C
    +
    303 cnst(1) = 0.0
    +
    304 cnst(2) = 1.0
    +
    305 cnst(3) = 20.0
    +
    306 cnst(4) = 0.0
    +
    307C
    +
    308 ELSE IF (q.EQ.60) THEN
    +
    309C
    +
    310C*** THUNDERSTORM PROBABILITY (%)
    +
    311C
    +
    312 cnst(1) = 0.0
    +
    313 cnst(2) = 1.0
    +
    314 cnst(3) = 20.0
    +
    315 cnst(4) = 0.0
    +
    316C
    +
    317 ELSE IF (q.EQ.61.OR.q.EQ.62.OR.q.EQ.63.OR.q.EQ.64.OR.
    +
    318 & q.EQ.65) THEN
    +
    319C
    +
    320C*** TOTAL PRECIPITATION A PCP (kg/m**2)
    +
    321C*** LARGE SCALE PRECIPITATION NCPCP (kg/m**2)
    +
    322C*** CONVECTIVE PRECIPITATION ACPCP (kg/m**2)
    +
    323C*** SNOWFALL RATE WATER EQUIVALENT SRWEQ (kg/m**2/s)
    +
    324C*** WATER EQUIV. OF ACCUM. SNOW DEPTH WEASD (kg/m**2)
    +
    325C
    +
    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
    +
    332C
    +
    333C*** SNOW DEPTH (METERS) (1 or 0) for snow or no snow
    +
    334C
    +
    335 cnst(1) = 0.0
    +
    336 cnst(2) = 1.0
    +
    337 cnst(3) = 1.0
    +
    338 cnst(4) = 0.0
    +
    339C
    +
    340 ELSE IF (q.EQ.67.OR.q.EQ.68.OR.q.EQ.69.OR.q.EQ.70) THEN
    +
    341C
    +
    342C*** MIXING LAYER DEPTH MIXHT (m)
    +
    343C*** TRANSIENT THEMOCLINE DEPTH TTHDP (m)
    +
    344C*** MAIN THERMOCLINE DEPTH MTHCD (m)
    +
    345C*** MAIN THERMOCLINE ANOMALY MTHCA (m)
    +
    346C
    +
    347 cnst(1) = 0.0
    +
    348 cnst(2) = 39.37
    +
    349 cnst(3) = 06.0
    +
    350 cnst(4) = 0.0
    +
    351C
    +
    352 ELSE IF (q.EQ.120.OR.q.EQ.121) THEN
    +
    353C
    +
    354C*** WAVE COMPONENT OF GEOPOTENTIAL (GEOP M)
    +
    355C
    +
    356 cnst(1) = 0.0
    +
    357 cnst(2) = 1.0
    +
    358 cnst(3) = 10.0
    +
    359 cnst(4) = 0.0
    +
    360C
    +
    361 ELSE IF (q.EQ.71.OR.q.EQ.72.OR.q.EQ.73.OR.q.EQ.74.OR.
    +
    362 & q.EQ.75) THEN
    +
    363C
    +
    364C*** TOTAL CLOUD COVER T CDC (%)
    +
    365C*** CONVECTIVE CLOUD COVER CDCON (%)
    +
    366C*** LOW CLOUD COVER L CDC (%)
    +
    367C*** MEDIUM CLOUD COVER M CDC (%)
    +
    368C*** HIGH CLOUD COVER H CDC (%)
    +
    369C
    +
    370 cnst(1) = 0.0
    +
    371 cnst(2) = 1.0
    +
    372 cnst(3) = 10.0
    +
    373 cnst(4) = 0.0
    +
    374C
    +
    375 ELSE IF (q.EQ.76) THEN
    +
    376C
    +
    377C*** CLOUD WATER -C-WAT (kg/m**2)
    +
    378C
    +
    379 cnst(1) = 0.0
    +
    380 cnst(2) = 1.0
    +
    381 cnst(3) = 10.0
    +
    382 cnst(4) = 0.0
    +
    383C
    +
    384 ELSE IF (q.EQ.78) THEN
    +
    385C
    +
    386C*** CONVECTIVE SNOW -C-SNO (kg/m**2)
    +
    387C
    +
    388 cnst(1) = 0.0
    +
    389 cnst(2) = 1.0
    +
    390 cnst(3) = 10.0
    +
    391 cnst(4) = 0.0
    +
    392C
    +
    393 ELSE IF (q.EQ.79) THEN
    +
    394C
    +
    395C*** LARGE SCALE SNOW -LSSNO (kg/m**2)
    +
    396C
    +
    397 cnst(1) = 0.0
    +
    398 cnst(2) = 0.1
    +
    399 cnst(3) = 500.0
    +
    400 cnst(4) = 0.0
    +
    401C
    +
    402 ELSE IF (q.EQ.80) THEN
    +
    403C
    +
    404C*** WATER TEMPERAUTER -WTMP- (deg. K)
    +
    405C
    +
    406 cnst(1) = 0.0
    +
    407 cnst(2) = 1.0
    +
    408 cnst(3) = 2.0
    +
    409 cnst(4) = 0.0
    +
    410C
    +
    411 ELSE IF (q.EQ.81) THEN
    +
    412C
    +
    413C*** LAND/SEA (1=LAND; 0=SEA)
    +
    414C*** ICE CONCENTRATION (ICE=1; NO ICE=0)
    +
    415C
    +
    416 cnst(1) = 0.0
    +
    417 cnst(2) = 1.0
    +
    418 cnst(3) = 1.0
    +
    419 cnst(4) = 0.5
    +
    420C
    +
    421 ELSE IF (q.EQ.82.OR.q.EQ.83.OR.q.EQ.92.OR.q.EQ.97) THEN
    +
    422C
    +
    423C*** DEVIATION OF SEA LEVEL FROM MEAN (m)
    +
    424C*** SUFACE ROUGHNESS (m)
    +
    425C*** ICE THICKNESS (m)
    +
    426C*** ICE GROWTH (m)
    +
    427C
    +
    428 cnst(1) = 0.0
    +
    429 cnst(2) = 1.0
    +
    430 cnst(3) = 2.0
    +
    431 cnst(4) = 0.0
    +
    432C
    +
    433 ELSE IF (q.EQ.84) THEN
    +
    434C
    +
    435C*** ALBEDO (%)
    +
    436C
    +
    437 cnst(1) = 0.0
    +
    438 cnst(2) = 1.0
    +
    439 cnst(3) = 10.0
    +
    440 cnst(4) = 0.0
    +
    441C
    +
    442 ELSE IF (q.EQ.86) THEN
    +
    443C
    +
    444C*** SOIL MOISTURE CONTENT (kg/m**2) -SOILM
    +
    445C
    +
    446 cnst(1) = 0.0
    +
    447 cnst(2) = 1.0
    +
    448 cnst(3) = 10.0
    +
    449 cnst(4) = 0.0
    +
    450C
    +
    451 ELSE IF (q.EQ.87) THEN
    +
    452C
    +
    453C*** VEGETATION -VEG- (%)
    +
    454C
    +
    455 cnst(1) = 0.0
    +
    456 cnst(2) = 1.0
    +
    457 cnst(3) = 10.0
    +
    458 cnst(4) = 0.0
    +
    459C
    +
    460 ELSE IF (q.EQ.88) THEN
    +
    461C
    +
    462C*** SALINITY -SALTY- (kg/kg)
    +
    463C
    +
    464 cnst(1) = 0.0
    +
    465 cnst(2) = 1.0
    +
    466 cnst(3) = 10.0
    +
    467 cnst(4) = 0.0
    +
    468C
    +
    469 ELSE IF (q.EQ.89) THEN
    +
    470C
    +
    471C*** DENSITY -DEN-- (kg/m**3)
    +
    472C
    +
    473 cnst(1) = 0.0
    +
    474 cnst(2) = 1.0
    +
    475 cnst(3) = 10.0
    +
    476 cnst(4) = 0.0
    +
    477C
    +
    478 ELSE IF (q.EQ.90) THEN
    +
    479C
    +
    480C*** WATER RUNOFF -WAT-R (kg/m**2)
    +
    481C
    +
    482 cnst(1) = 0.0
    +
    483 cnst(2) = 1.0
    +
    484 cnst(3) = 10.0
    +
    485 cnst(4) = 0.0
    +
    486C
    +
    487 ELSE IF (q.EQ.93) THEN
    +
    488C
    +
    489C*** DIRECTION OF ICE DRIFT -DICED (deg. true)
    +
    490C
    +
    491 cnst(1) = 0.0
    +
    492 cnst(2) = 1.0
    +
    493 cnst(3) = 10.0
    +
    494 cnst(4) = 0.0
    +
    495C
    +
    496 ELSE IF (q.EQ.94.OR.q.EQ.95.OR.q.EQ.96) THEN
    +
    497C
    +
    498C*** SPEED OF ICE DRIFT -SICED (m/s)
    +
    499C*** U-COMPONENT OF ICE DRIFT -U-ICE (m/s)
    +
    500C*** V-COMPONENT OF ICE DRIFT -V-ICE (m/s)
    +
    501C
    +
    502 cnst(1) = 0.0
    +
    503 cnst(2) = 1.0
    +
    504 cnst(3) = 2.0
    +
    505 cnst(4) = 0.0
    +
    506C
    +
    507 ELSE IF (q.EQ.98) THEN
    +
    508C
    +
    509C*** ICE DIVERGENCE -ICE D (/s)
    +
    510C
    +
    511 cnst(1) = 0.0
    +
    512 cnst(2) = 1.0
    +
    513 cnst(3) = 10.0
    +
    514 cnst(4) = 0.0
    +
    515C
    +
    516 ELSE IF (q.EQ.99) THEN
    +
    517C
    +
    518C*** SNO MELT -SNO- M (kg/m**2)
    +
    519C
    +
    520 cnst(1) = 0.0
    +
    521 cnst(2) = 1.0
    +
    522 cnst(3) = 10.0
    +
    523 cnst(4) = 0.0
    +
    524C
    +
    525 ELSE IF (q.EQ.100.OR.q.EQ.102.OR.q.EQ.105) THEN
    +
    526C
    +
    527C*** HEIGHT OF WIND DRIVEN OCEAN WAVES, SEA SWELLS, OR COMBINATION
    +
    528C*** (m)
    +
    529C
    +
    530 cnst(1) = 0.0
    +
    531 cnst(2) = 1.0
    +
    532 cnst(3) = 1.0
    +
    533 cnst(4) = 0.0
    +
    534C
    +
    535 ELSE IF (q.EQ.101.OR.q.EQ.104.OR.q.EQ.107.OR.q.EQ.109) THEN
    +
    536C
    +
    537C*** DIRECTION OF WIND WAVES, SWELLS WAVES, PRIMARY WAVE, SECONDARY
    +
    538C*** WAVE (deg. true) --------------------
    +
    539C
    +
    540 cnst(1) = 0.0
    +
    541 cnst(2) = 1.0
    +
    542 cnst(3) = 20.0
    +
    543 cnst(4) = 0.0
    +
    544C
    +
    545 ELSE IF (q.EQ.103.OR.q.EQ.106.OR.q.EQ.108.OR.q.EQ.110) THEN
    +
    546C
    +
    547C*** MEAN PERIOD OF WIND WAVES, SWELLS WAVES, PRIMARY WAVE, SECONDARY
    +
    548C*** WAVE (s) --------------------
    +
    549C
    +
    550 cnst(1) = 0.0
    +
    551 cnst(2) = 1.0
    +
    552 cnst(3) = 2.0
    +
    553 cnst(4) = 0.0
    +
    554C
    +
    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
    +
    558C
    +
    559C*** NET SHORTWAVE RADITION (SURFACE) -NSWRS w/m **2
    +
    560C*** NET LONGWAVE RADITION (SURFACE) -SHTFL w/m**2
    +
    561C*** NET SHORTWAVE RADITION (TOP OF ATOMS.) -NSWRT w/m**2
    +
    562C*** NET LONGWAVE RADITION (TOP OF ATOMS.) -NLWRT w/m**2
    +
    563C*** LONG WAVE RADITION -LWAVR w/m**2
    +
    564C*** SHORT WAVE RADITION -SWAVE w/m**2
    +
    565C*** GLOBAL RADITION -G-RAD w/m**2
    +
    566C*** LATENT HEAT FLUX -LHTFL w/m**2
    +
    567C*** SENSIBLE HEAT FLUX -SHTFL w/m**2
    +
    568C*** BOUNDARY LAYER DISSIPATION -BLYDP w/m**2
    +
    569C
    +
    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
    +
    575C
    +
    576 ELSE IF (q.EQ.127) THEN
    +
    577C
    +
    578C IMAGE DATA -IMG-D
    +
    579C
    +
    580 cnst(1) = 0.0
    +
    581 cnst(2) = 1.0
    +
    582 cnst(3) = 10.0
    +
    583 cnst(4) = 0.0
    +
    584C
    +
    585 ELSE IF (q.EQ.128) THEN
    +
    586C
    +
    587C Mean Sea Level Pressure -MSLSA (Pa)
    +
    588C (Standard Atmosphere Reduction)
    +
    589C
    +
    590 cnst(1) = 0.0
    +
    591 cnst(2) = 0.01
    +
    592 cnst(3) = 4.0
    +
    593 cnst(4) = 0.0
    +
    594C
    +
    595 ELSE IF (q.EQ.129) THEN
    +
    596C
    +
    597C Mean Sea Level Pressure -MSLMA (Pa)
    +
    598C (Maps System Reduction)
    +
    599C
    +
    600 cnst(1) = 0.0
    +
    601 cnst(2) = 0.01
    +
    602 cnst(3) = 4.0
    +
    603 cnst(4) = 0.0
    +
    604C
    +
    605 ELSE IF (q.EQ.130) THEN
    +
    606C
    +
    607C Mean Sea Level Pressure -MSLET (Pa)
    +
    608C (ETA Model Reduction)
    +
    609C
    +
    610 cnst(1) = 0.0
    +
    611 cnst(2) = 0.01
    +
    612 cnst(3) = 4.0
    +
    613 cnst(4) = 0.0
    +
    614C
    +
    615 ELSE IF (q.EQ.131.OR.q.EQ.132.OR.q.EQ.133.OR.q.EQ.134) THEN
    +
    616C
    +
    617C*** SURFACE LIFTED INDEX ..(DEG K)
    +
    618C*** BEST (4 LAYER) LIFTED INDEX ..(DEG K)
    +
    619C*** K INDEX ..(DEG K) TO DEG C.
    +
    620C*** SWEAT INDEX ..(DEG K) TO DEG C.
    +
    621C
    +
    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
    +
    630C
    +
    631 ELSE IF (q.EQ.135) THEN
    +
    632C
    +
    633C*** HORIZONTIAL MOISTURE DIVERGENCE (KG/KG/S) -MCONV
    +
    634C
    +
    635 cnst(1) = 0.0
    +
    636 cnst(2) = 1.e+8
    +
    637 cnst(3) = 10.0
    +
    638 cnst(4) = 0.0
    +
    639C
    +
    640 ELSE IF (q.EQ.136) THEN
    +
    641C
    +
    642C*** VERTICAL SPEED SHEAR (1/SEC)... TO BE CONVERTED TO KNOTS/1000 FT
    +
    643C
    +
    644 cnst(1) = 0.0
    +
    645 cnst(2) = 592.086
    +
    646 cnst(3) = 2.0
    +
    647 cnst(4) = 0.0
    +
    648C
    +
    649 ELSE IF (q.EQ.137) THEN
    +
    650C
    +
    651C*** 3-hr pressure tendency (TSLSA) (Pa/s)
    +
    652C
    +
    653 cnst(1) = 0.0
    +
    654 cnst(2) = 1000.0
    +
    655 cnst(3) = 10.0
    +
    656 cnst(4) = 0.0
    +
    657C
    +
    658 ELSE IF (q.EQ.156) THEN
    +
    659C
    +
    660C*** CONVECTIVE INHIBITION -CIN-- (J/kg)
    +
    661C
    +
    662 cnst(1) = 0.0
    +
    663 cnst(2) = 1.0
    +
    664 cnst(3) = 10.0
    +
    665 cnst(4) = 0.0
    +
    666C
    +
    667 ELSE IF (q.EQ.157) THEN
    +
    668C
    +
    669C*** CONVECTIVE AVAILABLE POTENTIAL ENERGY -CAPE- (J/kg)
    +
    670C
    +
    671 cnst(1) = 0.0
    +
    672 cnst(2) = 1.0
    +
    673 cnst(3) = 500.0
    +
    674 cnst(4) = 0.0
    +
    675C
    +
    676 ELSE IF (q.EQ.158) THEN
    +
    677C
    +
    678C*** TURBULENT KINETIC ENERGY -TKE-- (J/kg)
    +
    679C
    +
    680 cnst(1) = 0.0
    +
    681 cnst(2) = 1.0
    +
    682 cnst(3) = 100.0
    +
    683 cnst(4) = 0.0
    +
    684C
    +
    685 ELSE IF (q.EQ.175) THEN
    +
    686C
    +
    687C*** MODEL LAYER NUMBER (FROM BOTTOM UP) -SGLYR (non-dim)
    +
    688C
    +
    689 cnst(1) = 0.0
    +
    690 cnst(2) = 1.0
    +
    691 cnst(3) = 1.0
    +
    692 cnst(4) = 0.0
    +
    693C
    +
    694 ELSE IF (q.EQ.176) THEN
    +
    695C
    +
    696C*** LATITUDE (-90 TO +90) -NLAT- (deg)
    +
    697C
    +
    698 cnst(1) = 0.0
    +
    699 cnst(2) = 1.0
    +
    700 cnst(3) = 10.0
    +
    701 cnst(4) = 0.0
    +
    702C
    +
    703 ELSE IF (q.EQ.177) THEN
    +
    704C
    +
    705C*** EAST LATITUDE (0-360) -ELON- (deg)
    +
    706C
    +
    707 cnst(1) = 0.0
    +
    708 cnst(2) = 1.0
    +
    709 cnst(3) = 10.0
    +
    710 cnst(4) = 0.0
    +
    711C
    +
    712 ELSE IF (q.EQ.201) THEN
    +
    713C
    +
    714C*** ICE-FREE WATER SURFACE -ICWAT (%)
    +
    715C
    +
    716 cnst(1) = 0.0
    +
    717 cnst(2) = 1.0
    +
    718 cnst(3) = 10.0
    +
    719 cnst(4) = 0.0
    +
    720C
    +
    721 ELSE IF (q.EQ.204) THEN
    +
    722C
    +
    723C*** DOWNWARD SHORT WAVE RAD. FLUX -DSWRF (W/m**2)
    +
    724C
    +
    725 cnst(1) = 0.0
    +
    726 cnst(2) = 1.0
    +
    727 cnst(3) = 10.0
    +
    728 cnst(4) = 0.0
    +
    729C
    +
    730 ELSE IF (q.EQ.205) THEN
    +
    731C
    +
    732C*** DOWNWARD LONG WAVE RAD. FLUX -DLWRF (W/m**2)
    +
    733C
    +
    734 cnst(1) = 0.0
    +
    735 cnst(2) = 1.0
    +
    736 cnst(3) = 10.0
    +
    737 cnst(4) = 0.0
    +
    738C
    +
    739 ELSE IF (q.EQ.207) THEN
    +
    740C
    +
    741C*** MOISTURE AVAILABILITY -MSTAV (%)
    +
    742C
    +
    743 cnst(1) = 0.0
    +
    744 cnst(2) = 1.0
    +
    745 cnst(3) = 10.0
    +
    746 cnst(4) = 0.0
    +
    747C
    +
    748 ELSE IF (q.EQ.208) THEN
    +
    749C
    +
    750C*** EXCHANGE COEFFICIENT -SFEXC (kg/m**3)(m/s)
    +
    751C
    +
    752 cnst(1) = 0.0
    +
    753 cnst(2) = 1.0
    +
    754 cnst(3) = 10.0
    +
    755 cnst(4) = 0.0
    +
    756CC
    +
    757 ELSE IF (q.EQ.209) THEN
    +
    758C
    +
    759C*** NO. OF MIXED LAYERS NEXT TO SURFACE -MIXLY (integer)
    +
    760C
    +
    761 cnst(1) = 0.0
    +
    762 cnst(2) = 1.0
    +
    763 cnst(3) = 10.0
    +
    764 cnst(4) = 0.0
    +
    765C
    +
    766 ELSE IF (q.EQ.211) THEN
    +
    767C
    +
    768C*** UPWARD SHORT WAVE RAD. FLUX -USWRF (W/m**2)
    +
    769C
    +
    770 cnst(1) = 0.0
    +
    771 cnst(2) = 1.0
    +
    772 cnst(3) = 10.0
    +
    773 cnst(4) = 0.0
    +
    774C
    +
    775 ELSE IF (q.EQ.212) THEN
    +
    776C
    +
    777C*** UPWARD LONG WAVE RAD. FLUX -ULWRF (W/m**2)
    +
    778C
    +
    779 cnst(1) = 0.0
    +
    780 cnst(2) = 1.0
    +
    781 cnst(3) = 10.0
    +
    782 cnst(4) = 0.0
    +
    783C
    +
    784 ELSE IF (q.EQ.213) THEN
    +
    785C
    +
    786C*** AMOUNT OF NON-CONVECTIVE CLOUD -CDLYR (%)
    +
    787C
    +
    788 cnst(1) = 0.0
    +
    789 cnst(2) = 1.0
    +
    790 cnst(3) = 10.0
    +
    791 cnst(4) = 0.0
    +
    792C
    +
    793 ELSE IF (q.EQ.216) THEN
    +
    794C
    +
    795C*** TEMPERATURE TENDENCY BY ALL RADIATION -TTRAD (Deg. K/s)
    +
    796C
    +
    797 cnst(1) = 0.0
    +
    798 cnst(2) = 1.0
    +
    799 cnst(3) = 10.0
    +
    800 cnst(4) = 0.0
    +
    801C
    +
    802 ELSE IF (q.EQ.218) THEN
    +
    803C
    +
    804C*** PRECIP. INDEX (0.0-1.00) -PREIX (note will look like %)
    +
    805C
    +
    806 cnst(1) = 0.0
    +
    807 cnst(2) = 100.0
    +
    808 cnst(3) = 10.0
    +
    809 cnst(4) = 0.0
    +
    810C
    +
    811 ELSE IF (q.EQ.220) THEN
    +
    812C
    +
    813C*** NATURAL LOG OF SURFACE PRESSURE -NLGSP ln(kPa)
    +
    814C
    +
    815 cnst(1) = 0.0
    +
    816 cnst(2) = 1.0
    +
    817 cnst(3) = 10.0
    +
    818 cnst(4) = 0.0
    +
    819C
    +
    820C*** NONE OF THE ABOVE ....
    +
    821C
    +
    822 ELSE
    +
    823C
    +
    824C SET DEFAULT VALUES
    +
    825C
    +
    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
    +
    832C
    +
    833 RETURN
    +
    +
    834 END
    +
    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
    +
    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
    diff --git a/w3fi71_8f.html b/w3fi71_8f.html index 64904cbf..0a01db8e 100644 --- a/w3fi71_8f.html +++ b/w3fi71_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi71.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi71.f File Reference
    +
    w3fi71.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Make array used by GRIB packer for GDS.

    @@ -107,8 +113,8 @@

    Definition in file w3fi71.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi71()

    + +

    ◆ w3fi71()

    @@ -117,19 +123,19 @@

    subroutine w3fi71 ( integer  - IGRID, + igrid, integer, dimension (*)  - IGDS, + igds,   - IERR  + ierr  @@ -139,7 +145,7 @@

    -

    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.

    +

    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.
      • @@ -342,7 +348,7 @@

    diff --git a/w3fi71_8f.js b/w3fi71_8f.js index cc74ec30..2ea37520 100644 --- a/w3fi71_8f.js +++ b/w3fi71_8f.js @@ -1,4 +1,4 @@ var w3fi71_8f = [ - [ "w3fi71", "w3fi71_8f.html#add1b6b2b2c9fda60094914f5e676ec42", null ] + [ "w3fi71", "w3fi71_8f.html#a8093d4ae34f8b50308c55b03ac0d2fc6", null ] ]; \ No newline at end of file diff --git a/w3fi71_8f_source.html b/w3fi71_8f_source.html index 0994d660..3cd2008e 100644 --- a/w3fi71_8f_source.html +++ b/w3fi71_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi71.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,1680 +81,1688 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi71.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Make array used by GRIB packer for GDS.
    +
    3C> @author Ralph Jones @date 1992-02-21
    +
    4
    +
    5C> Makes a 18, 37, 55, 64, or 91 word integer array
    +
    6C> used by w3fi72() GRIB packer to make the grid description section
    +
    7C> (GDS) - section 2.
    +
    8C>
    +
    9C> @note
    +
    10C> - 1) Office note grid type 26 is 6 in grib, 26 is an
    +
    11C> international exchange grid.
    +
    12C>
    +
    13C> - 2) Values returned in 18, 37, 55, 64, or 91 word integer array
    +
    14C> igds vary depending on grid representation type.
    +
    15C>
    +
    16C> - LAT/LON GRID:
    +
    17C> - IGDS( 1) = number of vertical coordinates
    +
    18C> - IGDS( 2) = pv, pl or 255
    +
    19C> - IGDS( 3) = data representation type (code table 6)
    +
    20C> - IGDS( 4) = no. of points along a latitude
    +
    21C> - IGDS( 5) = no. of points along a longitude meridian
    +
    22C> - IGDS( 6) = latitude of origin (south - ive)
    +
    23C> - IGDS( 7) = longitude of origin (west -ive)
    +
    24C> - IGDS( 8) = resolution flag (code table 7)
    +
    25C> - IGDS( 9) = latitude of extreme point (south - ive)
    +
    26C> - IGDS(10) = longitude of extreme point (west - ive)
    +
    27C> - IGDS(11) = latitude increment
    +
    28C> - IGDS(12) = longitude increment
    +
    29C> - IGDS(13) = scanning mode flags (code table 8)
    +
    30C> - IGDS(14) = ... through ...
    +
    31C> - IGDS(18) = ... not used for this grid
    +
    32C> - IGDS(19) - igds(91) for grids 37-44, number of points
    +
    33C> - in each of 73 rows.
    +
    34C>
    +
    35C> - GAUSSIAN GRID:
    +
    36C> - IGDS( 1) = ... through ...
    +
    37C> - IGDS(10) = ... same as lat/lon grid
    +
    38C> - IGDS(11) = number of latitude lines between a pole
    +
    39C> - and the equator
    +
    40C> - IGDS(12) = longitude increment
    +
    41C> - IGDS(13) = scanning mode flags (code table 8)
    +
    42C> - IGDS(14) = ... through ...
    +
    43C> - IGDS(18) = ... not used for this grid
    +
    44C>
    +
    45C> - SPHERICAL HARMONICS:
    +
    46C> - IGDS( 1) = number of vertical coordinates
    +
    47C> - IGDS( 2) = pv, pl or 255
    +
    48C> - IGDS( 3) = data representation type (code table 6)
    +
    49C> - IGDS( 4) = j - pentagonal resolution parameter
    +
    50C> - IGDS( 5) = k - pentagonal resolution parameter
    +
    51C> - IGDS( 6) = m - pentagonal resolution parameter
    +
    52C> - IGDS( 7) = representation type (code table 9)
    +
    53C> - IGDS( 8) = representation mode (code table 10)
    +
    54C> - IGDS( 9) = ... through ...
    +
    55C> - IGDS(18) = ... not used for this grid
    +
    56C>
    +
    57C> - POLAR STEREOGRAPHIC:
    +
    58C> - IGDS( 1) = number of vertical coordinates
    +
    59C> - IGDS( 2) = pv, pl or 255
    +
    60C> - IGDS( 3) = data representation type (code table 6)
    +
    61C> - IGDS( 4) = no. of points along x-axis
    +
    62C> - IGDS( 5) = no. of points along y-axis
    +
    63C> - IGDS( 6) = latitude of origin (south -ive)
    +
    64C> - IGDS( 7) = longitute of origin (west -ive)
    +
    65C> - IGDS( 8) = resolution flag (code table 7)
    +
    66C> - IGDS( 9) = longitude of meridian parallel to y-axis
    +
    67C> - IGDS(10) = x-direction grid length (increment)
    +
    68C> - IGDS(11) = y-direction grid length (increment)
    +
    69C> - IGDS(12) = projection center flag (0=north pole on plane,
    +
    70C> - 1=south pole on plane,
    +
    71C> - IGDS(13) = scanning mode flags (code table 8)
    +
    72C> - IGDS(14) = ... through ...
    +
    73C> - IGDS(18) = .. not used for this grid
    +
    74C>
    +
    75C> - MERCATOR:
    +
    76C> - IGDS( 1) = ... through ...
    +
    77C> - IGDS(12) = ... same as lat/lon grid
    +
    78C> - IGDS(13) = latitude at which projection cylinder
    +
    79C> - intersects earth
    +
    80C> - IGDS(14) = scanning mode flags
    +
    81C> - IGDS(15) = ... through ...
    +
    82C> - IGDS(18) = .. not used for this grid
    +
    83C>
    +
    84C> - LAMBERT CONFORMAL:
    +
    85C> - IGDS( 1) = number of vertical coordinates
    +
    86C> - IGDS( 2) = pv, pl or 255
    +
    87C> - IGDS( 3) = data representation type (code table 6)
    +
    88C> - IGDS( 4) = no. of points along x-axis
    +
    89C> - IGDS( 5) = no. of points along y-axis
    +
    90C> - IGDS( 6) = latitude of origin (south -ive)
    +
    91C> - IGDS( 7) = longitute of origin (west -ive)
    +
    92C> - IGDS( 8) = resolution flag (code table 7)
    +
    93C> - IGDS( 9) = longitude of meridian parallel to y-axis
    +
    94C> - IGDS(10) = x-direction grid length (increment)
    +
    95C> - IGDS(11) = y-direction grid length (increment)
    +
    96C> - IGDS(12) = projection center flag (0=north pole on plane,
    +
    97C> - 1=south pole on plane,
    +
    98C> - IGDS(13) = scanning mode flags (code table 8)
    +
    99C> - IGDS(14) = not used
    +
    100C> - IGDS(15) = first latitude from the pole at which the
    +
    101C> - secant cone cuts the sperical earth
    +
    102C> - IGDS(16) = second latitude ...
    +
    103C> - IGDS(17) = latitude of south pole (millidegrees)
    +
    104C> - IGDS(18) = longitude of south pole (millidegrees)
    +
    105C>
    +
    106C> - ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID
    +
    107C> - IGDS( 1) = number of vertical coordinates
    +
    108C> - IGDS( 2) = pv, pl or 255
    +
    109C> - IGDS( 3) = data representation type (code table 6) [201]
    +
    110C> - IGDS( 4) = ni - total number of actual data points
    +
    111C> - included on grid
    +
    112C> - IGDS( 5) = nj - dummy second dimension; set=1
    +
    113C> - IGDS( 6) = la1 - latitude of first grid point
    +
    114C> - IGDS( 7) = lo1 - longitude of first grid point
    +
    115C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    116C> - IGDS( 9) = la2 - number of mass points along
    +
    117C> - southernmost row of grid
    +
    118C> - IGDS(10) = lo2 - number of rows in each column
    +
    119C> - IGDS(11) = di - longitudinal direction increment
    +
    120C> - IGDS(12) = dj - latitudinal direction increment
    +
    121C> - IGDS(13) = scanning mode flags (code table 8)
    +
    122C> - IGDS(14) = ... through ...
    +
    123C> - IGDS(18) = ... not used for this grid (set to zero)
    +
    124C>
    +
    125C> - ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID
    +
    126C> - IGDS( 1) = number of vertical coordinates
    +
    127C> - IGDS( 2) = pv, pl or 255
    +
    128C> - IGDS( 3) = data representation type (code table 6) [202]
    +
    129C> - IGDS( 4) = ni - total number of actual data points
    +
    130C> - included on grid
    +
    131C> - IGDS( 5) = nj - dummy second dimention; set=1
    +
    132C> - IGDS( 6) = la1 - latitude latitude of first grid point
    +
    133C> - IGDS( 7) = lo1 - longitude of first grid point
    +
    134C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    135C> - IGDS( 9) = la2 - number of (zonal) points in each row
    +
    136C> - IGDS(10) = lo2 - number of (meridional) points in each
    +
    137C> - column
    +
    138C> - IGDS(11) = di - longitudinal direction increment
    +
    139C> - IGDS(12) = dj - latitudinal direction increment
    +
    140C> - IGDS(13) = scanning mode flags (code table 8)
    +
    141C> - IGDS(14) = ... through ...
    +
    142C> - IGDS(18) = ... not used for this grid
    +
    143C>
    +
    144C> - ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID
    +
    145C> - IGDS( 1) = number of vertical coordinates
    +
    146C> - IGDS( 2) = pv, pl or 255
    +
    147C> - IGDS( 3) = data representation type (code table 6) [203]
    +
    148C> - IGDS( 4) = ni - number of data points in each row
    +
    149C> - IGDS( 5) = nj - number of rows
    +
    150C> - IGDS( 6) = la1 - latitude of first grid point
    +
    151C> - IGDS( 7) = lo1 - longitude of first grid point
    +
    152C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    153C> - IGDS( 9) = la2 - central latitude
    +
    154C> - IGDS(10) = lo2 - central longtitude
    +
    155C> - IGDS(11) = di - longitudinal direction increment
    +
    156C> - IGDS(12) = dj - latitudinal direction increment
    +
    157C> - IGDS(13) = scanning mode flags (code table 8)
    +
    158C> - IGDS(14) = ... through ...
    +
    159C> - IGDS(18) = ... not used for this grid
    +
    160C>
    +
    161C> - CURVILINEAR ORTHOGONAL GRID
    +
    162C> - IGDS( 1) = number of vertical coordinates
    +
    163C> - IGDS( 2) = pv, pl or 255
    +
    164C> - IGDS( 3) = data representation type (code table 6) [204]
    +
    165C> - IGDS( 4) = ni - number of data points in each row
    +
    166C> - IGDS( 5) = nj - number of rows
    +
    167C> - IGDS( 6) = reserved (set to 0)
    +
    168C> - IGDS( 7) = reserved (set to 0)
    +
    169C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    170C> - IGDS( 9) = reserved (set to 0)
    +
    171C> - IGDS(10) = reserved (set to 0)
    +
    172C> - IGDS(11) = reserved (set to 0)
    +
    173C> - IGDS(12) = reserved (set to 0)
    +
    174C> - IGDS(13) = scanning mode flags (code table 8)
    +
    175C> - IGDS(14) = ... through ...
    +
    176C> - IGDS(18) = ... not used for this grid
    +
    177C>
    +
    178C> @param[in] IGRID GRIB grid number, or office note 84 grid number
    +
    179C> @param[out] IGDS 18, 37, 55, 64, or 91 word integer array with
    +
    180C> information to make a grib grid description section.
    +
    181C> @param[out] IERR:
    +
    182C> - 0 Correct exit
    +
    183C> - 1 Grid type in igrid is not in table
    +
    184C>
    +
    185C> @author Ralph Jones @date 1992-02-21
    +
    +
    186 SUBROUTINE w3fi71 (IGRID, IGDS, IERR)
    +
    187C
    +
    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)
    +
    360C
    +
    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/
    +
    773C
    +
    774 ierr = 0
    +
    775C
    +
    776 DO 1 i = 1,18
    +
    777 igds(i) = 0
    +
    778 1 CONTINUE
    +
    779C
    +
    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
    +
    785C
    +
    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
    +
    791C
    +
    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
    +
    797C
    +
    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
    +
    803C
    +
    804 IF (igrid.EQ.1) THEN
    +
    805 DO 3 i = 1,18
    +
    806 igds(i) = grd1(i)
    +
    807 3 CONTINUE
    +
    808C
    +
    809 ELSE IF (igrid.EQ.2) THEN
    +
    810 DO 4 i = 1,18
    +
    811 igds(i) = grd2(i)
    +
    812 4 CONTINUE
    +
    813C
    +
    814 ELSE IF (igrid.EQ.3) THEN
    +
    815 DO 5 i = 1,18
    +
    816 igds(i) = grd3(i)
    +
    817 5 CONTINUE
    +
    818C
    +
    819 ELSE IF (igrid.EQ.4) THEN
    +
    820 DO 6 i = 1,18
    +
    821 igds(i) = grd4(i)
    +
    822 6 CONTINUE
    +
    823C
    +
    824 ELSE IF (igrid.EQ.5) THEN
    +
    825 DO 10 i = 1,18
    +
    826 igds(i) = grd5(i)
    +
    827 10 CONTINUE
    +
    828C
    +
    829 ELSE IF (igrid.EQ.6) THEN
    +
    830 DO 20 i = 1,18
    +
    831 igds(i) = grd6(i)
    +
    832 20 CONTINUE
    +
    833C
    +
    834 ELSE IF (igrid.EQ.8) THEN
    +
    835 DO i = 1,18
    +
    836 igds(i) = grd8(i)
    +
    837 END DO
    +
    838C
    +
    839 ELSE IF (igrid.EQ.10) THEN
    +
    840 DO i = 1,18
    +
    841 igds(i) = grd10(i)
    +
    842 END DO
    +
    843C
    +
    844 ELSE IF (igrid.EQ.11) THEN
    +
    845 DO i = 1,18
    +
    846 igds(i) = grd11(i)
    +
    847 END DO
    +
    848C
    +
    849 ELSE IF (igrid.EQ.12) THEN
    +
    850 DO i = 1,18
    +
    851 igds(i) = grd12(i)
    +
    852 END DO
    +
    853C
    +
    854 ELSE IF (igrid.EQ.13) THEN
    +
    855 DO i = 1,18
    +
    856 igds(i) = grd13(i)
    +
    857 END DO
    +
    858C
    +
    859 ELSE IF (igrid.EQ.14) THEN
    +
    860 DO i = 1,18
    +
    861 igds(i) = grd14(i)
    +
    862 END DO
    +
    863C
    +
    864 ELSE IF (igrid.EQ.15) THEN
    +
    865 DO i = 1,18
    +
    866 igds(i) = grd15(i)
    +
    867 END DO
    +
    868C
    +
    869 ELSE IF (igrid.EQ.16) THEN
    +
    870 DO i = 1,18
    +
    871 igds(i) = grd16(i)
    +
    872 END DO
    +
    873C
    +
    874 ELSE IF (igrid.EQ.17) THEN
    +
    875 DO i = 1,18
    +
    876 igds(i) = grd17(i)
    +
    877 END DO
    +
    878C
    +
    879 ELSE IF (igrid.EQ.18) THEN
    +
    880 DO i = 1,18
    +
    881 igds(i) = grd18(i)
    +
    882 END DO
    +
    883C
    +
    884 ELSE IF (igrid.EQ.21) THEN
    +
    885 DO 30 i = 1,55
    +
    886 igds(i) = grd21(i)
    +
    887 30 CONTINUE
    +
    888C
    +
    889 ELSE IF (igrid.EQ.22) THEN
    +
    890 DO 40 i = 1,55
    +
    891 igds(i) = grd22(i)
    +
    892 40 CONTINUE
    +
    893C
    +
    894 ELSE IF (igrid.EQ.23) THEN
    +
    895 DO 50 i = 1,55
    +
    896 igds(i) = grd23(i)
    +
    897 50 CONTINUE
    +
    898C
    +
    899 ELSE IF (igrid.EQ.24) THEN
    +
    900 DO 60 i = 1,55
    +
    901 igds(i) = grd24(i)
    +
    902 60 CONTINUE
    +
    903C
    +
    904 ELSE IF (igrid.EQ.25) THEN
    +
    905 DO 70 i = 1,37
    +
    906 igds(i) = grd25(i)
    +
    907 70 CONTINUE
    +
    908C
    +
    909 ELSE IF (igrid.EQ.26) THEN
    +
    910 DO 80 i = 1,37
    +
    911 igds(i) = grd26(i)
    +
    912 80 CONTINUE
    +
    913C
    +
    914 ELSE IF (igrid.EQ.27) THEN
    +
    915 DO 90 i = 1,18
    +
    916 igds(i) = grd27(i)
    +
    917 90 CONTINUE
    +
    918C
    +
    919 ELSE IF (igrid.EQ.28) THEN
    +
    920 DO 100 i = 1,18
    +
    921 igds(i) = grd28(i)
    +
    922 100 CONTINUE
    +
    923C
    +
    924 ELSE IF (igrid.EQ.29) THEN
    +
    925 DO 110 i = 1,18
    +
    926 igds(i) = grd29(i)
    +
    927 110 CONTINUE
    +
    928C
    +
    929 ELSE IF (igrid.EQ.30) THEN
    +
    930 DO 120 i = 1,18
    +
    931 igds(i) = grd30(i)
    +
    932 120 CONTINUE
    +
    933C
    +
    934 ELSE IF (igrid.EQ.33) THEN
    +
    935 DO 130 i = 1,18
    +
    936 igds(i) = grd33(i)
    +
    937 130 CONTINUE
    +
    938C
    +
    939 ELSE IF (igrid.EQ.34) THEN
    +
    940 DO 140 i = 1,18
    +
    941 igds(i) = grd34(i)
    +
    942 140 CONTINUE
    +
    943C
    +
    944 ELSE IF (igrid.EQ.37) THEN
    +
    945 DO 141 i = 1,91
    +
    946 igds(i) = grd37(i)
    +
    947 141 CONTINUE
    +
    948C
    +
    949 ELSE IF (igrid.EQ.38) THEN
    +
    950 DO 142 i = 1,91
    +
    951 igds(i) = grd38(i)
    +
    952 142 CONTINUE
    +
    953C
    +
    954 ELSE IF (igrid.EQ.39) THEN
    +
    955 DO 143 i = 1,91
    +
    956 igds(i) = grd39(i)
    +
    957 143 CONTINUE
    +
    958C
    +
    959 ELSE IF (igrid.EQ.40) THEN
    +
    960 DO 144 i = 1,91
    +
    961 igds(i) = grd40(i)
    +
    962 144 CONTINUE
    +
    963C
    +
    964 ELSE IF (igrid.EQ.41) THEN
    +
    965 DO 145 i = 1,91
    +
    966 igds(i) = grd41(i)
    +
    967 145 CONTINUE
    +
    968C
    +
    969 ELSE IF (igrid.EQ.42) THEN
    +
    970 DO 146 i = 1,91
    +
    971 igds(i) = grd42(i)
    +
    972 146 CONTINUE
    +
    973C
    +
    974 ELSE IF (igrid.EQ.43) THEN
    +
    975 DO 147 i = 1,91
    +
    976 igds(i) = grd43(i)
    +
    977 147 CONTINUE
    +
    978C
    +
    979 ELSE IF (igrid.EQ.44) THEN
    +
    980 DO 148 i = 1,91
    +
    981 igds(i) = grd44(i)
    +
    982 148 CONTINUE
    +
    983C
    +
    984 ELSE IF (igrid.EQ.45) THEN
    +
    985 DO 149 i = 1,18
    +
    986 igds(i) = grd45(i)
    +
    987 149 CONTINUE
    +
    988C
    +
    989 ELSE IF (igrid.EQ.53) THEN
    +
    990 DO i = 1,18
    +
    991 igds(i) = grd53(i)
    +
    992 END DO
    +
    993C
    +
    994 ELSE IF (igrid.EQ.55) THEN
    +
    995 DO 152 i = 1,18
    +
    996 igds(i) = grd55(i)
    +
    997 152 CONTINUE
    +
    998C
    +
    999 ELSE IF (igrid.EQ.56) THEN
    +
    1000 DO 154 i = 1,18
    +
    1001 igds(i) = grd56(i)
    +
    1002 154 CONTINUE
    +
    1003C
    +
    1004 ELSE IF (igrid.EQ.61) THEN
    +
    1005 DO 160 i = 1,64
    +
    1006 igds(i) = grd61(i)
    +
    1007 160 CONTINUE
    +
    1008C
    +
    1009 ELSE IF (igrid.EQ.62) THEN
    +
    1010 DO 170 i = 1,64
    +
    1011 igds(i) = grd62(i)
    +
    1012 170 CONTINUE
    +
    1013C
    +
    1014 ELSE IF (igrid.EQ.63) THEN
    +
    1015 DO 180 i = 1,64
    +
    1016 igds(i) = grd63(i)
    +
    1017 180 CONTINUE
    +
    1018C
    +
    1019 ELSE IF (igrid.EQ.64) THEN
    +
    1020 DO 190 i = 1,64
    +
    1021 igds(i) = grd64(i)
    +
    1022 190 CONTINUE
    +
    1023C
    +
    1024 ELSE IF (igrid.EQ.83) THEN
    +
    1025 DO i = 1,18
    +
    1026 igds(i) = grd83(i)
    +
    1027 ENDDO
    +
    1028C
    +
    1029 ELSE IF (igrid.EQ.85) THEN
    +
    1030 DO 192 i = 1,18
    +
    1031 igds(i) = grd85(i)
    +
    1032 192 CONTINUE
    +
    1033C
    +
    1034 ELSE IF (igrid.EQ.86) THEN
    +
    1035 DO 194 i = 1,18
    +
    1036 igds(i) = grd86(i)
    +
    1037 194 CONTINUE
    +
    1038C
    +
    1039 ELSE IF (igrid.EQ.87) THEN
    +
    1040 DO 195 i = 1,18
    +
    1041 igds(i) = grd87(i)
    +
    1042 195 CONTINUE
    +
    1043C
    +
    1044 ELSE IF (igrid.EQ.88) THEN
    +
    1045 DO 2195 i = 1,18
    +
    1046 igds(i) = grd88(i)
    +
    10472195 CONTINUE
    +
    1048C
    +
    1049 ELSE IF (igrid.EQ.90) THEN
    +
    1050 DO 196 i = 1,18
    +
    1051 igds(i) = grd90(i)
    +
    1052 196 CONTINUE
    +
    1053C
    +
    1054 ELSE IF (igrid.EQ.91) THEN
    +
    1055 DO 197 i = 1,18
    +
    1056 igds(i) = grd91(i)
    +
    1057 197 CONTINUE
    +
    1058C
    +
    1059 ELSE IF (igrid.EQ.92) THEN
    +
    1060 DO 198 i = 1,18
    +
    1061 igds(i) = grd92(i)
    +
    1062 198 CONTINUE
    +
    1063C
    +
    1064 ELSE IF (igrid.EQ.93) THEN
    +
    1065 DO 199 i = 1,18
    +
    1066 igds(i) = grd93(i)
    +
    1067 199 CONTINUE
    +
    1068C
    +
    1069 ELSE IF (igrid.EQ.94) THEN
    +
    1070 DO 200 i = 1,18
    +
    1071 igds(i) = grd94(i)
    +
    1072 200 CONTINUE
    +
    1073C
    +
    1074 ELSE IF (igrid.EQ.95) THEN
    +
    1075 DO 201 i = 1,18
    +
    1076 igds(i) = grd95(i)
    +
    1077 201 CONTINUE
    +
    1078C
    +
    1079 ELSE IF (igrid.EQ.96) THEN
    +
    1080 DO 202 i = 1,18
    +
    1081 igds(i) = grd96(i)
    +
    1082 202 CONTINUE
    +
    1083C
    +
    1084 ELSE IF (igrid.EQ.97) THEN
    +
    1085 DO 203 i = 1,18
    +
    1086 igds(i) = grd97(i)
    +
    1087 203 CONTINUE
    +
    1088C
    +
    1089 ELSE IF (igrid.EQ.98) THEN
    +
    1090 DO 204 i = 1,18
    +
    1091 igds(i) = grd98(i)
    +
    1092 204 CONTINUE
    +
    1093C
    +
    1094 ELSE IF (igrid.EQ.99) THEN
    +
    1095 DO i = 1,18
    +
    1096 igds(i) = grd99(i)
    +
    1097 ENDDO
    +
    1098C
    +
    1099 ELSE IF (igrid.EQ.100) THEN
    +
    1100 DO 205 i = 1,18
    +
    1101 igds(i) = grd100(i)
    +
    1102 205 CONTINUE
    +
    1103C
    +
    1104 ELSE IF (igrid.EQ.101) THEN
    +
    1105 DO 210 i = 1,18
    +
    1106 igds(i) = grd101(i)
    +
    1107 210 CONTINUE
    +
    1108C
    +
    1109 ELSE IF (igrid.EQ.103) THEN
    +
    1110 DO 220 i = 1,18
    +
    1111 igds(i) = grd103(i)
    +
    1112 220 CONTINUE
    +
    1113C
    +
    1114 ELSE IF (igrid.EQ.104) THEN
    +
    1115 DO 230 i = 1,18
    +
    1116 igds(i) = grd104(i)
    +
    1117 230 CONTINUE
    +
    1118C
    +
    1119 ELSE IF (igrid.EQ.105) THEN
    +
    1120 DO 240 i = 1,18
    +
    1121 igds(i) = grd105(i)
    +
    1122 240 CONTINUE
    +
    1123C
    +
    1124 ELSE IF (igrid.EQ.106) THEN
    +
    1125 DO 242 i = 1,18
    +
    1126 igds(i) = grd106(i)
    +
    1127 242 CONTINUE
    +
    1128C
    +
    1129 ELSE IF (igrid.EQ.107) THEN
    +
    1130 DO 244 i = 1,18
    +
    1131 igds(i) = grd107(i)
    +
    1132 244 CONTINUE
    +
    1133C
    +
    1134 ELSE IF (igrid.EQ.110) THEN
    +
    1135 DO i = 1,18
    +
    1136 igds(i) = grd110(i)
    +
    1137 ENDDO
    +
    1138C
    +
    1139 ELSE IF (igrid.EQ.120) THEN
    +
    1140 DO i = 1,18
    +
    1141 igds(i) = grd120(i)
    +
    1142 ENDDO
    +
    1143C
    +
    1144 ELSE IF (igrid.EQ.122) THEN
    +
    1145 DO i = 1,18
    +
    1146 igds(i) = grd122(i)
    +
    1147 ENDDO
    +
    1148C
    +
    1149 ELSE IF (igrid.EQ.123) THEN
    +
    1150 DO i = 1,18
    +
    1151 igds(i) = grd123(i)
    +
    1152 ENDDO
    +
    1153C
    +
    1154 ELSE IF (igrid.EQ.124) THEN
    +
    1155 DO i = 1,18
    +
    1156 igds(i) = grd124(i)
    +
    1157 ENDDO
    +
    1158C
    +
    1159 ELSE IF (igrid.EQ.125) THEN
    +
    1160 DO i = 1,18
    +
    1161 igds(i) = grd125(i)
    +
    1162 ENDDO
    +
    1163C
    +
    1164 ELSE IF (igrid.EQ.126) THEN
    +
    1165 DO 245 i = 1,18
    +
    1166 igds(i) = grd126(i)
    +
    1167 245 CONTINUE
    +
    1168C
    +
    1169 ELSE IF (igrid.EQ.127) THEN
    +
    1170 DO i = 1,18
    +
    1171 igds(i) = grd127(i)
    +
    1172 ENDDO
    +
    1173C
    +
    1174 ELSE IF (igrid.EQ.128) THEN
    +
    1175 DO i = 1,18
    +
    1176 igds(i) = grd128(i)
    +
    1177 ENDDO
    +
    1178C
    +
    1179 ELSE IF (igrid.EQ.129) THEN
    +
    1180 DO i = 1,18
    +
    1181 igds(i) = grd129(i)
    +
    1182 ENDDO
    +
    1183C
    +
    1184 ELSE IF (igrid.EQ.130) THEN
    +
    1185 DO i = 1,18
    +
    1186 igds(i) = grd130(i)
    +
    1187 ENDDO
    +
    1188C
    +
    1189 ELSE IF (igrid.EQ.132) THEN
    +
    1190 DO i = 1,18
    +
    1191 igds(i) = grd132(i)
    +
    1192 ENDDO
    +
    1193C
    +
    1194 ELSE IF (igrid.EQ.138) THEN
    +
    1195 DO i = 1,18
    +
    1196 igds(i) = grd138(i)
    +
    1197 ENDDO
    +
    1198C
    +
    1199 ELSE IF (igrid.EQ.139) THEN
    +
    1200 DO i = 1,18
    +
    1201 igds(i) = grd139(i)
    +
    1202 ENDDO
    +
    1203C
    +
    1204 ELSE IF (igrid.EQ.140) THEN
    +
    1205 DO i = 1,18
    +
    1206 igds(i) = grd140(i)
    +
    1207 ENDDO
    +
    1208C
    +
    1209 ELSE IF (igrid.EQ.145) THEN
    +
    1210 DO i = 1,18
    +
    1211 igds(i) = grd145(i)
    +
    1212 ENDDO
    +
    1213C
    +
    1214 ELSE IF (igrid.EQ.146) THEN
    +
    1215 DO i = 1,18
    +
    1216 igds(i) = grd146(i)
    +
    1217 ENDDO
    +
    1218C
    +
    1219 ELSE IF (igrid.EQ.147) THEN
    +
    1220 DO i = 1,18
    +
    1221 igds(i) = grd147(i)
    +
    1222 ENDDO
    +
    1223C
    +
    1224 ELSE IF (igrid.EQ.148) THEN
    +
    1225 DO i = 1,18
    +
    1226 igds(i) = grd148(i)
    +
    1227 ENDDO
    +
    1228C
    +
    1229 ELSE IF (igrid.EQ.150) THEN
    +
    1230 DO i = 1,18
    +
    1231 igds(i) = grd150(i)
    +
    1232 ENDDO
    +
    1233C
    +
    1234 ELSE IF (igrid.EQ.151) THEN
    +
    1235 DO i = 1,18
    +
    1236 igds(i) = grd151(i)
    +
    1237 ENDDO
    +
    1238C
    +
    1239 ELSE IF (igrid.EQ.160) THEN
    +
    1240 DO i = 1,18
    +
    1241 igds(i) = grd160(i)
    +
    1242 ENDDO
    +
    1243C
    +
    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
    +
    1252C
    +
    1253 ELSE IF (igrid.EQ.170) THEN
    +
    1254 DO i = 1,18
    +
    1255 igds(i) = grd170(i)
    +
    1256 ENDDO
    +
    1257C
    +
    1258 ELSE IF (igrid.EQ.171) THEN
    +
    1259 DO i = 1,18
    +
    1260 igds(i) = grd171(i)
    +
    1261 ENDDO
    +
    1262C
    +
    1263 ELSE IF (igrid.EQ.172) THEN
    +
    1264 DO i = 1,18
    +
    1265 igds(i) = grd172(i)
    +
    1266 ENDDO
    +
    1267C
    +
    1268 ELSE IF (igrid.EQ.173) THEN
    +
    1269 DO i = 1,18
    +
    1270 igds(i) = grd173(i)
    +
    1271 ENDDO
    +
    1272C
    +
    1273 ELSE IF (igrid.EQ.174) THEN
    +
    1274 DO i = 1,18
    +
    1275 igds(i) = grd174(i)
    +
    1276 ENDDO
    +
    1277C
    +
    1278 ELSE IF (igrid.EQ.175) THEN
    +
    1279 DO i = 1,18
    +
    1280 igds(i) = grd175(i)
    +
    1281 ENDDO
    +
    1282C
    +
    1283 ELSE IF (igrid.EQ.176) THEN
    +
    1284 DO i = 1,18
    +
    1285 igds(i) = grd176(i)
    +
    1286 ENDDO
    +
    1287C
    +
    1288 ELSE IF (igrid.EQ.179) THEN
    +
    1289 DO i = 1,18
    +
    1290 igds(i) = grd179(i)
    +
    1291 ENDDO
    +
    1292C
    +
    1293 ELSE IF (igrid.EQ.180) THEN
    +
    1294 DO i = 1,18
    +
    1295 igds(i) = grd180(i)
    +
    1296 ENDDO
    +
    1297C
    +
    1298 ELSE IF (igrid.EQ.181) THEN
    +
    1299 DO i = 1,18
    +
    1300 igds(i) = grd181(i)
    +
    1301 ENDDO
    +
    1302C
    +
    1303 ELSE IF (igrid.EQ.182) THEN
    +
    1304 DO i = 1,18
    +
    1305 igds(i) = grd182(i)
    +
    1306 ENDDO
    +
    1307C
    +
    1308 ELSE IF (igrid.EQ.183) THEN
    +
    1309 DO i = 1,18
    +
    1310 igds(i) = grd183(i)
    +
    1311 ENDDO
    +
    1312C
    +
    1313 ELSE IF (igrid.EQ.184) THEN
    +
    1314 DO i = 1,18
    +
    1315 igds(i) = grd184(i)
    +
    1316 ENDDO
    +
    1317C
    +
    1318 ELSE IF (igrid.EQ.187) THEN
    +
    1319 DO i = 1,18
    +
    1320 igds(i) = grd187(i)
    +
    1321 ENDDO
    +
    1322C
    +
    1323 ELSE IF (igrid.EQ.188) THEN
    +
    1324 DO i = 1,18
    +
    1325 igds(i) = grd188(i)
    +
    1326 ENDDO
    +
    1327C
    +
    1328 ELSE IF (igrid.EQ.189) THEN
    +
    1329 DO i = 1,18
    +
    1330 igds(i) = grd189(i)
    +
    1331 ENDDO
    +
    1332C
    +
    1333 ELSE IF (igrid.EQ.190) THEN
    +
    1334 DO 2190 i = 1,18
    +
    1335 igds(i) = grd190(i)
    +
    1336 2190 CONTINUE
    +
    1337C
    +
    1338 ELSE IF (igrid.EQ.192) THEN
    +
    1339 DO 2191 i = 1,18
    +
    1340 igds(i) = grd192(i)
    +
    1341 2191 CONTINUE
    +
    1342C
    +
    1343 ELSE IF (igrid.EQ.193) THEN
    +
    1344 DO i = 1,18
    +
    1345 igds(i) = grd193(i)
    +
    1346 END DO
    +
    1347C
    +
    1348 ELSE IF (igrid.EQ.194) THEN
    +
    1349 DO 2192 i = 1,18
    +
    1350 igds(i) = grd194(i)
    +
    1351 2192 CONTINUE
    +
    1352C
    +
    1353 ELSE IF (igrid.EQ.195) THEN
    +
    1354 DO i = 1,18
    +
    1355 igds(i) = grd195(i)
    +
    1356 END DO
    +
    1357C
    +
    1358 ELSE IF (igrid.EQ.196) THEN
    +
    1359 DO 249 i = 1,18
    +
    1360 igds(i) = grd196(i)
    +
    1361 249 CONTINUE
    +
    1362C
    +
    1363 ELSE IF (igrid.EQ.197) THEN
    +
    1364 DO i = 1,18
    +
    1365 igds(i) = grd197(i)
    +
    1366 END DO
    +
    1367C
    +
    1368 ELSE IF (igrid.EQ.198) THEN
    +
    1369 DO 2490 i = 1,18
    +
    1370 igds(i) = grd198(i)
    +
    1371 2490 CONTINUE
    +
    1372C
    +
    1373 ELSE IF (igrid.EQ.199) THEN
    +
    1374 DO i = 1,18
    +
    1375 igds(i) = grd199(i)
    +
    1376 END DO
    +
    1377C
    +
    1378 ELSE IF (igrid.EQ.200) THEN
    +
    1379 DO i = 1,18
    +
    1380 igds(i) = grd200(i)
    +
    1381 END DO
    +
    1382C
    +
    1383 ELSE IF (igrid.EQ.201) THEN
    +
    1384 DO 250 i = 1,18
    +
    1385 igds(i) = grd201(i)
    +
    1386 250 CONTINUE
    +
    1387C
    +
    1388 ELSE IF (igrid.EQ.202) THEN
    +
    1389 DO 260 i = 1,18
    +
    1390 igds(i) = grd202(i)
    +
    1391 260 CONTINUE
    +
    1392C
    +
    1393 ELSE IF (igrid.EQ.203) THEN
    +
    1394 DO 270 i = 1,18
    +
    1395 igds(i) = grd203(i)
    +
    1396 270 CONTINUE
    +
    1397C
    +
    1398 ELSE IF (igrid.EQ.204) THEN
    +
    1399 DO 280 i = 1,18
    +
    1400 igds(i) = grd204(i)
    +
    1401 280 CONTINUE
    +
    1402C
    +
    1403 ELSE IF (igrid.EQ.205) THEN
    +
    1404 DO 290 i = 1,18
    +
    1405 igds(i) = grd205(i)
    +
    1406 290 CONTINUE
    +
    1407C
    +
    1408 ELSE IF (igrid.EQ.206) THEN
    +
    1409 DO 300 i = 1,18
    +
    1410 igds(i) = grd206(i)
    +
    1411 300 CONTINUE
    +
    1412C
    +
    1413 ELSE IF (igrid.EQ.207) THEN
    +
    1414 DO 310 i = 1,18
    +
    1415 igds(i) = grd207(i)
    +
    1416 310 CONTINUE
    +
    1417C
    +
    1418 ELSE IF (igrid.EQ.208) THEN
    +
    1419 DO 320 i = 1,18
    +
    1420 igds(i) = grd208(i)
    +
    1421 320 CONTINUE
    +
    1422C
    +
    1423 ELSE IF (igrid.EQ.209) THEN
    +
    1424 DO 330 i = 1,18
    +
    1425 igds(i) = grd209(i)
    +
    1426 330 CONTINUE
    +
    1427C
    +
    1428 ELSE IF (igrid.EQ.210) THEN
    +
    1429 DO 340 i = 1,18
    +
    1430 igds(i) = grd210(i)
    +
    1431 340 CONTINUE
    +
    1432C
    +
    1433 ELSE IF (igrid.EQ.211) THEN
    +
    1434 DO 350 i = 1,18
    +
    1435 igds(i) = grd211(i)
    +
    1436 350 CONTINUE
    +
    1437C
    +
    1438 ELSE IF (igrid.EQ.212) THEN
    +
    1439 DO 360 i = 1,18
    +
    1440 igds(i) = grd212(i)
    +
    1441 360 CONTINUE
    +
    1442C
    +
    1443 ELSE IF (igrid.EQ.213) THEN
    +
    1444 DO 370 i = 1,18
    +
    1445 igds(i) = grd213(i)
    +
    1446 370 CONTINUE
    +
    1447C
    +
    1448 ELSE IF (igrid.EQ.214) THEN
    +
    1449 DO 380 i = 1,18
    +
    1450 igds(i) = grd214(i)
    +
    1451 380 CONTINUE
    +
    1452C
    +
    1453 ELSE IF (igrid.EQ.215) THEN
    +
    1454 DO 390 i = 1,18
    +
    1455 igds(i) = grd215(i)
    +
    1456 390 CONTINUE
    +
    1457C
    +
    1458 ELSE IF (igrid.EQ.216) THEN
    +
    1459 DO 400 i = 1,18
    +
    1460 igds(i) = grd216(i)
    +
    1461 400 CONTINUE
    +
    1462C
    +
    1463 ELSE IF (igrid.EQ.217) THEN
    +
    1464 DO 401 i = 1,18
    +
    1465 igds(i) = grd217(i)
    +
    1466 401 CONTINUE
    +
    1467C
    +
    1468 ELSE IF (igrid.EQ.218) THEN
    +
    1469 DO 410 i = 1,18
    +
    1470 igds(i) = grd218(i)
    +
    1471 410 CONTINUE
    +
    1472C
    +
    1473 ELSE IF (igrid.EQ.219) THEN
    +
    1474 DO 411 i = 1,18
    +
    1475 igds(i) = grd219(i)
    +
    1476 411 CONTINUE
    +
    1477C
    +
    1478 ELSE IF (igrid.EQ.220) THEN
    +
    1479 DO 412 i = 1,18
    +
    1480 igds(i) = grd220(i)
    +
    1481 412 CONTINUE
    +
    1482C
    +
    1483 ELSE IF (igrid.EQ.221) THEN
    +
    1484 DO 413 i = 1,18
    +
    1485 igds(i) = grd221(i)
    +
    1486 413 CONTINUE
    +
    1487C
    +
    1488 ELSE IF (igrid.EQ.222) THEN
    +
    1489 DO 414 i = 1,18
    +
    1490 igds(i) = grd222(i)
    +
    1491 414 CONTINUE
    +
    1492C
    +
    1493 ELSE IF (igrid.EQ.223) THEN
    +
    1494 DO 415 i = 1,18
    +
    1495 igds(i) = grd223(i)
    +
    1496 415 CONTINUE
    +
    1497C
    +
    1498 ELSE IF (igrid.EQ.224) THEN
    +
    1499 DO 416 i = 1,18
    +
    1500 igds(i) = grd224(i)
    +
    1501 416 CONTINUE
    +
    1502C
    +
    1503 ELSE IF (igrid.EQ.225) THEN
    +
    1504 DO 417 i = 1,18
    +
    1505 igds(i) = grd225(i)
    +
    1506 417 CONTINUE
    +
    1507C
    +
    1508 ELSE IF (igrid.EQ.226) THEN
    +
    1509 DO 418 i = 1,18
    +
    1510 igds(i) = grd226(i)
    +
    1511 418 CONTINUE
    +
    1512C
    +
    1513 ELSE IF (igrid.EQ.227) THEN
    +
    1514 DO 419 i = 1,18
    +
    1515 igds(i) = grd227(i)
    +
    1516 419 CONTINUE
    +
    1517C
    +
    1518 ELSE IF (igrid.EQ.228) THEN
    +
    1519 DO 420 i = 1,18
    +
    1520 igds(i) = grd228(i)
    +
    1521 420 CONTINUE
    +
    1522C
    +
    1523 ELSE IF (igrid.EQ.229) THEN
    +
    1524 DO 421 i = 1,18
    +
    1525 igds(i) = grd229(i)
    +
    1526 421 CONTINUE
    +
    1527C
    +
    1528 ELSE IF (igrid.EQ.230) THEN
    +
    1529 DO 422 i = 1,18
    +
    1530 igds(i) = grd230(i)
    +
    1531 422 CONTINUE
    +
    1532C
    +
    1533 ELSE IF (igrid.EQ.231) THEN
    +
    1534 DO 423 i = 1,18
    +
    1535 igds(i) = grd231(i)
    +
    1536 423 CONTINUE
    +
    1537C
    +
    1538 ELSE IF (igrid.EQ.232) THEN
    +
    1539 DO 424 i = 1,18
    +
    1540 igds(i) = grd232(i)
    +
    1541 424 CONTINUE
    +
    1542C
    +
    1543 ELSE IF (igrid.EQ.233) THEN
    +
    1544 DO 425 i = 1,18
    +
    1545 igds(i) = grd233(i)
    +
    1546 425 CONTINUE
    +
    1547C
    +
    1548 ELSE IF (igrid.EQ.234) THEN
    +
    1549 DO 426 i = 1,18
    +
    1550 igds(i) = grd234(i)
    +
    1551 426 CONTINUE
    +
    1552C
    +
    1553 ELSE IF (igrid.EQ.235) THEN
    +
    1554 DO 427 i = 1,18
    +
    1555 igds(i) = grd235(i)
    +
    1556 427 CONTINUE
    +
    1557C
    +
    1558 ELSE IF (igrid.EQ.236) THEN
    +
    1559 DO 428 i = 1,18
    +
    1560 igds(i) = grd236(i)
    +
    1561 428 CONTINUE
    +
    1562C
    +
    1563 ELSE IF (igrid.EQ.237) THEN
    +
    1564 DO 429 i = 1,18
    +
    1565 igds(i) = grd237(i)
    +
    1566 429 CONTINUE
    +
    1567C
    +
    1568 ELSE IF (igrid.EQ.238) THEN
    +
    1569 DO i = 1,18
    +
    1570 igds(i) = grd238(i)
    +
    1571 END DO
    +
    1572C
    +
    1573 ELSE IF (igrid.EQ.239) THEN
    +
    1574 DO i = 1,18
    +
    1575 igds(i) = grd239(i)
    +
    1576 END DO
    +
    1577C
    +
    1578 ELSE IF (igrid.EQ.240) THEN
    +
    1579 DO i = 1,18
    +
    1580 igds(i) = grd240(i)
    +
    1581 END DO
    +
    1582C
    +
    1583 ELSE IF (igrid.EQ.241) THEN
    +
    1584 DO 430 i = 1,18
    +
    1585 igds(i) = grd241(i)
    +
    1586 430 CONTINUE
    +
    1587C
    +
    1588 ELSE IF (igrid.EQ.242) THEN
    +
    1589 DO 431 i = 1,18
    +
    1590 igds(i) = grd242(i)
    +
    1591 431 CONTINUE
    +
    1592C
    +
    1593 ELSE IF (igrid.EQ.243) THEN
    +
    1594 DO 432 i = 1,18
    +
    1595 igds(i) = grd243(i)
    +
    1596 432 CONTINUE
    +
    1597C
    +
    1598 ELSE IF (igrid.EQ.244) THEN
    +
    1599 DO i = 1,18
    +
    1600 igds(i) = grd244(i)
    +
    1601 END DO
    +
    1602C
    +
    1603 ELSE IF (igrid.EQ.245) THEN
    +
    1604 DO 433 i = 1,18
    +
    1605 igds(i) = grd245(i)
    +
    1606 433 CONTINUE
    +
    1607C
    +
    1608 ELSE IF (igrid.EQ.246) THEN
    +
    1609 DO 434 i = 1,18
    +
    1610 igds(i) = grd246(i)
    +
    1611 434 CONTINUE
    +
    1612C
    +
    1613 ELSE IF (igrid.EQ.247) THEN
    +
    1614 DO 435 i = 1,18
    +
    1615 igds(i) = grd247(i)
    +
    1616 435 CONTINUE
    +
    1617C
    +
    1618 ELSE IF (igrid.EQ.248) THEN
    +
    1619 DO 436 i = 1,18
    +
    1620 igds(i) = grd248(i)
    +
    1621 436 CONTINUE
    +
    1622C
    +
    1623 ELSE IF (igrid.EQ.249) THEN
    +
    1624 DO 437 i = 1,18
    +
    1625 igds(i) = grd249(i)
    +
    1626 437 CONTINUE
    +
    1627C
    +
    1628 ELSE IF (igrid.EQ.250) THEN
    +
    1629 DO 438 i = 1,18
    +
    1630 igds(i) = grd250(i)
    +
    1631 438 CONTINUE
    +
    1632C
    +
    1633 ELSE IF (igrid.EQ.251) THEN
    +
    1634 DO 439 i = 1,18
    +
    1635 igds(i) = grd251(i)
    +
    1636 439 CONTINUE
    +
    1637C
    +
    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
    +
    1650C
    +
    1651 ELSE
    +
    1652 ierr = 1
    +
    1653 ENDIF
    +
    1654C
    +
    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/w3fi72_8f.html b/w3fi72_8f.html index 1d91e9c5..b03ec9d2 100644 --- a/w3fi72_8f.html +++ b/w3fi72_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi72.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi72.f File Reference
    +
    w3fi72.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Make a complete GRIB message.

    @@ -107,8 +113,8 @@

    Definition in file w3fi72.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi72()

    + +

    ◆ w3fi72()

    @@ -117,115 +123,115 @@

    subroutine w3fi72 (   - ITYPE, + itype, real, dimension(*)  - FLD, + fld, integer, dimension(*)  - IFLD, + ifld,   - IBITL, + ibitl,   - IPFLAG, + ipflag, integer, dimension(*)  - ID, + id, character * 1, dimension(*)  - PDS, + pds,   - IGFLAG, + igflag,   - IGRID, + igrid, integer, dimension(*)  - IGDS, + igds,   - ICOMP, + icomp,   - IBFLAG, + ibflag, integer, dimension(*)  - IBMAP, + ibmap,   - IBLEN, + iblen, integer, dimension(*)  - IBDSFL, + ibdsfl,   - NPTS, + npts, character * 1, dimension(*)  - KBUF, + kbuf,   - ITOT, + itot,   - JERR  + jerr  @@ -236,7 +242,7 @@

    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.

    +

    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
    - + - + - + - + - + - + @@ -161,7 +167,7 @@

    Note
    Subprogram can be called from a multiprocessing environment.
    Parameters

    [in]ITYPE
      @@ -247,8 +253,8 @@

      [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.
      • +
    • 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
      @@ -259,10 +265,10 @@

      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.
      +
      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
      - + + - + - + - + - + - + - + @@ -191,7 +197,7 @@

      diff --git a/w3fi73_8f.js b/w3fi73_8f.js index c4d107f6..0a03cb0f 100644 --- a/w3fi73_8f.js +++ b/w3fi73_8f.js @@ -1,4 +1,4 @@ var w3fi73_8f = [ - [ "w3fi73", "w3fi73_8f.html#a89eedc9b7ba4fd46b1f6ac9eba1f773e", null ] + [ "w3fi73", "w3fi73_8f.html#a16b6fc47763b666ed5c21c66e65b0e63", null ] ]; \ No newline at end of file diff --git a/w3fi73_8f_source.html b/w3fi73_8f_source.html index 6306e0f4..fcf2844b 100644 --- a/w3fi73_8f_source.html +++ b/w3fi73_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi73.f Source File @@ -23,10 +23,9 @@

      [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]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.
        • @@ -274,7 +280,7 @@

        [in]

      		IGDSInteger array containing user gds info (same format as supplied by w3fi71() - see dockblock for layout) if igflag=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
        • @@ -367,7 +373,7 @@

        diff --git a/w3fi72_8f.js b/w3fi72_8f.js index 324a160a..82df185a 100644 --- a/w3fi72_8f.js +++ b/w3fi72_8f.js @@ -1,4 +1,4 @@ var w3fi72_8f = [ - [ "w3fi72", "w3fi72_8f.html#aaac6e022f341c919316466672ef3e70c", null ] + [ "w3fi72", "w3fi72_8f.html#af30a5edb120c0910beafc6ee46d1f3c5", null ] ]; \ No newline at end of file diff --git a/w3fi72_8f_source.html b/w3fi72_8f_source.html index 2d8362d4..f73f1ac8 100644 --- a/w3fi72_8f_source.html +++ b/w3fi72_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi72.f Source File @@ -23,10 +23,9 @@
        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ + +
        @@ -76,430 +81,438 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3fi72.f
        +
        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
        -
        lengds
        function lengds(KGDS)
        Program history log:
        Definition: lengds.f:15
        -
        mova2i
        integer function mova2i(a)
        This Function copies a bit string from a Character*1 variable to an integer variable.
        Definition: mova2i.f:25
        -
        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
        -
        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
        -
        w3fi73
        subroutine w3fi73(IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
        This subroutine constructs a grib bit map section.
        Definition: w3fi73.f:23
        -
        w3fi74
        subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
        This subroutine constructs a GRIB grid definition section.
        Definition: w3fi74.f:19
        -
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Make a complete GRIB message.
        +
        3C> @author Ralph Jones @date 1991-05-08
        +
        4
        +
        5C> Makes a complete GRIB message from a user supplied
        +
        6C> array of floating point or integer data. The user has the
        +
        7C> option of supplying the PDS or an integer array that will be
        +
        8C> used to create a PDS (with w3fi68()). The user must also
        +
        9C> supply other necessary information.
        +
        10C>
        +
        11C> @param[in] ITYPE
        +
        12C> - 0 = Floating point data supplied in array 'fld'
        +
        13C> - 1 = Integer data supplied in array 'ifld'
        +
        14C> @param[in] FLD Real array of data (at proper gridpoints) to be
        +
        15C> converted to grib format if itype=0.
        +
        16C> see remarks #1 & 2.
        +
        17C> @param[in] IFLD Integer array of data (at proper gridpoints) to be
        +
        18C> converted to grib format if itype=1. See remarks #1 & 2.
        +
        19C> @param[in] IBITL
        +
        20C> - 0 = Computer computes length for packing data from
        +
        21C> power of 2 (number of bits) best fit of data
        +
        22C> using 'variable' bit packer w3fi58().
        +
        23C> - 8, 12, Etc. computer rescales data to fit into that
        +
        24C> 'fixed' number of bits using w3fi59(). See remarks #3.
        +
        25C> @param[in] IPFLAG
        +
        26C> - 0 = Make pds from user supplied array (id)
        +
        27C> - 1 = User supplying pds
        +
        28C> @note If pds is greater than 30, use iplfag=1. The user could call w3fi68()
        +
        29C> before he calls w3fi72(). This would make the first 30 bytes of the pds,
        +
        30C> user then would make bytes after 30.
        +
        31C> @param[in] ID Integer array of values that w3fi68() will use
        +
        32C> to make an edition 1 pds if ipflag=0. (see the
        +
        33C> docblock for w3fi68() for layout of array)
        +
        34C> @param[in] PDS Character array of values (valid pds supplied
        +
        35C> by user) if ipflag=1. length may exceed 28 bytes
        +
        36C> (contents of bytes beyond 28 are passed
        +
        37C> through unchanged).
        +
        38C> @param[in] IGFLAG
        +
        39C> - 0 = Make gds based on 'igrid' value.
        +
        40C> - 1 = Make gds from user supplied info in 'igds' and 'igrid' value.
        +
        41C> See remarks #4.
        +
        42C> @param[in] IGRID
        +
        43C> - # = Grid identification (table b)
        +
        44C> - 255 = If user defined grid; igds must be supplied and igflag must =1.
        +
        45C> @param[in] IGDS Integer array containing user gds info (same
        +
        46C> format as supplied by w3fi71() - see dockblock for
        +
        47C> layout) if igflag=1.
        +
        48C> @param[in] ICOMP Resolution and component flag for bit 5 of gds(17)
        +
        49C> - 0 = Earth oriented winds
        +
        50C> - 1 = Grid oriented winds
        +
        51C> @param[in] IBFLAG
        +
        52C> - 0 = Make bit map from user supplied data
        +
        53C> - # = Bit map predefined by center. See remarks #5.
        +
        54C> @param[in] IBMAP Integer array containing bit map
        +
        55C> @param[in] IBLEN Length of bit map will be used to verify length
        +
        56C> of field (error if it doesn't match).
        +
        57C> @param[in] IBDSFL Integer array containing table 11 flag info
        +
        58C> - BDS octet 4:
        +
        59C> - (1)
        +
        60C> - 0 = Grid point data
        +
        61C> - 1 = Spherical harmonic coefficients
        +
        62C> - (2) 0 = Simple packing
        +
        63C> - 1 = Second order packing
        +
        64C> - (3) ... Same value as 'itype'
        +
        65C> - 0 = Original data were floating point values
        +
        66C> - 1 = Original data were integer values
        +
        67C> - (4) 0 = No additional flags at octet 14
        +
        68C> - 1 = Octet 14 contains flag bits 5-12
        +
        69C> - (5) 0 = Reserved - always set to 0
        +
        70C> Byte 6 option 1 not available (as of 5-16-93)
        +
        71C> - (6) 0 = Single datum at each grid point
        +
        72C> - 1 = Matrix of values at each grid point
        +
        73C> Byte 7 option 0 with second order packing n/a (as of 5-16-93)
        +
        74C> - (7) 0 = No secondary bit maps
        +
        75C> - 1 = Secondary bit maps present
        +
        76C> - (8) 0 = Second order values have constant width
        +
        77C> - 1 = Second order values have different widths
        +
        78C> @param[out] NPTS Number of gridpoints in array fld or ifld
        +
        79C> @param[out] KBUF Entire grib message ('grib' to '7777')
        +
        80C> equivalence to integer array to make sure it is on word boundary.
        +
        81C> @param[out] ITOT Total length of grib message in bytes
        +
        82C> @param[out] JERR
        +
        83C> - = 0, Completed making grib field without error
        +
        84C> - = 1, Ipflag not 0 or 1
        +
        85C> - = 2, Igflag not 0 or 1
        +
        86C> - = 3, Error converting ieee f.p. number to ibm370 f.p.
        +
        87C> - = 4, W3fi71() error/igrid not defined
        +
        88C> - = 5, W3fk74() error/grid representation type not valid
        +
        89C> - = 6, Grid too large for packer dimension arrays
        +
        90C> - = See automation division for revision!
        +
        91C> - = 7, Length of bit map not equal to size of fld/ifld
        +
        92C> - = 8, W3fi73() error, all values in ibmap are zero
        +
        93C>
        +
        94C> @note
        +
        95C> - 1: If bit map to be included in message, null data should
        +
        96C> be included in fld or ifld. this routine will take care
        +
        97C> of 'discarding' any null data based on the bit map.
        +
        98C> - 2: Units must be those in grib documentation: nmc o.n. 388
        +
        99C> or wmo publication 306.
        +
        100C> - 3: In either case, input numbers will be multiplied by
        +
        101C> '10 to the nth' power found in id(25) or pds(27-28),
        +
        102C> the d-scaling factor, prior to binary packing.
        +
        103C> - 4: All nmc produced grib fields will have a grid definition
        +
        104C> section included in the grib message. id(6) will be
        +
        105C> set to '1'.
        +
        106C> - GDS will be built based on grid number (igrid), unless
        +
        107C> igflag=1 (user supplying igds). user must still supply
        +
        108C> igrid even if igds provided.
        +
        109C> - 5: if bit map used then id(7) or pds(8) must indicate the
        +
        110C> presence of a bit map.
        +
        111C> - 6: Array kbuf should be equivalenced to an integer value or
        +
        112C> array to make sure it is on a word boundary.
        +
        113C> - 7: Subprogram can be called from a multiprocessing environment.
        +
        114C>
        +
        115C> @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)
        +
        121C
        +
        122 REAL FLD(*)
        +
        123C
        +
        124 INTEGER IBDSFL(*)
        +
        125 INTEGER IBMAP(*)
        +
        126 INTEGER ID(*)
        +
        127 INTEGER IFLD(*)
        +
        128 INTEGER IGDS(*)
        +
        129 INTEGER IB(4)
        +
        130 INTEGER NLEFT, NUMBMS
        +
        131C
        +
        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
        +
        141C
        +
        142C
        +
        143C ASCII REP OF /'G', 'R', 'I', 'B'/
        +
        144C
        +
        145 DATA ib / 71, 82, 73, 66/
        +
        146C
        +
        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
        +
        156C
        +
        157C$ 1.0 PRODUCT DEFINITION SECTION(PDS).
        +
        158C
        +
        159C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ...
        +
        160C REGARDLESS OF USER SPECIFICATION...
        +
        161C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS
        +
        162C
        +
        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
        +
        168C BOTH GDS AND BMS
        +
        169 pds(8) = char(192)
        +
        170 ELSE IF (mova2i(pds(8)) .EQ. 0) THEN
        +
        171C GDS ONLY
        +
        172 pds(8) = char(128)
        +
        173 END IF
        +
        174 CONTINUE
        +
        175 ELSE
        +
        176C PRINT *,' W3FI72 ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG
        +
        177 jerr = 1
        +
        178 GO TO 900
        +
        179 END IF
        +
        180C
        +
        181C GET LENGTH OF PDS
        +
        182C
        +
        183 ipdsl = mova2i(pds(1)) * 65536 + mova2i(pds(2)) * 256 +
        +
        184 & mova2i(pds(3))
        +
        185C
        +
        186C$ 2.0 GRID DEFINITION SECTION (GDS).
        +
        187C
        +
        188C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION
        +
        189C
        +
        190 IF (igflag .EQ. 0) THEN
        +
        191 CALL w3fi71(igrid,igds,igerr)
        +
        192 IF (igerr .EQ. 1) THEN
        +
        193C 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
        +
        201C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3)
        +
        202 jerr = 5
        +
        203 GO TO 900
        +
        204 ELSE
        +
        205 END IF
        +
        206 ELSE
        +
        207C PRINT *,' W3FI72 ERROR, IGFLAG IS NOT 0 OR 1 IGFLAG = ',IGFLAG
        +
        208 jerr = 2
        +
        209 GO TO 900
        +
        210 END IF
        +
        211C
        +
        212C$ 3.0 BIT MAP SECTION (BMS).
        +
        213C
        +
        214C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA
        +
        215C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE
        +
        216C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'.
        +
        217C
        +
        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
        +
        223C 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
        +
        238C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO'
        +
        239 jerr = 8
        +
        240 GO TO 900
        +
        241 END IF
        +
        242 ELSE
        +
        243C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG
        +
        244 END IF
        +
        245 END IF
        +
        246C
        +
        247C$ 4.0 BINARY DATA SECTION (BDS).
        +
        248C
        +
        249C$ 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28)
        +
        250C
        +
        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
        +
        265C
        +
        266C$ 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS.
        +
        267C
        +
        268 ALLOCATE(pfld(npts*4))
        +
        269C
        +
        270 IF(ibdsfl(2).NE.0) THEN
        +
        271 ALLOCATE(ipfld(npts*4))
        +
        272 ipfld=char(0)
        +
        273 ELSE
        +
        274 ALLOCATE(ipfld(1))
        +
        275 ENDIF
        +
        276C
        +
        277 CALL w3fi75(ibitl,itype,itoss,fld,ifld,ibmap,ibdsfl,
        +
        278 & npts,bds11,ipfld,pfld,len,lenbds,iberr,pds,igds)
        +
        279C
        +
        280 IF(ibdsfl(2).NE.0) THEN
        +
        281C CALL XMOVEX(PFLD,IPFLD,NPTS*4)
        +
        282 do ii = 1, npts*4
        +
        283 pfld(ii) = ipfld(ii)
        +
        284 enddo
        +
        285 ENDIF
        +
        286 DEALLOCATE(ipfld)
        +
        287C
        +
        288 IF (iberr .EQ. 1) THEN
        +
        289 jerr = 3
        +
        290 GO TO 900
        +
        291 END IF
        +
        292C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO
        +
        293C ORIGINAL VALUE
        +
        294C
        +
        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
        +
        307C
        +
        308C$ 5.0 OUTPUT SECTION.
        +
        309C
        +
        310C$ 5.1 ZERO OUT THE OUTPUT ARRAY KBUF.
        +
        311C
        +
        312 zero = char(00)
        +
        313 itot = igribl + ipdsl + lengds + lenbms + lenbds + 4
        +
        314C PRINT *,'IGRIBL =',IGRIBL
        +
        315C PRINT *,'IPDSL =',IPDSL
        +
        316C PRINT *,'LENGDS =',LENGDS
        +
        317C PRINT *,'LENBMS =',LENBMS
        +
        318C PRINT *,'LENBDS =',LENBDS
        +
        319C PRINT *,'ITOT =',ITOT
        +
        320 kbuf(1:itot)=zero
        +
        321C
        +
        322C$ 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES).
        +
        323C
        +
        324 istart = 0
        +
        325 DO 520 i = 1,4
        +
        326 kbuf(i) = char(ib(i))
        +
        327 520 CONTINUE
        +
        328C
        +
        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)
        +
        333C
        +
        334C$ 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES).
        +
        335C
        +
        336 istart = istart + igribl
        +
        337 IF (ipdsl.GT.0) THEN
        +
        338C CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL)
        +
        339 do ii = 1, ipdsl
        +
        340 kbuf(istart+ii) = pds(ii)
        +
        341 enddo
        +
        342 ELSE
        +
        343C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL
        +
        344 END IF
        +
        345C
        +
        346C$ 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF.
        +
        347C
        +
        348 istart = istart + ipdsl
        +
        349 IF (lengds .GT. 0) THEN
        +
        350C CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS)
        +
        351 do ii = 1, lengds
        +
        352 kbuf(istart+ii) = gds(ii)
        +
        353 enddo
        +
        354 END IF
        +
        355C
        +
        356C$ 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF.
        +
        357C
        +
        358 istart = istart + lengds
        +
        359 IF (lenbms .GT. 0) THEN
        +
        360C CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS)
        +
        361 do ii = 1, lenbms
        +
        362 kbuf(istart+ii) = bms(ii)
        +
        363 enddo
        +
        364 END IF
        +
        365C
        +
        366C$ 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF.
        +
        367C
        +
        368C$ MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF.
        +
        369C
        +
        370 istart = istart + lenbms
        +
        371C CALL XMOVEX(KBUF(ISTART+1),BDS11,11)
        +
        372 do ii = 1, 11
        +
        373 kbuf(istart+ii) = bds11(ii)
        +
        374 enddo
        +
        375C
        +
        376C$ MOVE THE PACKED DATA INTO THE KBUF
        +
        377C
        +
        378 istart = istart + 11
        +
        379 IF (len.GT.0) THEN
        +
        380C CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN)
        +
        381 do ii = 1, len
        +
        382 kbuf(istart+ii) = pfld(ii)
        +
        383 enddo
        +
        384 END IF
        +
        385C
        +
        386C$ ADD '7777' TO END OFF KBUF
        +
        387C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS.
        +
        388C
        +
        389 seven = char(55)
        +
        390 istart = itot - 4
        +
        391 DO 562 i = 1,4
        +
        392 kbuf(istart+i) = seven
        +
        393 562 CONTINUE
        +
        394C
        +
        395 900 CONTINUE
        +
        396 IF(ALLOCATED(bms)) DEALLOCATE(bms)
        +
        397 IF(ALLOCATED(pfld)) DEALLOCATE(pfld)
        +
        398 RETURN
        +
        +
        399 END
        +
        lengds
        function lengds(kgds)
        Program history log:
        Definition lengds.f:15
        +
        mova2i
        integer function mova2i(a)
        This Function copies a bit string from a Character*1 variable to an integer variable.
        Definition mova2i.f:25
        +
        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
        +
        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
        +
        w3fi73
        subroutine w3fi73(ibflag, ibmap, iblen, bms, lenbms, ier)
        This subroutine constructs a grib bit map section.
        Definition w3fi73.f:23
        +
        w3fi74
        subroutine w3fi74(igds, icomp, gds, lengds, npts, igerr)
        This subroutine constructs a GRIB grid definition section.
        Definition w3fi74.f:19
        +
        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
        diff --git a/w3fi73_8f.html b/w3fi73_8f.html index 75a37720..2e30f35d 100644 --- a/w3fi73_8f.html +++ b/w3fi73_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi73.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@
        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3fi73.f File Reference
        +
        w3fi73.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3fi73 (ibflag, ibmap, iblen, bms, lenbms, ier)
         This subroutine constructs a grib bit map section.
         

        Detailed Description

        Construct grib bit map section (BMS).

        @@ -107,8 +113,8 @@

        Definition in file w3fi73.f.

        Function/Subroutine Documentation

        - -

        ◆ w3fi73()

        + +

        ◆ w3fi73()

        @@ -117,37 +123,37 @@

        subroutine w3fi73

      		( integer IBFLAG, ibflag,
      integer, dimension(*) IBMAP, ibmap,
      integer IBLEN, iblen,
      character*1, dimension(*) BMS, bms,
      integer LENBMS, lenbms,
       IER ier 
      - - + @@ -34,22 +33,28 @@
      -
      NCEPLIBS-w3emc -  2.11.0 +
      +
      NCEPLIBS-w3emc 2.11.0
      - + +/* @license-end */ + +
      @@ -76,114 +81,122 @@
      - +
      +
      +
      +
      +
      Loading...
      +
      Searching...
      +
      No Matches
      +
      +
      +
      -
      -
      w3fi73.f
      +
      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 in bytes.
      -
      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
      -
      sbytec
      subroutine sbytec(OUT, IN, ISKIP, NBYTE)
      This is a wrapper for sbytesc()
      Definition: sbytec.f:14
      -
      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
      -
      w3fi73
      subroutine w3fi73(IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
      This subroutine constructs a grib bit map section.
      Definition: w3fi73.f:23
      +Go to the documentation of this file.
      1C> @file
      +
      2C> @brief Construct grib bit map section (BMS).
      +
      3C> @author M. Farley @date 1992-07-01
      +
      4
      +
      5C> This subroutine constructs a grib bit map section.
      +
      6C>
      +
      7C> Program history log:
      +
      8C> - M. Farley 1992-07-01
      +
      9C> - Bill Cavanaugh 1994-02-14 Recoded
      +
      10C> - Ebisuzaki 1998-06-30 Linux port
      +
      11C>
      +
      12C> @param[in] IBFLAG
      +
      13C> - 0, if bit map supplied by user
      +
      14C> - #, Number of predefined center bit map
      +
      15C> @param[in] IBMAP Integer array containing user bit map.
      +
      16C> @param[in] IBLEN Length of bit map.
      +
      17C> @param[out] BMS Completed grib bit map section.
      +
      18C> @param[out] LENBMS Length of bit map section in bytes.
      +
      19C> @param[out] IER 0 normal exit, 8 = ibmap values are all zero.
      +
      20C>
      +
      21C> @author M. Farley @date 1992-07-01
      +
      +
      22 SUBROUTINE w3fi73 (IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER)
      +
      23C
      +
      24 INTEGER IBMAP(*)
      +
      25 INTEGER LENBMS
      +
      26 INTEGER IBLEN
      +
      27 INTEGER IBFLAG
      +
      28C
      +
      29 CHARACTER*1 BMS(*)
      +
      30C
      +
      31 ier = 0
      +
      32C
      +
      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
      +
      38C
      +
      39C AT THIS POINT ALL BIT MAP POSITIONS ARE ZERO
      +
      40C
      +
      41 ier = 8
      +
      42 RETURN
      +
      43 END IF
      +
      44C
      +
      45C BIT MAP IS A COMBINATION OF ONES AND ZEROS
      +
      46C OR BIT MAP ALL ONES
      +
      47C
      +
      48C CONSTRUCT BIT MAP FIELD OF BIT MAP SECTION
      +
      49C
      +
      50 CALL sbytesc(bms,ibmap,48,1,0,iblen)
      +
      51C
      +
      52 IF (mod(iblen,16).NE.0) THEN
      +
      53 nleft = 16 - mod(iblen,16)
      +
      54 ELSE
      +
      55 nleft = 0
      +
      56 END IF
      +
      57C
      +
      58 num = 6 + (iblen+nleft) / 8
      +
      59C
      +
      60C CONSTRUCT BMS FROM COLLECTED DATA
      +
      61C
      +
      62C SIZE INTO FIRST THREE BYTES
      +
      63C
      +
      64 CALL sbytec(bms,num,0,24)
      +
      65C NUMBER OF FILL BITS INTO BYTE 4
      +
      66 CALL sbytec(bms,nleft,24,8)
      +
      67C OCTET 5-6 TO CONTAIN INFO FROM IBFLAG
      +
      68 CALL sbytec(bms,ibflag,32,16)
      +
      69C
      +
      70C BIT MAP MAY BE ALL ONES OR A COMBINATION
      +
      71C OF ONES AND ZEROS
      +
      72C
      +
      73C ACTUAL BITS OF BIT MAP PLACED ALL READY
      +
      74C
      +
      75C INSTALL FILL POSITIONS IF NEEDED
      +
      76 IF (nleft.NE.0) THEN
      +
      77 nleft = 16 - nleft
      +
      78C ZERO FILL POSITIONS
      +
      79 CALL sbytec(bms,0,iblen+48,nleft)
      +
      80 END IF
      +
      81C
      +
      82C STORE NUM IN LENBMS (LENGTH OF BMS SECTION)
      +
      83C
      +
      84 lenbms = num
      +
      85C PRINT *,'W3FI73 - BMS LEN =',NUM,LENBMS
      +
      86C
      +
      87 RETURN
      +
      +
      88 END
      +
      sbytec
      subroutine sbytec(out, in, iskip, nbyte)
      This is a wrapper for sbytesc()
      Definition sbytec.f:14
      +
      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
      +
      w3fi73
      subroutine w3fi73(ibflag, ibmap, iblen, bms, lenbms, ier)
      This subroutine constructs a grib bit map section.
      Definition w3fi73.f:23
      diff --git a/w3fi74_8f.html b/w3fi74_8f.html index cf126534..10b2d41c 100644 --- a/w3fi74_8f.html +++ b/w3fi74_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi74.f File Reference @@ -23,10 +23,9 @@
      - - + @@ -34,21 +33,22 @@
      -
      NCEPLIBS-w3emc -  2.11.0 +
      +
      NCEPLIBS-w3emc 2.11.0
      - + +/* @license-end */ +
      @@ -62,7 +62,7 @@
      @@ -76,16 +76,22 @@
      - +
      +
      +
      +
      +
      Loading...
      +
      Searching...
      +
      No Matches
      +
      +
      +
      Functions/Subroutines
      -
      -
      w3fi74.f File Reference
      +
      w3fi74.f File Reference
      @@ -94,11 +100,11 @@

      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...
       
      subroutine w3fi74 (igds, icomp, gds, lengds, npts, igerr)
       This subroutine constructs a GRIB grid definition section.
       

      Detailed Description

      Construct Grid Definition Section (GDS).

      @@ -107,8 +113,8 @@

      Definition in file w3fi74.f.

      Function/Subroutine Documentation

      - -

      ◆ w3fi74()

      + +

      ◆ w3fi74()

      @@ -117,37 +123,37 @@

      subroutine w3fi74

    		( integer, dimension (*) IGDS, igds,
     ICOMP, icomp,
    character*1, dimension (*) GDS, gds,
     LENGDS, lengds,
     NPTS, npts,
     IGERR igerr 
    - + @@ -183,7 +189,7 @@

    diff --git a/w3fi74_8f.js b/w3fi74_8f.js index 32c1c1a7..440cc105 100644 --- a/w3fi74_8f.js +++ b/w3fi74_8f.js @@ -1,4 +1,4 @@ var w3fi74_8f = [ - [ "w3fi74", "w3fi74_8f.html#ab921a7e370356989116ba2ac3e429d61", null ] + [ "w3fi74", "w3fi74_8f.html#aa3d0542b1282d44be47215d59e6432dc", null ] ]; \ No newline at end of file diff --git a/w3fi74_8f_source.html b/w3fi74_8f_source.html index 9ad0a808..a7d2a4fd 100644 --- a/w3fi74_8f_source.html +++ b/w3fi74_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi74.f Source File @@ -23,10 +23,9 @@

    [in]IGDSInteger array supplied by w3fi71().
    [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.
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,425 +81,433 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi74.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Construct Grid Definition Section (GDS).
    +
    3C> @author M. Farley @date 1992-07-07
    +
    4
    +
    5C> This subroutine constructs a GRIB grid definition section.
    +
    6C>
    +
    7C> @note Subprogram can be called from a multiprocessing environment.
    +
    8C>
    +
    9C> @param[in] IGDS Integer array supplied by w3fi71().
    +
    10C> @param[in] ICOMP Table 7- resolution & component flag (bit 5)
    +
    11C> for gds(17) wind components.
    +
    12C> @param[out] GDS Completed grib grid definition section.
    +
    13C> @param[out] LENGDS Length of gds.
    +
    14C> @param[out] NPTS Number of points in grid.
    +
    15C> @param[out] IGERR 1, grid representation type not valid.
    +
    16C>
    +
    17C> @author M. Farley @date 1992-07-07
    +
    +
    18 SUBROUTINE w3fi74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
    +
    19C
    +
    20 INTEGER IGDS (*)
    +
    21C
    +
    22 CHARACTER*1 GDS (*)
    +
    23C
    +
    24 isum = 0
    +
    25 igerr = 0
    +
    26C
    +
    27C PRINT *,' '
    +
    28C PRINT *,'(W3FI74-IGDS = )'
    +
    29C PRINT *,(IGDS(I),I=1,18)
    +
    30C PRINT *,' '
    +
    31C
    +
    32C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3)
    +
    33C LENGDS = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON,
    +
    34C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS,
    +
    35C ROTATED LAT/LON E-STAGGER
    +
    36C LENGDS = 34 ROTATED LAT/LON A,B,C,D STAGGERS
    +
    37C LENGDS = 42 FOR MERCATOR, LAMBERT, TANGENT CONE
    +
    38C LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE
    +
    39C
    +
    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
    +
    46C
    +
    47C CORRECTION FOR GRIDS 37-44
    +
    48C
    +
    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
    +
    59C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID'
    +
    60 igerr = 1
    +
    61 RETURN
    +
    62 ENDIF
    +
    63C
    +
    64C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3
    +
    65C
    +
    66 gds(1) = char(mod(lengds/65536,256))
    +
    67 gds(2) = char(mod(lengds/ 256,256))
    +
    68 gds(3) = char(mod(lengds ,256))
    +
    69C
    +
    70C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS
    +
    71C OCTET 5 = PV, PL OR 255
    +
    72C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6)
    +
    73C
    +
    74 gds(4) = char(igds(1))
    +
    75 gds(5) = char(igds(2))
    +
    76 gds(6) = char(igds(3))
    +
    77C
    +
    78C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION
    +
    79C TYPE (TABLE 6)
    +
    80C
    +
    81C$$
    +
    82C PROCESS ROTATED LAT/LON A,B,C,D STAGGERS
    +
    83C
    +
    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))
    +
    142C
    +
    143C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA
    +
    144C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS
    +
    145C
    +
    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
    +
    226C
    +
    227C$$ PROCESS MERCATOR GRID TYPES
    +
    228C
    +
    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)
    +
    285C$$ 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)
    +
    337C$$ 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
    +
    380C PRINT 10,(GDS(IG),IG=1,32)
    +
    381C10 FORMAT (' GDS= ',32(1X,Z2.2))
    +
    382C
    +
    383C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING
    +
    384C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER
    +
    385C
    +
    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
    +
    392C
    +
    393C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS
    +
    394C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA)
    +
    395C
    +
    396 itemp = ishft(icomp,3)
    +
    397 gds(17) = char(ior(igds(8),itemp))
    +
    398C
    +
    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/w3fi75_8f.html b/w3fi75_8f.html index f0df0c8d..f92c85d6 100644 --- a/w3fi75_8f.html +++ b/w3fi75_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi75.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi75.f File Reference
    +
    w3fi75.f File Reference
    @@ -94,35 +100,35 @@

    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...
     
    subroutine fi7501 (iwork, ipfld, npts, ibdsfl, bds11, len, lenbds, pds, refnce, iscal2, kwide)
     BDS second order packing.
     
    subroutine fi7502 (iwork, istart, npts, isame)
     Second order same value collection.
     
    subroutine fi7503 (iwork, ipfld, npts, ibdsfl, bds11, len, lenbds, pds, refnce, iscal2, kwide, igds)
     Row by row, col by col packing.
     
    subroutine fi7505 (n, nbits)
     Determine number of bits to contain value.
     
    subroutine fi7513 (iwork, istart, npts, max, min, inrnge)
     Select block of data for packing.
     
    subroutine fi7516 (iwork, npts, inrng, istart, max, min, mxval, lwidth)
     Scan number of points.
     
    subroutine fi7517 (iret, iwork, npts, istrtb, inrnga, maxb, minb, mxvalb, lwideb)
     Scan backward.
     
    subroutine fi7518 (iret, iwork, npts, istrta, inrnga, inrngb, maxa, mina, lwidea, mxvala)
     Scan forward.
     
    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).
     

    Detailed Description

    GRIB pack data and form bds octets(1-11)

    @@ -131,8 +137,8 @@

    Definition in file w3fi75.f.

    Function/Subroutine Documentation

    - -

    ◆ fi7501()

    + +

    ◆ fi7501()

    @@ -141,67 +147,67 @@

    subroutine fi7501 ( integer, dimension(*)  - IWORK, + iwork, character(len=1), dimension(*)  - IPFLD, + ipfld,   - NPTS, + npts, integer, dimension(*)  - IBDSFL, + ibdsfl, character*1, dimension(*)  - BDS11, + bds11, integer  - LEN, + len, integer  - LENBDS, + lenbds, character*1, dimension(*)  - PDS, + pds, real  - REFNCE, + refnce, integer  - ISCAL2, + iscal2, integer  - KWIDE  + kwide  @@ -243,8 +249,8 @@

    -

    ◆ fi7502()

    + +

    ◆ fi7502()

    @@ -253,25 +259,25 @@

    subroutine fi7502 ( integer, dimension(*)  - IWORK, + iwork, integer  - ISTART, + istart, integer  - NPTS, + npts, integer  - ISAME  + isame  @@ -305,8 +311,8 @@

    -

    ◆ fi7503()

    + +

    ◆ fi7503()

    @@ -315,73 +321,73 @@

    subroutine fi7503 ( integer, dimension(*)  - IWORK, + iwork, character*1, dimension(*)  - IPFLD, + ipfld,   - NPTS, + npts, integer, dimension(*)  - IBDSFL, + ibdsfl, character*1, dimension(*)  - BDS11, + bds11, integer  - LEN, + len, integer  - LENBDS, + lenbds, character*1, dimension(*)  - PDS, + pds, real  - REFNCE, + refnce, integer  - ISCAL2, + iscal2, integer  - KWIDE, + kwide, integer, dimension(*)  - IGDS  + igds  @@ -423,8 +429,8 @@

    -

    ◆ fi7505()

    + +

    ◆ fi7505()

    @@ -433,13 +439,13 @@

    subroutine fi7505 ( integer  - N, + n, integer  - NBITS  + nbits  @@ -471,8 +477,8 @@

    -

    ◆ fi7513()

    + +

    ◆ fi7513()

    @@ -481,37 +487,37 @@

    subroutine fi7513 ( integer, dimension(*)  - IWORK, + iwork, integer  - ISTART, + istart, integer  - NPTS, + npts, integer  - MAX, + max, integer  - MIN, + min, integer  - INRNGE  + inrnge  @@ -548,8 +554,8 @@

    -

    ◆ fi7516()

    + +

    ◆ fi7516()

    @@ -558,49 +564,49 @@

    subroutine fi7516 ( integer, dimension(*)  - IWORK, + iwork, integer  - NPTS, + npts, integer  - INRNG, + inrng, integer  - ISTART, + istart, integer  - MAX, + max, integer  - MIN, + min, integer  - MXVAL, + mxval, integer  - LWIDTH  + lwidth  @@ -639,8 +645,8 @@

    -

    ◆ fi7517()

    + +

    ◆ fi7517()

    @@ -649,55 +655,55 @@

    subroutine fi7517 (   - IRET, + iret, integer, dimension(*)  - IWORK, + iwork, integer  - NPTS, + npts, integer  - ISTRTB, + istrtb, integer  - INRNGA, + inrnga, integer  - MAXB, + maxb, integer  - MINB, + minb, integer  - MXVALB, + mxvalb, integer  - LWIDEB  + lwideb  @@ -737,8 +743,8 @@

    -

    ◆ fi7518()

    + +

    ◆ fi7518()

    @@ -747,61 +753,61 @@

    subroutine fi7518 (   - IRET, + iret, integer, dimension(*)  - IWORK, + iwork, integer  - NPTS, + npts, integer  - ISTRTA, + istrta, integer  - INRNGA, + inrnga,   - INRNGB, + inrngb, integer  - MAXA, + maxa, integer  - MINA, + mina, integer  - LWIDEA, + lwidea, integer  - MXVALA  + mxvala  @@ -842,8 +848,8 @@

    -

    ◆ w3fi75()

    + +

    ◆ w3fi75()

    @@ -852,97 +858,97 @@

    subroutine w3fi75 (   - IBITL, + ibitl,   - ITYPE, + itype,   - ITOSS, + itoss, real, dimension(*)  - FLD, + fld, integer, dimension(*)  - IFLD, + ifld, integer, dimension(*)  - IBMAP, + ibmap, integer, dimension(*)  - IBDSFL, + ibdsfl,   - NPTS, + npts, character * 1, dimension(11)  - BDS11, + bds11, character(len=1), dimension(*)  - IPFLD, + ipfld, character * 1, dimension(*)  - PFLD, + pfld,   - LEN, + len,   - LENBDS, + lenbds,   - IBERR, + iberr, character * 1, dimension(*)  - PDS, + pds, integer, dimension(*)  - IGDS  + igds  @@ -960,7 +966,7 @@

    fi7501(). +
  • 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
    • @@ -1052,7 +1058,7 @@

    diff --git a/w3fi75_8f.js b/w3fi75_8f.js index 8e104cf6..2e670c1a 100644 --- a/w3fi75_8f.js +++ b/w3fi75_8f.js @@ -1,12 +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 ] + [ "fi7501", "w3fi75_8f.html#a32a2a7401b114f4fc586df3beba1740f", null ], + [ "fi7502", "w3fi75_8f.html#a7f98512b07c6233808c17cc41d39d34c", null ], + [ "fi7503", "w3fi75_8f.html#a3c5445cb4d0324926bf799220832227d", null ], + [ "fi7505", "w3fi75_8f.html#ab7aeef8ecb7b6e109f40de24ef9c466e", null ], + [ "fi7513", "w3fi75_8f.html#a080e563a3a2efeccaad9f91ac50f47e6", null ], + [ "fi7516", "w3fi75_8f.html#ae8e50fdcf98e231dd87ac0cac3407a23", null ], + [ "fi7517", "w3fi75_8f.html#a27b075bf60130cc76e5af83a4631df21", null ], + [ "fi7518", "w3fi75_8f.html#a229a0a1cdb13a4ac40e64396a062b0ab", null ], + [ "w3fi75", "w3fi75_8f.html#a132bfbd67589901d6bb5e9f72158a0c7", null ] ]; \ No newline at end of file diff --git a/w3fi75_8f_source.html b/w3fi75_8f_source.html index db8dbab0..15c154d8 100644 --- a/w3fi75_8f_source.html +++ b/w3fi75_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi75.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,1596 +81,1620 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi75.f
    +
    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
    -
    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
    -
    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
    -
    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
    -
    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
    -
    fi7516
    subroutine fi7516(IWORK, NPTS, INRNG, ISTART, MAX, MIN, MXVAL, LWIDTH)
    Scan number of points.
    Definition: w3fi75.f:1371
    -
    fi7513
    subroutine fi7513(IWORK, ISTART, NPTS, MAX, MIN, INRNGE)
    Select block of data for packing.
    Definition: w3fi75.f:1248
    -
    fi7501
    subroutine fi7501(IWORK, IPFLD, NPTS, IBDSFL, BDS11, LEN, LENBDS, PDS, REFNCE, ISCAL2, KWIDE)
    BDS second order packing.
    Definition: w3fi75.f:537
    -
    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
    -
    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
    -
    fi7518
    subroutine fi7518(IRET, IWORK, NPTS, ISTRTA, INRNGA, INRNGB, MAXA, MINA, LWIDEA, MXVALA)
    Scan forward.
    Definition: w3fi75.f:1512
    -
    fi7502
    subroutine fi7502(IWORK, ISTART, NPTS, ISAME)
    Second order same value collection.
    Definition: w3fi75.f:857
    -
    fi7505
    subroutine fi7505(N, NBITS)
    Determine number of bits to contain value.
    Definition: w3fi75.f:1208
    -
    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
    -
    w3fi82
    subroutine w3fi82(IFLD, FVAL1, FDIFF1, NPTS, PDS, IGDS)
    Accept an input array, convert to array of second differences.
    Definition: w3fi82.f:31
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief GRIB pack data and form bds octets(1-11)
    +
    3C> @author M. Farley @date 1992-07-10
    +
    4
    +
    5C> This routine packs a grib field and forms octets(1-11)
    +
    6C> of the binary data section (bds).
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - M. Farley 1992-07-10 Original author
    +
    10C> - Ralph Jones 1992-10-01 Correction for field of constant data
    +
    11C> - Ralph Jones 1992-10-16 Get rid of arrays fp and int
    +
    12C> - Bill Cavanaugh 1993-08-06 Added routines fi7501, fi7502, fi7503
    +
    13C> To allow second order packing in pds.
    +
    14C> - John Stackpole 1993-07-21 Assorted repairs to get 2nd diff pack in
    +
    15C> - Bill Cavanaugh 1993-10-28 Commented out nonoperational prints and
    +
    16C> Write statements
    +
    17C> - Bill Cavanaugh 1993-12-15 Corrected location of start of first order
    +
    18C> Values and start of second order values to
    +
    19C> Reflect a byte location in the bds instead
    +
    20C> Of an offset in subroutine fi7501().
    +
    21C> - Bill Cavanaugh 1994-01-27 Added igds as input argument to this routine
    +
    22C> And added pds and igds arrays to the call to
    +
    23C> W3fi82 to provide information needed for
    +
    24C> Boustrophedonic processing.
    +
    25C> - Bill Cavanaugh 1994-05-25 Subroutine fi7503 has been added to provide
    +
    26C> For row by row or column by column second
    +
    27C> Order packing. this feature can be activated
    +
    28C> By setting ibdsfl(7) to zero.
    +
    29C> - Bill Cavanaugh 1994-07-08 Commented out print statements used for debug
    +
    30C> - M. Farley 1994-11-22 Enlarged work arrays to handle .5degree grids
    +
    31C> - Ralph Jones 1995-06-01 Correction for number of unused bits at end
    +
    32C> Of section 4, in bds byte 4, bits 5-8.
    +
    33C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    34C> - Stephen Gilbert 2001-06-06 Changed gbyte/sbyte calls to refer to
    +
    35C> Wesley ebisuzaki's endian independent
    +
    36C> versions gbytec/sbytec.
    +
    37C> Use f90 standard routine bit_size to get
    +
    38C> number of bits in an integer instead of w3fi01.
    +
    39C>
    +
    40C> @param[in] IBITL
    +
    41C> - 0, computer computes packing length from power of 2 that best fits the data.
    +
    42C> - 8, 12, etc. computer rescales data to fit into set number of bits.
    +
    43C> @param[in] ITYPE
    +
    44C> - 0 = if input data is floating point (fld)
    +
    45C> - 1 = If input data is integer (ifld)
    +
    46C> @param[in] ITOSS
    +
    47C> - 0 = no bit map is included (don't toss data)
    +
    48C> - 1 = Toss null data according to ibmap
    +
    49C> @param[in] FLD Real array of data to be packed if itype=0
    +
    50C> @param[in] IFLD Integer array to be packed if itype=1
    +
    51C> @param[in] IBMAP Bit map supplied from user
    +
    52C> @param[in] IBDSFL Integer array containing table 11 flag info
    +
    53C> BDS octet 4:
    +
    54C> - (1)
    +
    55C> - 0 = grid point data
    +
    56C> - 1 = spherical harmonic coefficients
    +
    57C> - (2)
    +
    58C> - 0 = simple packing
    +
    59C> - 1 = second order packing
    +
    60C> - (3)
    +
    61C> - 0 = original data were floating point values
    +
    62C> - 1 = original data were integer values
    +
    63C> - (4)
    +
    64C> - 0 = no additional flags at octet 14
    +
    65C> - 1 = octet 14 contains flag bits 5-12
    +
    66C> - (5) 0 = reserved - always set to 0
    +
    67C> - (6)
    +
    68C> - 0 = single datum at each grid point
    +
    69C> - 1 = matrix of values at each grid point
    +
    70C> - (7)
    +
    71C> - 0 = no secondary bit maps
    +
    72C> - 1 = secondary bit maps present
    +
    73C> - (8)
    +
    74C> - 0 = second order values have constant width
    +
    75C> - 1 = second order values have different widths
    +
    76C> @param[in] NPTS Number of gridpoints in array to be packed
    +
    77C> @param[in] IGDS Array of gds information
    +
    78C> @param[out] BDS11 First 11 octets of bds
    +
    79C> @param[out] PFLD Packed grib field
    +
    80C> @param[out] LEN Length of pfld
    +
    81C> @param[out] LENBDS Length of bds
    +
    82C> @param[out] IBERR 1, error converting ieee f.p. number to ibm370 f.p.
    +
    83C> @param IPFLD
    +
    84C> @param PDS
    +
    85C>
    +
    86C> @note Subprogram can be called from a multiprocessing environment.
    +
    87C>
    +
    +
    88 SUBROUTINE w3fi75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL,
    +
    89 & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS)
    +
    90C
    +
    91 REAL FLD(*)
    +
    92C REAL FWORK(260000)
    +
    93C
    +
    94C FWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY
    +
    95C
    +
    96 REAL FWORK(NPTS)
    +
    97 REAL RMIN,REFNCE
    +
    98C
    +
    99 character(len=1) IPFLD(*)
    +
    100 INTEGER IBDSFL(*)
    +
    101 INTEGER IBMAP(*)
    +
    102 INTEGER IFLD(*),IGDS(*)
    +
    103C INTEGER IWORK(260000)
    +
    104C
    +
    105C IWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY
    +
    106C
    +
    107 INTEGER IWORK(NPTS)
    +
    108C
    +
    109 LOGICAL CONST
    +
    110C
    +
    111 CHARACTER * 1 BDS11(11),PDS(*)
    +
    112 CHARACTER * 1 PFLD(*)
    +
    113C
    +
    114C 1.0 PACK THE FIELD.
    +
    115C
    +
    116C 1.1 TOSS DATA IF BITMAP BEING USED,
    +
    117C MOVING 'DATA' TO WORK AREA...
    +
    118C
    +
    119 const = .false.
    +
    120 iberr = 0
    +
    121 iw = 0
    +
    122C
    +
    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
    +
    141C
    +
    142C ELSE, JUST MOVE DATA TO WORK ARRAY
    +
    143C
    +
    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
    +
    155C
    +
    156C 1.2 CONVERT DATA IF NEEDED PRIOR TO PACKING.
    +
    157C (INTEGER TO F.P. OR F.P. TO INTEGER)
    +
    158C ITYPE = 0...FLOATING POINT DATA
    +
    159C IBITL = 0...PACK IN LEAST # BITS...CONVERT TO INTEGER
    +
    160C ITYPE = 1...INTEGER DATA
    +
    161C IBITL > 0...PACK IN FIXED # BITS...CONVERT TO FLOATING POINT
    +
    162C
    +
    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
    +
    172C
    +
    173C 1.3 PACK THE DATA.
    +
    174C
    +
    175 IF (ibdsfl(2).NE.0) THEN
    +
    176C SECOND ORDER PACKING
    +
    177C
    +
    178C PRINT*,' DOING SECOND ORDER PACKING...'
    +
    179 IF (ibitl.EQ.0) THEN
    +
    180C
    +
    181C PRINT*,' AND VARIABLE BIT PACKING'
    +
    182C
    +
    183C WORKING WITH INTEGER VALUES
    +
    184C SINCE DOING VARIABLE BIT PACKING
    +
    185C
    +
    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
    +
    195C EXTRACT MINIMA
    +
    196 DO 400 i = 1, npts
    +
    197C IF (IWORK(I).LT.0) THEN
    +
    198C PRINT *,'MINIMA 400',I,IWORK(I),NPTS
    +
    199C END IF
    +
    200 iwork(i) = iwork(i) - min
    +
    201 400 CONTINUE
    +
    202 refnce = min
    +
    203 idiff = max - min
    +
    204C PRINT *,'REFERENCE VALUE',REFNCE
    +
    205C
    +
    206C WRITE (6,FMT='('' MINIMA REMOVED = '',/,
    +
    207C & 10(3X,10I10,/))') (IWORK(I),I=1,6)
    +
    208C WRITE (6,FMT='('' END OF ARRAY = '',/,
    +
    209C & 10(3X,10I10,/))') (IWORK(I),I=NPTS-5,NPTS)
    +
    210C
    +
    211C FIND BIT WIDTH OF IDIFF
    +
    212C
    +
    213 CALL fi7505 (idiff,kwide)
    +
    214C PRINT*,' BIT WIDTH FOR ORIGINAL DATA', KWIDE
    +
    215 iscal2 = 0
    +
    216C
    +
    217C MULTIPLICATIVE SCALE FACTOR SET TO 1
    +
    218C IN ANTICIPATION OF POSSIBLE USE IN GLAHN 2DN DIFF
    +
    219C
    +
    220 scal2 = 1.
    +
    221C
    +
    222 ELSE
    +
    223C
    +
    224C PRINT*,' AND FIXED BIT PACKING, IBITL = ', IBITL
    +
    225C FIXED BIT PACKING
    +
    226C - LENGTH OF FIELD IN IBITL
    +
    227C - MUST BE REAL DATA
    +
    228C FLOATING POINT INPUT
    +
    229C
    +
    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
    +
    240C PRINT *,'100 REFERENCE',REFNCE
    +
    241C EXTRACT MINIMA
    +
    242 DO 200 i = 1, npts
    +
    243 fwork(i) = fwork(i) - rmin
    +
    244 200 CONTINUE
    +
    245C PRINT *,'REFERENCE VALUE',REFNCE
    +
    246C WRITE (6,FMT='('' MINIMA REMOVED = '',/,
    +
    247C & 10(3X,10F8.2,/))') (FWORK(I),I=1,6)
    +
    248C WRITE (6,FMT='('' END OF ARRAY = '',/,
    +
    249C & 10(3X,10F8.2,/))') (FWORK(I),I=NPTS-5,NPTS)
    +
    250C FIND LARGEST DELTA
    +
    251 idelt = nint(rmax - rmin)
    +
    252C DO BINARY SCALING
    +
    253C FIND OUT WHAT BINARY SCALE FACTOR
    +
    254C PERMITS CONTAINMENT OF
    +
    255C LARGEST DELTA
    +
    256 CALL fi7505 (idelt,iwide)
    +
    257C
    +
    258C BINARY SCALING
    +
    259C
    +
    260 iscal2 = iwide - ibitl
    +
    261C PRINT *,'SCALING NEEDED TO FIT =',ISCAL2
    +
    262C PRINT*,' RANGE OF = ',IDELT
    +
    263C
    +
    264C EXPAND DATA WITH BINARY SCALING
    +
    265C 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
    +
    273C
    +
    274C *****************************************************************
    +
    275C
    +
    276C FOLLOWING IS FOR GLAHN SECOND DIFFERENCING
    +
    277C NOT STANDARD GRIB
    +
    278C
    +
    279C TEST FOR SECOND DIFFERENCE PACKING
    +
    280C BASED OF SIZE OF PDS - SIZE IN FIRST 3 BYTES
    +
    281C
    +
    282 CALL gbytec(pds,ipdsiz,0,24)
    +
    283 IF (ipdsiz.EQ.50) THEN
    +
    284C PRINT*,' DO SECOND DIFFERENCE PACKING '
    +
    285C
    +
    286C GLAHN PACKING TO 2ND DIFFS
    +
    287C
    +
    288C WRITE (6,FMT='('' CALL TO W3FI82 WITH = '',/,
    +
    289C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    +
    290C
    +
    291 CALL w3fi82 (iwork,fval1,fdiff1,npts,pds,igds)
    +
    292C
    +
    293C PRINT *,'GLAHN',FVAL1,FDIFF1
    +
    294C WRITE (6,FMT='('' OUT FROM W3FI82 WITH = '',/,
    +
    295C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    +
    296C
    +
    297C MUST NOW RE-REMOVE THE MINIMUM VALUE
    +
    298C OF THE SECOND DIFFERENCES TO ASSURE
    +
    299C ALL POSITIVE NUMBERS FOR SECOND ORDER GRIB PACKING
    +
    300C
    +
    301C ORIGINAL REFERENCE VALUE ADDED TO FIRST POINT
    +
    302C VALUE FROM THE 2ND DIFF PACKER TO BE ADDED
    +
    303C BACK IN WHEN THE 2ND DIFF VALUES ARE
    +
    304C RECONSTRUCTED BACK TO THE BASIC VALUES
    +
    305C
    +
    306C ALSO, THE REFERENCE VALUE IS
    +
    307C POWER-OF-TWO SCALED TO MATCH
    +
    308C FVAL1. ALL OF THIS SCALING
    +
    309C WILL BE REMOVED AFTER THE
    +
    310C GLAHN SECOND DIFFERENCING IS UNDONE.
    +
    311C THE SCALING FACTOR NEEDED TO DO THAT
    +
    312C IS SAVED IN THE PDS AS A SIGNED POSITIVE
    +
    313C TWO BYTE INTEGER
    +
    314C
    +
    315C THE SCALING FOR THE 2ND DIF PACKED
    +
    316C VALUES IS PROPERLY SET TO ZERO
    +
    317C
    +
    318 fval1 = fval1 + refnce*scal2
    +
    319C FIRST TEST TO SEE IF
    +
    320C ON 32 OR 64 BIT COMPUTER
    +
    321C 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)
    +
    329C
    +
    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)
    +
    337C
    +
    338C TURN ISCAL2 INTO SIGNED POSITIVE INTEGER
    +
    339C AND STORE IN TWO BYTES
    +
    340C
    +
    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
    +
    348C
    +
    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
    +
    358C EXTRACT MINIMA
    +
    359 DO 710 i = 1, npts
    +
    360 iwork(i) = iwork(i) - min
    +
    361 710 CONTINUE
    +
    362 refnce = min
    +
    363C PRINT *,'710 REFERENCE',REFNCE
    +
    364 iscal2 = 0
    +
    365C
    +
    366C AND RESET VALUE OF KWIDE - THE BIT WIDTH
    +
    367C FOR THE RANGE OF THE VALUES
    +
    368C
    +
    369 idiff = max - min
    +
    370 CALL fi7505 (idiff,kwide)
    +
    371C
    +
    372C PRINT*,'BIT WIDTH (KWIDE) OF 2ND DIFFS', KWIDE
    +
    373C
    +
    374C **************************** END OF GLAHN PACKING ************
    +
    375 ELSE IF (ibdsfl(2).EQ.1.AND.ibdsfl(7).EQ.0) THEN
    +
    376C HAVE SECOND ORDER PACKING WITH NO SECOND ORDER
    +
    377C 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
    +
    382C WRITE (6,FMT='('' CALL TO FI7501 WITH = '',/,
    +
    383C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    +
    384C WRITE (6,FMT='('' END OF ARRAY = '',/,
    +
    385C & 10(3X,10I6,/))') (IWORK(I),I=NPTS-5,NPTS)
    +
    386C PRINT*,' REFNCE,ISCAL2, KWIDE AT CALL TO FI7501',
    +
    387C & REFNCE, ISCAL2,KWIDE
    +
    388C
    +
    389C SECOND ORDER PACKING
    +
    390C
    +
    391 CALL fi7501 (iwork,ipfld,npts,ibdsfl,bds11,
    +
    392 * len,lenbds,pds,refnce,iscal2,kwide)
    +
    393C
    +
    394C BDS COMPLETELY ASSEMBLED IN FI7501 FOR SECOND ORDER
    +
    395C PACKING.
    +
    396C
    +
    397 ELSE
    +
    398C SIMPLE PACKING
    +
    399C
    +
    400C PRINT*,' SIMPLE FIRST ORDER PACKING...'
    +
    401 IF (ibitl.EQ.0) THEN
    +
    402C PRINT*,' WITH VARIABLE BIT LENGTH'
    +
    403C
    +
    404C WITH VARIABLE BIT LENGTH, ADJUSTED
    +
    405C TO ACCOMMODATE LARGEST VALUE
    +
    406C BINARY SCALING ALWAYS = 0
    +
    407C
    +
    408 CALL w3fi58(iwork,npts,iwork,pfld,nbits,len,kmin)
    +
    409 rmin = kmin
    +
    410 refnce = rmin
    +
    411 iscale = 0
    +
    412C PRINT*,' BIT LENGTH CAME OUT AT ...',NBITS
    +
    413C
    +
    414C SET CONST .TRUE. IF ALL VALUES ARE THE SAME
    +
    415C
    +
    416 IF (len.EQ.0.AND.nbits.EQ.0) const = .true.
    +
    417C
    +
    418 ELSE
    +
    419C PRINT*,' FIXED BIT LENGTH, IBITL = ', IBITL
    +
    420C
    +
    421C FIXED BIT LENGTH PACKING (VARIABLE PRECISION)
    +
    422C VALUES SCALED BY POWER OF 2 (ISCALE) TO
    +
    423C FIT LARGEST VALUE INTO GIVEN BIT LENGTH (IBITL)
    +
    424C
    +
    425 CALL w3fi59(fwork,npts,ibitl,iwork,pfld,iscale,len,rmin)
    +
    426 refnce = rmin
    +
    427C PRINT *,' SCALING NEEDED TO FIT IS ...', ISCALE
    +
    428 nbits = ibitl
    +
    429C
    +
    430C SET CONST .TRUE. IF ALL VALUES ARE THE SAME
    +
    431C
    +
    432 IF (len.EQ.0) THEN
    +
    433 const = .true.
    +
    434 nbits = 0
    +
    435 END IF
    +
    436 END IF
    +
    437C
    +
    438C$ COMPUTE LENGTH OF BDS IN OCTETS
    +
    439C
    +
    440 inum = npts * nbits + 88
    +
    441C PRINT *,'NUMBER OF BITS BEFORE FILL ADDED',INUM
    +
    442C
    +
    443C 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
    +
    450C PRINT *,'NUMBER OF BITS AFTER FILL ADDED',INUM
    +
    451C LENGTH OF BDS IN BYTES
    +
    452 lenbds = inum / 8
    +
    453C
    +
    454C 2.0 FORM THE BINARY DATA SECTION (BDS).
    +
    455C
    +
    456C CONCANTENATE ALL FIELDS FOR BDS
    +
    457C
    +
    458C BYTES 1-3
    +
    459 CALL sbytec (bds11,lenbds,0,24)
    +
    460C
    +
    461C BYTE 4
    +
    462C 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)
    +
    467C NR OF FILL BITS
    +
    468 CALL sbytec (bds11,nfill,28,4)
    +
    469C
    +
    470C$ FILL OCTETS 5-6 WITH THE SCALE FACTOR.
    +
    471C
    +
    472C 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
    +
    480C
    +
    481C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE
    +
    482C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    +
    483C FLOATING POINT NUMBER
    +
    484C
    +
    485C BYTE 7-10
    +
    486C REFERENCE VALUE
    +
    487C FIRST TEST TO SEE IF
    +
    488C ON 32 OR 64 BIT COMPUTER
    +
    489C 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)
    +
    497C
    +
    498C
    +
    499C$ FILL OCTET 11 WITH THE NUMBER OF BITS.
    +
    500C
    +
    501C BYTE 11
    +
    502 CALL sbytec (bds11,nbits,80,8)
    +
    503 END IF
    +
    504C
    +
    505 RETURN
    +
    +
    506 END
    +
    507C
    +
    508C> @brief BDS second order packing.
    +
    509C> @author Bill Cavanaugh @date 1993-08-06
    +
    510
    +
    511C> Perform secondary packing on grid point data, generating all BDS information.
    +
    512C>
    +
    513C> Program history log:
    +
    514C> - Bill Cavanaugh 1993-08-06
    +
    515C> - Bill Cavanaugh 1993-12-15 Corrected location of start of first order
    +
    516C> values and start of second order values to reflect a byte location in the
    +
    517C> BDS instead of an offset.
    +
    518C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    519C>
    +
    520C> @param[in] IWORK Integer source array
    +
    521C> @param[in] NPTS Number of points in iwork
    +
    522C> @param[in] IBDSFL Flags
    +
    523C> @param[out] IPFLD Contains bds from byte 12 on
    +
    524C> @param[out] BDS11 Contains first 11 bytes for bds
    +
    525C> @param[out] LEN Number of bytes from 12 on
    +
    526C> @param[out] LENBDS Total length of bds
    +
    527C> @param PDS
    +
    528C> @param REFNCE
    +
    529C> @param ISCAL2
    +
    530C> @param KWIDE
    +
    531C>
    +
    532C> @note Subprogram can be called from a multiprocessing environment.
    +
    533C>
    +
    534C> @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(*)
    +
    539C
    +
    540 REAL REFNCE
    +
    541C
    +
    542 INTEGER ISCAL2,KWIDE
    +
    543 INTEGER LENBDS
    +
    544 CHARACTER(len=1) IPFLD(*)
    +
    545 INTEGER LEN,KBDS(22)
    +
    546 INTEGER IWORK(*)
    +
    547C OCTET NUMBER IN SECTION, FIRST ORDER PACKING
    +
    548C INTEGER KBDS(12)
    +
    549C FLAGS
    +
    550 INTEGER IBDSFL(*)
    +
    551C EXTENDED FLAGS
    +
    552C INTEGER KBDS(14)
    +
    553C OCTET NUMBER FOR SECOND ORDER PACKING
    +
    554C INTEGER KBDS(15)
    +
    555C NUMBER OF FIRST ORDER VALUES
    +
    556C INTEGER KBDS(17)
    +
    557C NUMBER OF SECOND ORDER PACKED VALUES
    +
    558C INTEGER KBDS(19)
    +
    559C WIDTH OF SECOND ORDER PACKING
    +
    560 character(len=1) ISOWID(400000)
    +
    561C SECONDARY BIT MAP
    +
    562 character(len=1) ISOBMP(65600)
    +
    563C FIRST ORDER PACKED VALUES
    +
    564 character(len=1) IFOVAL(400000)
    +
    565C SECOND ORDER PACKED VALUES
    +
    566 character(len=1) ISOVAL(800000)
    +
    567C
    +
    568C INTEGER KBDS(11)
    +
    569C BIT WIDTH TABLE
    +
    570 INTEGER IBITS(31)
    +
    571C
    +
    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/
    +
    578C ----------------------------------
    +
    579C INITIALIZE ARRAYS
    +
    580
    +
    581 DO i = 1, 400000
    +
    582 ifoval(i) = char(0)
    +
    583 isowid(i) = char(0)
    +
    584 ENDDO
    +
    585C
    +
    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
    +
    592C INITIALIZE POINTERS
    +
    593C SECONDARY BIT WIDTH POINTER
    +
    594 iwdptr = 0
    +
    595C SECONDARY BIT MAP POINTER
    +
    596 ibmp2p = 0
    +
    597C FIRST ORDER VALUE POINTER
    +
    598 ifoptr = 0
    +
    599C BYTE POINTER TO START OF 1ST ORDER VALUES
    +
    600 kbds(12) = 0
    +
    601C BYTE POINTER TO START OF 2ND ORDER VALUES
    +
    602 kbds(15) = 0
    +
    603C TO CONTAIN NUMBER OF FIRST ORDER VALUES
    +
    604 kbds(17) = 0
    +
    605C TO CONTAIN NUMBER OF SECOND ORDER VALUES
    +
    606 kbds(19) = 0
    +
    607C SECOND ORDER PACKED VALUE POINTER
    +
    608 isoptr = 0
    +
    609C =======================================================
    +
    610C
    +
    611C DATA IS IN IWORK
    +
    612C
    +
    613 kbds(11) = kwide
    +
    614C
    +
    615C DATA PACKING
    +
    616C
    +
    617 iter = 0
    +
    618 inext = 1
    +
    619 istart = 1
    +
    620C -----------------------------------------------------------
    +
    621 kount = 0
    +
    622C DO 1 I = 1, NPTS, 10
    +
    623C PRINT *,I,(IWORK(K),K=I, I+9)
    +
    624C 1 CONTINUE
    +
    625 2000 CONTINUE
    +
    626 iter = iter + 1
    +
    627C 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
    +
    635C
    +
    636C LOOK FOR REPITITIONS OF A SINGLE VALUE
    +
    637 CALL fi7502 (iwork,istart,npts,isame)
    +
    638 IF (isame.GE.15) THEN
    +
    639 kount = kount + 1
    +
    640C PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME
    +
    641 mxdiff = 0
    +
    642 kpts = isame
    +
    643 ELSE
    +
    644C
    +
    645C LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE
    +
    646 CALL fi7513 (iwork,istart,npts,nmax,nmin,inrnge)
    +
    647C PRINT *,'ISTART ',ISTART,' INRNGE',INRNGE,NMAX,NMIN
    +
    648 iend = istart + inrnge - 1
    +
    649C DO 2199 NM = ISTART, IEND, 10
    +
    650C PRINT *,' ',(IWORK(NM+JK),JK=0,9)
    +
    651C2199 CONTINUE
    +
    652 mxdiff = nmax - nmin
    +
    653 kpts = inrnge
    +
    654 END IF
    +
    655 2200 CONTINUE
    +
    656C PRINT *,' RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN
    +
    657C INCREMENT NUMBER OF FIRST ORDER VALUES
    +
    658 kbds(17) = kbds(17) + 1
    +
    659C 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)
    +
    669C 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
    +
    682C PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS
    +
    683C 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
    +
    688C PRINT *,' SECOND ORDER VALUES'
    +
    689C PRINT *,(IWORK(ISTART+I),I=0,KPTS-1)
    +
    690 END IF
    +
    691C ADD TO SECOND ORDER BITMAP
    +
    692 CALL sbytec (isobmp,1,ibmp2p,1)
    +
    693 ibmp2p = ibmp2p + kpts
    +
    694 istart = istart + kpts
    +
    695 GO TO 2000
    +
    696C --------------------------------------------------------------
    +
    697 4000 CONTINUE
    +
    698C PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS'
    +
    699C PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS'
    +
    700C CONCANTENATE ALL FIELDS FOR BDS
    +
    701C
    +
    702C REMAINDER GOES INTO IPFLD
    +
    703 iptr = 0
    +
    704C BYTES 12-13
    +
    705C VALUE FOR N1
    +
    706C LEAVE SPACE FOR THIS
    +
    707 iptr = iptr + 16
    +
    708C BYTE 14
    +
    709C 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
    +
    726C BYTES 15-16
    +
    727C SKIP OVER VALUE FOR N2
    +
    728 iptr = iptr + 16
    +
    729C BYTES 17-18
    +
    730C P1
    +
    731 CALL sbytec (ipfld,kbds(17),iptr,16)
    +
    732 iptr = iptr + 16
    +
    733C BYTES 19-20
    +
    734C P2
    +
    735 CALL sbytec (ipfld,kbds(19),iptr,16)
    +
    736 iptr = iptr + 16
    +
    737C BYTE 21 - RESERVED LOCATION
    +
    738 CALL sbytec (ipfld,0,iptr,8)
    +
    739 iptr = iptr + 8
    +
    740C BYTES 22 - ?
    +
    741C WIDTHS OF SECOND ORDER PACKING
    +
    742 ix = (iwdptr + 32) / 32
    +
    743C 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
    +
    748C SECONDARY BIT MAP
    +
    749 ij = (ibmp2p + 32) / 32
    +
    750C 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
    +
    758C DETERMINE LOCATION FOR START
    +
    759C OF FIRST ORDER PACKED VALUES
    +
    760 kbds(12) = iptr / 8 + 12
    +
    761C STORE LOCATION
    +
    762 CALL sbytec (ipfld,kbds(12),0,16)
    +
    763C MOVE IN FIRST ORDER PACKED VALUES
    +
    764 ipass = (ifoptr + 32) / 32
    +
    765C 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
    +
    773C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
    +
    774C DETERMINE LOCATION FOR START
    +
    775C OF SECOND ORDER VALUES
    +
    776 kbds(15) = iptr / 8 + 12
    +
    777C SAVE LOCATION OF SECOND ORDER VALUES
    +
    778 CALL sbytec (ipfld,kbds(15),24,16)
    +
    779C MOVE IN SECOND ORDER PACKED VALUES
    +
    780 ix = (isoptr + 32) / 32
    +
    781c 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
    +
    791C COMPUTE LENGTH OF DATA PORTION
    +
    792 len = iptr / 8
    +
    793C COMPUTE LENGTH OF BDS
    +
    794 lenbds = len + 11
    +
    795C -----------------------------------
    +
    796C BYTES 1-3
    +
    797C THIS FUNCTION COMPLETED BELOW
    +
    798C WHEN LENGTH OF BDS IS KNOWN
    +
    799 CALL sbytec (bds11,lenbds,0,24)
    +
    800C 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)
    +
    805C ENTER NUMBER OF FILL BITS
    +
    806 CALL sbytec (bds11,nleft,28,4)
    +
    807C 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)
    +
    815C
    +
    816C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE
    +
    817C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    +
    818C FLOATING POINT NUMBER
    +
    819C REFERENCE VALUE
    +
    820C FIRST TEST TO SEE IF
    +
    821C ON 32 OR 64 BIT COMPUTER
    +
    822C 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)
    +
    830C
    +
    831C BYTE 11
    +
    832C
    +
    833 CALL sbytec (bds11,kbds(11),80,8)
    +
    834C
    +
    835 RETURN
    +
    +
    836 END
    +
    837C
    +
    838C> @brief Second order same value collection.
    +
    839C> @author Bill Cavanaugh @date 1993-06-23
    +
    840
    +
    841C> Collect sequential same values for processing
    +
    842C> as second order value for grib messages.
    +
    843C>
    +
    844C> Program history log:
    +
    845C> - Bill Cavanaugh 1993-06-23
    +
    846C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    847C>
    +
    848C> @param[in] IWORK Array containing source data
    +
    849C> @param[in] ISTART Starting location for this test
    +
    850C> @param[in] NPTS Number of points in iwork
    +
    851C> @param[out] ISAME Number of sequential points having the same value
    +
    852C>
    +
    853C> @note Subprogram can be called from a multiprocessing environment.
    +
    854C>
    +
    855C> @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
    +
    863C -------------------------------------------------------------
    +
    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
    +
    873C
    +
    874C> @brief Row by row, col by col packing.
    +
    875C> @author Bill Cavanaugh @date 1993-08-06
    +
    876
    +
    877C> Perform row by row or column by column packing
    +
    878C> generating all bds information.
    +
    879C>
    +
    880C> Program history log:
    +
    881C> - Bill Cavanaugh 1993-08-06
    +
    882C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    883C>
    +
    884C> @param[in] IWORK Integer source array
    +
    885C> @param[in] NPTS Number of points in iwork
    +
    886C> @param[in] IBDSFL Flags
    +
    887C> @param[out] IPFLD Contains bds from byte 12 on
    +
    888C> @param[out] BDS11 Contains first 11 bytes for bds
    +
    889C> @param[out] LEN Number of bytes from 12 on
    +
    890C> @param[out] LENBDS Total length of bds
    +
    891C> @param PDS
    +
    892C> @param REFNCE
    +
    893C> @param ISCAL2
    +
    894C> @param KWIDE
    +
    895C> @param IGDS
    +
    896C>
    +
    897C> @note Subprogram can be called from a multiprocessing environment.
    +
    898C>
    +
    899C> @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(*)
    +
    904C
    +
    905 REAL REFNCE
    +
    906C
    +
    907 INTEGER ISCAL2,KWIDE
    +
    908 INTEGER LENBDS
    +
    909 INTEGER IGDS(*)
    +
    910 INTEGER LEN,KBDS(22)
    +
    911 INTEGER IWORK(*)
    +
    912C OCTET NUMBER IN SECTION, FIRST ORDER PACKING
    +
    913C INTEGER KBDS(12)
    +
    914C FLAGS
    +
    915 INTEGER IBDSFL(*)
    +
    916C EXTENDED FLAGS
    +
    917C INTEGER KBDS(14)
    +
    918C OCTET NUMBER FOR SECOND ORDER PACKING
    +
    919C INTEGER KBDS(15)
    +
    920C NUMBER OF FIRST ORDER VALUES
    +
    921C INTEGER KBDS(17)
    +
    922C NUMBER OF SECOND ORDER PACKED VALUES
    +
    923C INTEGER KBDS(19)
    +
    924C WIDTH OF SECOND ORDER PACKING
    +
    925 character(len=1) ISOWID(400000)
    +
    926C SECONDARY BIT MAP
    +
    927 character(len=1) ISOBMP(65600)
    +
    928C FIRST ORDER PACKED VALUES
    +
    929 character(len=1) IFOVAL(400000)
    +
    930C SECOND ORDER PACKED VALUES
    +
    931 character(len=1) ISOVAL(800000)
    +
    932C
    +
    933C INTEGER KBDS(11)
    +
    934C ----------------------------------
    +
    935C INITIALIZE ARRAYS
    +
    936C
    +
    937 DO i = 1, 400000
    +
    938 ifoval(i) = char(0)
    +
    939 isowid(i) = char(0)
    +
    940 ENDDO
    +
    941C
    +
    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
    +
    948C INITIALIZE POINTERS
    +
    949C SECONDARY BIT WIDTH POINTER
    +
    950 iwdptr = 0
    +
    951C SECONDARY BIT MAP POINTER
    +
    952 ibmp2p = 0
    +
    953C FIRST ORDER VALUE POINTER
    +
    954 ifoptr = 0
    +
    955C BYTE POINTER TO START OF 1ST ORDER VALUES
    +
    956 kbds(12) = 0
    +
    957C BYTE POINTER TO START OF 2ND ORDER VALUES
    +
    958 kbds(15) = 0
    +
    959C TO CONTAIN NUMBER OF FIRST ORDER VALUES
    +
    960 kbds(17) = 0
    +
    961C TO CONTAIN NUMBER OF SECOND ORDER VALUES
    +
    962 kbds(19) = 0
    +
    963C SECOND ORDER PACKED VALUE POINTER
    +
    964 isoptr = 0
    +
    965C =======================================================
    +
    966C BUILD SECOND ORDER BIT MAP IN EITHER
    +
    967C ROW BY ROW OR COL BY COL FORMAT
    +
    968 IF (iand(igds(13),32).NE.0) THEN
    +
    969C COLUMN BY COLUMN
    +
    970 kout = igds(4)
    +
    971 kin = igds(5)
    +
    972C PRINT *,'COLUMN BY COLUMN',KOUT,KIN
    +
    973 ELSE
    +
    974C ROW BY ROW
    +
    975 kout = igds(5)
    +
    976 kin = igds(4)
    +
    977C PRINT *,'ROW BY ROW',KOUT,KIN
    +
    978 END IF
    +
    979 kbds(17) = kout
    +
    980 kbds(19) = npts
    +
    981C
    +
    982C DO 4100 J = 1, NPTS, 53
    +
    983C WRITE (6,4101) (IWORK(K),K=J,J+52)
    +
    984 4101 FORMAT (1x,25i4)
    +
    985C PRINT *,' '
    +
    986C4100 CONTINUE
    +
    987C
    +
    988C INITIALIZE BIT MAP POINTER
    +
    989 ibmp2p = 0
    +
    990C 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
    +
    1002C CALL BINARY(ISOBMP,LEN)
    +
    1003C
    +
    1004C PROCESS OUTER LOOP OF ROW BY ROW OR COL BY COL
    +
    1005C
    +
    1006 kptr = 1
    +
    1007 kbds(11) = kwide
    +
    1008 DO 6000 i = 1, kout
    +
    1009C IN CURRENT ROW OR COL
    +
    1010C 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
    +
    1019C SAVE FIRST ORDER VALUE
    +
    1020 CALL sbytec (ifoval,lowest,ifoptr,kwide)
    +
    1021 ifoptr = ifoptr + kwide
    +
    1022C PRINT *,'FOVAL',I,LOWEST,KWIDE
    +
    1023C SUBTRACT FIRST ORDER VALUE FROM OTHER VALS
    +
    1024C 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
    +
    1034C HOW MANY BITS TO CONTAIN LARGEST SECOND
    +
    1035C ORDER VALUE IN SEGMENT
    +
    1036 CALL fi7505 (ibig,nwide)
    +
    1037C SAVE BIT WIDTH
    +
    1038 CALL sbytec (isowid,nwide,iwdptr,8)
    +
    1039 iwdptr = iwdptr + 8
    +
    1040C PRINT *,I,'SOVAL',IBIG,' IN',NWIDE,' BITS'
    +
    1041C WRITE (6,4101) (IWORK(K),K=KPTR,KPTR+52)
    +
    1042C 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
    +
    1049C =======================================================
    +
    1050C CONCANTENATE ALL FIELDS FOR BDS
    +
    1051C
    +
    1052C REMAINDER GOES INTO IPFLD
    +
    1053 iptr = 0
    +
    1054C BYTES 12-13
    +
    1055C VALUE FOR N1
    +
    1056C LEAVE SPACE FOR THIS
    +
    1057 iptr = iptr + 16
    +
    1058C BYTE 14
    +
    1059C 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
    +
    1076C BYTES 15-16
    +
    1077C SKIP OVER VALUE FOR N2
    +
    1078 iptr = iptr + 16
    +
    1079C BYTES 17-18
    +
    1080C P1
    +
    1081 CALL sbytec (ipfld,kbds(17),iptr,16)
    +
    1082 iptr = iptr + 16
    +
    1083C BYTES 19-20
    +
    1084C P2
    +
    1085 CALL sbytec (ipfld,kbds(19),iptr,16)
    +
    1086 iptr = iptr + 16
    +
    1087C BYTE 21 - RESERVED LOCATION
    +
    1088 CALL sbytec (ipfld,0,iptr,8)
    +
    1089 iptr = iptr + 8
    +
    1090C BYTES 22 - ?
    +
    1091C WIDTHS OF SECOND ORDER PACKING
    +
    1092 ix = (iwdptr + 32) / 32
    +
    1093C 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
    +
    1098C PRINT *,'ISOWID',IWDPTR,IX
    +
    1099C CALL BINARY (ISOWID,IX)
    +
    1100C
    +
    1101C NO SECONDARY BIT MAP
    +
    1102
    +
    1103C DETERMINE LOCATION FOR START
    +
    1104C OF FIRST ORDER PACKED VALUES
    +
    1105 kbds(12) = iptr / 8 + 12
    +
    1106C STORE LOCATION
    +
    1107 CALL sbytec (ipfld,kbds(12),0,16)
    +
    1108C MOVE IN FIRST ORDER PACKED VALUES
    +
    1109 ipass = (ifoptr + 32) / 32
    +
    1110c 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
    +
    1115C PRINT *,'IFOVAL',IFOPTR,IPASS,KWIDE
    +
    1116C CALL BINARY (IFOVAL,IPASS)
    +
    1117 IF (mod(iptr,8).NE.0) THEN
    +
    1118 iptr = iptr + 8 - mod(iptr,8)
    +
    1119 END IF
    +
    1120C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
    +
    1121C DETERMINE LOCATION FOR START
    +
    1122C OF SECOND ORDER VALUES
    +
    1123 kbds(15) = iptr / 8 + 12
    +
    1124C SAVE LOCATION OF SECOND ORDER VALUES
    +
    1125 CALL sbytec (ipfld,kbds(15),24,16)
    +
    1126C MOVE IN SECOND ORDER PACKED VALUES
    +
    1127 ix = (isoptr + 32) / 32
    +
    1128C 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
    +
    1133C PRINT *,'ISOVAL',ISOPTR,IX
    +
    1134C 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
    +
    1140C COMPUTE LENGTH OF DATA PORTION
    +
    1141 len = iptr / 8
    +
    1142C COMPUTE LENGTH OF BDS
    +
    1143 lenbds = len + 11
    +
    1144C -----------------------------------
    +
    1145C BYTES 1-3
    +
    1146C THIS FUNCTION COMPLETED BELOW
    +
    1147C WHEN LENGTH OF BDS IS KNOWN
    +
    1148 CALL sbytec (bds11,lenbds,0,24)
    +
    1149C 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)
    +
    1154C ENTER NUMBER OF FILL BITS
    +
    1155 CALL sbytec (bds11,nleft,28,4)
    +
    1156C 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)
    +
    1164C
    +
    1165C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE
    +
    1166C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    +
    1167C FLOATING POINT NUMBER
    +
    1168C REFERENCE VALUE
    +
    1169C FIRST TEST TO SEE IF
    +
    1170C ON 32 OR 64 BIT COMPUTER
    +
    1171C 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)
    +
    1179C
    +
    1180C BYTE 11
    +
    1181C
    +
    1182 CALL sbytec (bds11,kbds(11),80,8)
    +
    1183C
    +
    1184 klen = lenbds / 4 + 1
    +
    1185C PRINT *,'BDS11 LISTING',4,LENBDS
    +
    1186C CALL BINARY (BDS11,4)
    +
    1187C PRINT *,'IPFLD LISTING'
    +
    1188C CALL BINARY (IPFLD,KLEN)
    +
    1189 RETURN
    +
    +
    1190 END
    +
    1191C
    +
    1192C> @brief Determine number of bits to contain value.
    +
    1193C> @author Bill Cavanaugh @date 1993-06-23
    +
    1194
    +
    1195C> Calculate number of bits to contain value n, with a maximum of 32 bits.
    +
    1196C>
    +
    1197C> Program history log:
    +
    1198C> - Bill Cavanaugh 1993-06-23
    +
    1199C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1200C>
    +
    1201C> @param[in] N Integer value
    +
    1202C> @param[out] NBITS Number of bits to contain n
    +
    1203C>
    +
    1204C> @note Subprogram can be called from a multiprocessing environment.
    +
    1205C>
    +
    1206C> @author Bill Cavanaugh @date 1993-06-23
    +
    +
    1207 SUBROUTINE fi7505 (N,NBITS)
    +
    1208
    +
    1209 INTEGER N,NBITS
    +
    1210 INTEGER IBITS(31)
    +
    1211C
    +
    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/
    +
    1217C ----------------------------------------------------------------
    +
    1218C
    +
    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
    +
    1226C
    +
    1227C> @brief Select block of data for packing.
    +
    1228C> @author Bill Cavanaugh @date 1994-01-21
    +
    1229
    +
    1230C> Select a block of data for packing
    +
    1231C>
    +
    1232C> Program history log:
    +
    1233C> - Bill Cavanaugh 1994-01-21
    +
    1234C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1235C>
    +
    1236C> - Return address if encounter set of same values
    +
    1237C> @param[in] IWORK
    +
    1238C> @param[in] ISTART
    +
    1239C> @param[in] NPTS
    +
    1240C> @param[out] MAX
    +
    1241C> @param[out] MIN
    +
    1242C> @param[out] INRNGE
    +
    1243C>
    +
    1244C> @note Subprogram can be called from a multiprocessing environment.
    +
    1245C>
    +
    1246C> @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)
    +
    1252C
    +
    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/
    +
    1258C ----------------------------------------------------------------
    +
    1259C IDENTIFY NEXT BLOCK OF DATA FOR PACKING AND
    +
    1260C RETURN TO CALLER
    +
    1261C ********************************************************************
    +
    1262 istrta = istart
    +
    1263C
    +
    1264C GET BLOCK A
    +
    1265 CALL fi7516 (iwork,npts,inrnga,istrta,
    +
    1266 * max,min,mxval,lwide)
    +
    1267C ********************************************************************
    +
    1268C
    +
    1269 istrtb = istrta + inrnga
    +
    1270 2000 CONTINUE
    +
    1271C IF HAVE PROCESSED ALL DATA, RETURN
    +
    1272 IF (istrtb.GT.npts) THEN
    +
    1273C NO MORE DATA TO LOOK AT
    +
    1274 inrnge = inrnga
    +
    1275 RETURN
    +
    1276 END IF
    +
    1277C GET BLOCK B
    +
    1278 CALL fi7502 (iwork,istrtb,npts,isame)
    +
    1279 IF (isame.GE.15) THEN
    +
    1280C PRINT *,'BLOCK B HAS ALL IDENTICAL VALUES'
    +
    1281C PRINT *,'BLOCK A HAS INRNGE =',INRNGA
    +
    1282C BLOCK B CONTAINS ALL IDENTICAL VALUES
    +
    1283 inrnge = inrnga
    +
    1284C EXIT WITH BLOCK A
    +
    1285 RETURN
    +
    1286 END IF
    +
    1287C GET BLOCK B
    +
    1288C
    +
    1289 istrtb = istrta + inrnga
    +
    1290 CALL fi7516 (iwork,npts,inrngb,istrtb,
    +
    1291 * maxb,minb,mxvalb,lwideb)
    +
    1292C PRINT *,'BLOCK A',INRNGA,' BLOCK B',INRNGB
    +
    1293C ********************************************************************
    +
    1294C PERFORM TREND ANALYSIS TO DETERMINE
    +
    1295C IF DATA COLLECTION CAN BE IMPROVED
    +
    1296C
    +
    1297 ktrnd = lwide - lwideb
    +
    1298C PRINT *,'TREND',LWIDE,LWIDEB
    +
    1299 IF (ktrnd.LE.0) THEN
    +
    1300C PRINT *,'BLOCK A - SMALLER, SHOULD EXTEND INTO BLOCK B'
    +
    1301 mxval = ibits(lwide)
    +
    1302C
    +
    1303C IF BLOCK A REQUIRES THE SAME OR FEWER BITS
    +
    1304C LOOK AHEAD
    +
    1305C AND GATHER THOSE DATA POINTS THAT CAN
    +
    1306C BE RETAINED IN BLOCK A
    +
    1307C BECAUSE THIS BLOCK OF DATA
    +
    1308C USES FEWER BITS
    +
    1309C
    +
    1310 CALL fi7518 (iret,iwork,npts,istrta,inrnga,inrngb,
    +
    1311 * max,min,lwide,mxval)
    +
    1312 IF(iret.EQ.1) GO TO 8000
    +
    1313C 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
    +
    1320C PRINT *,'BLOCK A - LARGER, B SHOULD EXTEND BACK INTO A'
    +
    1321 mxvalb = ibits(lwideb)
    +
    1322C
    +
    1323C IF BLOCK B REQUIRES FEWER BITS
    +
    1324C LOOK BACK
    +
    1325C SHORTEN BLOCK A BECAUSE NEXT BLOCK OF DATA
    +
    1326C USES FEWER BITS
    +
    1327C
    +
    1328 CALL fi7517 (iret,iwork,npts,istrtb,inrnga,
    +
    1329 * maxb,minb,lwideb,mxvalb)
    +
    1330 IF(iret.EQ.1) GO TO 8000
    +
    1331C PRINT *,'17 INRNGA IS NOW ',INRNGA
    +
    1332 END IF
    +
    1333C
    +
    1334C PACK UP BLOCK A
    +
    1335C UPDATA POINTERS
    +
    1336 8000 CONTINUE
    +
    1337 inrnge = inrnga
    +
    1338C GET NEXT BLOCK A
    +
    1339 9000 CONTINUE
    +
    1340 RETURN
    +
    +
    1341 END
    +
    1342C
    +
    1343C> @brief Scan number of points.
    +
    1344C> @author Bill Cavanaugh @date 1994-01-21
    +
    1345
    +
    1346C> Scan forward from current position. collect points and
    +
    1347C> determine maximum and minimum values and the number
    +
    1348C> of points that are included. Forward search is terminated
    +
    1349C> by encountering a set of identical values, by reaching
    +
    1350C> the number of points selected or by reaching the end
    +
    1351C> of data.
    +
    1352C>
    +
    1353C> Program history log:
    +
    1354C> - Bill Cavavnaugh 1994-01-21
    +
    1355C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1356C>
    +
    1357C> - Return address if encounter set of same values
    +
    1358C> @param[in] IWORK Data array
    +
    1359C> @param[in] NPTS Number of points in data array
    +
    1360C> @param[in] ISTART Starting location in data
    +
    1361C> @param[out] INRNG Number of points selected
    +
    1362C> @param[out] MAX Maximum value of points
    +
    1363C> @param[out] MIN Minimum value of points
    +
    1364C> @param[out] MXVAL Maximum value that can be contained in lwidth bits
    +
    1365C> @param[out] LWIDTH Number of bits to contain max diff
    +
    1366C>
    +
    1367C> @note Subprogram can be called from a multiprocessing environment.
    +
    1368C>
    +
    1369C> @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)
    +
    1374C
    +
    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/
    +
    1380C ----------------------------------------------------------------
    +
    1381C
    +
    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
    +
    1400C
    +
    1401 DO 9000 lwidth = 1, 31
    +
    1402 IF (krng.LE.ibits(lwidth)) THEN
    +
    1403C PRINT *,'RETURNED',INRNG,' VALUES'
    +
    1404 RETURN
    +
    1405 END IF
    +
    1406 9000 CONTINUE
    +
    1407 RETURN
    +
    +
    1408 END
    +
    1409C
    +
    1410C> @brief Scan backward.
    +
    1411C> @author Bill Cavanaugh @date 1994-01-21
    +
    1412
    +
    1413C> Scan backwards until a value exceeds range of group b this may shorten group a
    +
    1414C>
    +
    1415C> Program history log:
    +
    1416C> - Bill Cavanaugh 1994-01-21
    +
    1417C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1418C> - Mark Iredell 1998-06-17 Removed alternate return
    +
    1419C>
    +
    1420C> @param[in] IWORK
    +
    1421C> @param[in] ISTRTB
    +
    1422C> @param[in] NPTS
    +
    1423C> @param[in] INRNGA
    +
    1424C> @param[out] IRET
    +
    1425C> @param[out] MAXB
    +
    1426C> @param[out] MINB
    +
    1427C> @param MXVALB
    +
    1428C> @param LWIDEB
    +
    1429C>
    +
    1430C> @note Subprogram can be called from a multiprocessing environment.
    +
    1431C>
    +
    1432C> @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)
    +
    1439C
    +
    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/
    +
    1445C ----------------------------------------------------------------
    +
    1446 iret=0
    +
    1447C PRINT *,' FI7517'
    +
    1448 npos = istrtb - 1
    +
    1449 itst = 0
    +
    1450 kset = inrnga
    +
    1451C
    +
    1452 1000 CONTINUE
    +
    1453C 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
    +
    1458C 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
    +
    1466C 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
    +
    1477C ----------------------------------------------------------------
    +
    1478C
    +
    1479 9000 CONTINUE
    +
    1480 RETURN
    +
    +
    1481 END
    +
    1482C
    +
    1483C> @brief Scan forward.
    +
    1484C> @author Bill Cavanaugh @date 1994-01-21
    +
    1485
    +
    1486C> Scan forward from start of block b towards end of block b
    +
    1487C> if next point under test forces a larger maxvala then
    +
    1488C> terminate indicating last point tested for inclusion
    +
    1489C> into block a.
    +
    1490C>
    +
    1491C> Program history log:
    +
    1492C> - Bill Cavanaugh 1994-01-21
    +
    1493C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1494C> - Mark Iredell 1998-06-17 Removed alternate return
    +
    1495C>
    +
    1496C> @param IWORK
    +
    1497C> @param ISTRTA
    +
    1498C> @param INRNGA
    +
    1499C> @param INRNGB
    +
    1500C> @param MAXA
    +
    1501C> @param MINA
    +
    1502C> @param LWIDEA
    +
    1503C> @param MXVALA
    +
    1504C> @param[in] NPTS
    +
    1505C> @param[out] IRET
    +
    1506C>
    +
    1507C> @note Subprogram can be called from a multiprocessing environment.
    +
    1508C>
    +
    1509C> @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)
    +
    1516C
    +
    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/
    +
    1522C ----------------------------------------------------------------
    +
    1523 iret=0
    +
    1524C PRINT *,' FI7518'
    +
    1525 npos = istrta + inrnga
    +
    1526 itst = 0
    +
    1527C
    +
    1528 1000 CONTINUE
    +
    1529 itst = itst + 1
    +
    1530 IF (itst.LE.inrngb) THEN
    +
    1531C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXA,MINA
    +
    1532 IF (iwork(npos).GT.maxa) THEN
    +
    1533 IF ((iwork(npos)-mina).GT.mxvala) THEN
    +
    1534C 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
    +
    1542C 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
    +
    1550C PRINT *,' ',ITST,INRNGA
    +
    1551 npos = npos +1
    +
    1552 GO TO 1000
    +
    1553 END IF
    +
    1554C ----------------------------------------------------------------
    +
    1555 9000 CONTINUE
    +
    1556 RETURN
    +
    +
    1557 END
    +
    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
    +
    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
    +
    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
    +
    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
    +
    fi7513
    subroutine fi7513(iwork, istart, npts, max, min, inrnge)
    Select block of data for packing.
    Definition w3fi75.f:1248
    +
    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
    +
    fi7518
    subroutine fi7518(iret, iwork, npts, istrta, inrnga, inrngb, maxa, mina, lwidea, mxvala)
    Scan forward.
    Definition w3fi75.f:1512
    +
    fi7517
    subroutine fi7517(iret, iwork, npts, istrtb, inrnga, maxb, minb, mxvalb, lwideb)
    Scan backward.
    Definition w3fi75.f:1435
    +
    fi7501
    subroutine fi7501(iwork, ipfld, npts, ibdsfl, bds11, len, lenbds, pds, refnce, iscal2, kwide)
    BDS second order packing.
    Definition w3fi75.f:537
    +
    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
    +
    fi7502
    subroutine fi7502(iwork, istart, npts, isame)
    Second order same value collection.
    Definition w3fi75.f:857
    +
    fi7505
    subroutine fi7505(n, nbits)
    Determine number of bits to contain value.
    Definition w3fi75.f:1208
    +
    fi7516
    subroutine fi7516(iwork, npts, inrng, istart, max, min, mxval, lwidth)
    Scan number of points.
    Definition w3fi75.f:1371
    +
    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
    +
    w3fi82
    subroutine w3fi82(ifld, fval1, fdiff1, npts, pds, igds)
    Accept an input array, convert to array of second differences.
    Definition w3fi82.f:31
    diff --git a/w3fi76_8f.html b/w3fi76_8f.html index 1e0c95cc..510b8d08 100644 --- a/w3fi76_8f.html +++ b/w3fi76_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi76.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi76.f File Reference
    +
    w3fi76.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi76 (pval, kexp, kmant, kbits)
     Converts floating point number from machine representation to grib representation (ibm370 32 bit f.p.).
     

    Detailed Description

    Convert to ibm370 floating point.

    @@ -107,8 +113,8 @@

    Definition in file w3fi76.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi76()

    + +

    ◆ w3fi76()

    @@ -117,25 +123,25 @@

    subroutine w3fi76 ( real  - PVAL, + pval, integer  - KEXP, + kexp, integer  - KMANT, + kmant, integer  - KBITS  + kbits  @@ -176,7 +182,7 @@

    diff --git a/w3fi76_8f.js b/w3fi76_8f.js index 317baf2c..5fc954b5 100644 --- a/w3fi76_8f.js +++ b/w3fi76_8f.js @@ -1,4 +1,4 @@ var w3fi76_8f = [ - [ "w3fi76", "w3fi76_8f.html#a5af5a733105c5ce75ddfe99f7249f999", null ] + [ "w3fi76", "w3fi76_8f.html#a9e0b5a3150bf143ba67534a40ddd2856", null ] ]; \ No newline at end of file diff --git a/w3fi76_8f_source.html b/w3fi76_8f_source.html index b9d7a24b..1181cb86 100644 --- a/w3fi76_8f_source.html +++ b/w3fi76_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi76.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,146 +81,154 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi76.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert to ibm370 floating point
    +
    3C> @author John Hennessy @date 1985-09-15
    +
    4
    +
    5C> Converts floating point number from machine
    +
    6C> representation to grib representation (ibm370 32 bit f.p.).
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - John Hennessy 1985-09-15
    +
    10C> - Ralph Jones 1992-09-23 Change name, add doc block
    +
    11C> - Ralph Jones 1993-10-27 Change to agree with hennessy changes
    +
    12C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    13C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive
    +
    14C>
    +
    15C> @param[in] PVAL Floating point number to be converted
    +
    16C> @param[in] KBITS Number of bits in computer word (32 or 64)
    +
    17C> @param[out] KEXP 8 Bit signed exponent
    +
    18C> @param[out] KMANT 24 Bit mantissa (fraction)
    +
    19C>
    +
    20C> @note Subprogram can be called from a multiprocessing environment.
    +
    21C>
    +
    22C> @author John Hennessy @date 1985-09-15
    +
    +
    23 SUBROUTINE w3fi76(PVAL,KEXP,KMANT,KBITS)
    +
    24C
    +
    25C********************************************************************
    +
    26C*
    +
    27C* NAME : CONFP3
    +
    28C*
    +
    29C* FUNCTION : CONVERT FLOATING POINT NUMBER FROM MACHINE
    +
    30C* REPRESENTATION TO GRIB REPRESENTATION.
    +
    31C*
    +
    32C* INPUT : PVAL - FLOATING POINT NUMBER TO BE CONVERTED.
    +
    33C* KBITS : KBITS - NUMBER OF BITS IN COMPUTER WORD
    +
    34C*
    +
    35C* OUTPUT : KEXP - 8 BIT SIGNED EXPONENT
    +
    36C* KMANT - 24 BIT MANTISSA
    +
    37C* PVAL - UNCHANGED.
    +
    38C*
    +
    39C* JOHN HENNESSY , ECMWF 18.06.91
    +
    40C*
    +
    41C********************************************************************
    +
    42C
    +
    43C
    +
    44C IMPLICIT NONE
    +
    45C
    +
    46 INTEGER IEXP
    +
    47 INTEGER ISIGN
    +
    48C
    +
    49 INTEGER KBITS
    +
    50 INTEGER KEXP
    +
    51 INTEGER KMANT
    +
    52C
    +
    53 REAL PVAL
    +
    54 REAL ZEPS
    +
    55 REAL ZREF
    +
    56C
    +
    57C TEST FOR FLOATING POINT ZERO
    +
    58C
    +
    59 IF (pval.EQ.0.0) THEN
    +
    60 kexp = 0
    +
    61 kmant = 0
    +
    62 GO TO 900
    +
    63 ENDIF
    +
    64C
    +
    65C SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY)
    +
    66C SET ZEPS TO 1.0E-8 FOR 32 BIT COMPUTERS
    +
    67C
    +
    68 IF (kbits.EQ.32) THEN
    +
    69 zeps = 1.0e-8
    +
    70 ELSE
    +
    71 zeps = 1.0e-12
    +
    72 ENDIF
    +
    73 zref = pval
    +
    74C
    +
    75C SIGN OF VALUE
    +
    76C
    +
    77 isign = 0
    +
    78 IF (zref.LT.0.0) THEN
    +
    79 isign = 128
    +
    80 zref = - zref
    +
    81 ENDIF
    +
    82C
    +
    83C EXPONENT
    +
    84C
    +
    85 iexp = int(alog(zref)*(1.0/alog(16.0))+64.0+1.0+zeps)
    +
    86C
    +
    87 IF (iexp.LT.0 ) iexp = 0
    +
    88 IF (iexp.GT.127) iexp = 127
    +
    89C
    +
    90C MANTISSA
    +
    91C
    +
    92C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
    +
    93C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
    +
    94C
    +
    95 kmant = nint(zref/16.0**(iexp-70))
    +
    96C
    +
    97C CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS
    +
    98C 16777215 = 2**24 - 1
    +
    99C
    +
    100 IF (kmant.GT.16777215) THEN
    +
    101 iexp = iexp + 1
    +
    102C
    +
    103C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
    +
    104C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
    +
    105C
    +
    106 kmant = nint(zref/16.0**(iexp-70))
    +
    107C
    +
    108C CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN
    +
    109C
    +
    110 IF (kmant.GT.16777215) THEN
    +
    111 print *,'BAD MANTISSA VALUE FOR PVAL = ',pval
    +
    112 ENDIF
    +
    113 ENDIF
    +
    114C
    +
    115C ADD SIGN BIT TO EXPONENT.
    +
    116C
    +
    117 kexp = iexp + isign
    +
    118C
    +
    119 900 CONTINUE
    +
    120C
    +
    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/w3fi78_8f.html b/w3fi78_8f.html index a086a24a..6cc0b011 100644 --- a/w3fi78_8f.html +++ b/w3fi78_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi78.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi78.f File Reference
    +
    w3fi78.f File Reference
    @@ -94,41 +100,41 @@

    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...
     
    subroutine fi7801 (iptr, ident, msga, istack, iwork, aname, kdata, ivals, mstack, aunits, kdesc, mwidth, mref, mscale, knr, index, maxr, maxd, iunitb, iunitd)
     Data extraction.
     
    subroutine fi7802 (iptr, ident, msga, kdata, kdesc, ll, mstack, aunits, mwidth, mref, mscale, jdesc, ivals, j, maxr, maxd)
     Process standard descriptor.
     
    subroutine fi7803 (iptr, ident, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, jdesc, maxr, maxd)
     Process compressed data.
     
    subroutine fi7804 (iptr, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, ll, jdesc, maxr, maxd)
     Process serial data.
     
    subroutine fi7805 (iptr, ident, msga, iwork, lx, ly, kdata, ll, knr, mstack, maxr, maxd)
     Process a replication descriptor.
     
    subroutine fi7806 (iptr, lx, ly, ident, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, ll, kdesc, iwork, jdesc, maxr, maxd)
     Process operator descriptors.
     
    subroutine fi7807 (iptr, iwork, itbld, jdesc, maxd)
     Process queue descriptor.
     
    subroutine fi7808 (iptr, iwork, lf, lx, ly, jdesc, maxd)
     Program history log:
     
    subroutine fi7809 (ident, mstack, kdata, iptr, maxr, maxd)
     Reformat profiler w hgt increments.
     
    subroutine fi7810 (ident, mstack, kdata, iptr, maxr, maxd)
     Reformat profiler edition 2 data.
     
    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.
     

    Detailed Description

    BUFR Message decoder.

    @@ -137,8 +143,8 @@

    Definition in file w3fi78.f.

    Function/Subroutine Documentation

    - -

    ◆ fi7801()

    + +

    ◆ fi7801()

    @@ -147,121 +153,121 @@

    subroutine fi7801 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(*)  - ISTACK, + istack, integer, dimension(*)  - IWORK, + iwork, character*40, dimension(*)  - ANAME, + aname, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, character*24, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - KDESC, + kdesc, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer, dimension(maxr)  - KNR, + knr, integer  - INDEX, + index,   - MAXR, + maxr,   - MAXD, + maxd,   - IUNITB, + iunitb,   - IUNITD  + iunitd  @@ -282,8 +288,8 @@

    Parameters
    - - + + @@ -301,15 +307,15 @@

    [out]

    - +
    [in]IPTRSee w3fi78() routine docblock
    [in]IDENTSee w3fi78() routine docblock
    [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
    MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    IVALS
    KNRError return: IPTR(1)
      +
    KNR
    +
    + +

    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
    @@ -317,8 +323,8 @@

    -

    ◆ fi7802()

    + +

    ◆ fi7802()

    @@ -327,97 +333,97 @@

    subroutine fi7802 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - KDESC, + kdesc,   - LL, + ll, integer, dimension(2,maxd)  - MSTACK, + mstack, character*24, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer  - JDESC, + jdesc, integer, dimension(*)  - IVALS, + ivals, integer  - J, + j,   - MAXR, + maxr,   - MAXD  + maxd  @@ -451,10 +457,11 @@

    LL JDESC IVALS - JError return: IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist in table b. + J +

    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
    @@ -462,8 +469,8 @@

    -

    ◆ fi7803()

    + +

    ◆ fi7803()

    @@ -472,79 +479,79 @@

    subroutine fi7803 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer  - J, + j, integer  - JDESC, + jdesc,   - MAXR, + maxr,   - MAXD  + maxd  @@ -565,8 +572,8 @@

    Parameters
    - - + + @@ -588,8 +595,8 @@

    -

    ◆ fi7804()

    + +

    ◆ fi7804()

    @@ -598,79 +605,79 @@

    subroutine fi7804

    - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -703,10 +710,11 @@

    [out]

    - +
    [in]IPTRSee w3fi78() routine docblock
    [in]IDENTSee w3fi78() routine docblock
    [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
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) MSGA, msga,
    integer, dimension(maxr,maxd) KDATA, kdata,
    integer, dimension(*) IVALS, ivals,
    integer, dimension(2,maxd) MSTACK, mstack,
    integer, dimension(*) MWIDTH, mwidth,
    integer, dimension(700,3) MREF, mref,
    integer, dimension(*) MSCALE, mscale,
    integer J, j,
    integer LL, ll,
    integer JDESC, jdesc,
     MAXR, maxr,
     MAXD maxd 
    MWIDTHBit width for value of descriptor
    MSTACK
    LL
    JDESCError return: IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
    JDESC
     +

    Error return: IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8

    Author
    Bill Cavanaugh
    Date
    1988-09-01
    @@ -714,8 +722,8 @@

    -

    ◆ fi7805()

    + +

    ◆ fi7805()

    @@ -724,73 +732,73 @@

    subroutine fi7805 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxd)  - IWORK, + iwork, integer  - LX, + lx, integer  - LY, + ly, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer  - LL, + ll, integer, dimension(maxr)  - KNR, + knr, integer, dimension(2,maxd)  - MSTACK, + mstack,   - MAXR, + maxr,   - MAXD  + maxd  @@ -819,14 +827,14 @@

    MSGA LL KNR - MSTACKError return: IPTR(1):
      -
    • = 12 Data descriptor qualifier does not follow delayed replication descriptor
      • -
    • = 20 Exceeded count for delayed replication pass
      • -
    - + MSTACK +

    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
    @@ -834,8 +842,8 @@

    -

    ◆ fi7806()

    + +

    ◆ fi7806()

    @@ -844,109 +852,109 @@

    subroutine fi7806 ( integer, dimension(*)  - IPTR, + iptr, integer  - LX, + lx, integer  - LY, + ly, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(*)  - MWIDTH, + mwidth, integer, dimension(700,3)  - MREF, + mref, integer, dimension(*)  - MSCALE, + mscale, integer  - J, + j, integer  - LL, + ll, integer, dimension(*)  - KDESC, + kdesc, integer, dimension(*)  - IWORK, + iwork, integer  - JDESC, + jdesc,   - MAXR, + maxr,   - MAXD  + maxd  @@ -984,10 +992,11 @@

    LL KDESC JDESC - IWORKError return: IPTR(1) = 5 - Erroneous X value in data descriptor operator + IWORK +

    Error return: IPTR(1) = 5 - Erroneous X value in data descriptor operator

    Author
    Bill Cavanaugh
    Date
    1988-09-01
    @@ -995,8 +1004,8 @@

    -

    ◆ fi7807()

    + +

    ◆ fi7807()

    @@ -1005,31 +1014,31 @@

    subroutine fi7807 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IWORK, + iwork, integer, dimension(500,11)  - ITBLD, + itbld, integer  - JDESC, + jdesc,   - MAXD  + maxd  @@ -1062,8 +1071,8 @@

    -

    ◆ fi7808()

    + +

    ◆ fi7808()

    @@ -1072,43 +1081,43 @@

    subroutine fi7808 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IWORK, + iwork, integer  - LF, + lf, integer  - LX, + lx, integer  - LY, + ly, integer  - JDESC, + jdesc,   - MAXD  + maxd  @@ -1123,7 +1132,7 @@

    Date
    1988-09-01 - Bill Cavanaugh 1988-09-01
    Parameters
    - + @@ -1140,8 +1149,8 @@

    -

    ◆ fi7809()

    + +

    ◆ fi7809()

    @@ -1150,37 +1159,37 @@

    subroutine fi7809

    - + - + - + - + - + - + @@ -1232,8 +1241,8 @@

    -

    ◆ fi7810()

    + +

    ◆ fi7810()

    @@ -1242,37 +1251,37 @@

    subroutine fi7810

    - + - + - + - + - + - + @@ -1324,8 +1333,8 @@

    -

    ◆ w3fi78()

    + +

    ◆ w3fi78()

    @@ -1334,73 +1343,73 @@

    subroutine w3fi78

    - + - + - + - + - + - + - + - + - + - + - + - + @@ -1422,8 +1431,8 @@

    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 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
    • @@ -1437,7 +1446,7 @@

    fi7810() has been added to permit reformatting of profiler data in edition 2. +
  • Bill Cavanaugh 93-01-26 Subroutine fi7810() has been added to permit reformatting of profiler data in edition 2.
    • Parameters

    [in,out]IPTRSee w3fi78() routine docblock
    [in,out]IPTRSee w3fi78() routine docblock
    [in]IWORKWorking descriptor list
    LF
    LX
    ( integer, dimension(*) IDENT, ident,
    integer, dimension(2,maxd) MSTACK, mstack,
    integer, dimension(maxr,maxd) KDATA, kdata,
    integer, dimension(*) IPTR, iptr,
     MAXR, maxr,
     MAXD maxd 
    ( integer, dimension(*) IDENT, ident,
    integer, dimension(2,maxd) MSTACK, mstack,
    integer, dimension(maxr,maxd) KDATA, kdata,
    integer, dimension(*) IPTR, iptr,
     MAXR, maxr,
     MAXD maxd 
    ( integer, dimension(*) IPTR, iptr,
    integer, dimension(*) IDENT, ident,
    integer, dimension(*) MSGA, msga,
    integer, dimension(*) ISTACK, istack,
    integer, dimension(2,maxd) MSTACK, mstack,
    integer, dimension(maxr,maxd) KDATA, kdata,
    integer, dimension(maxr) KNR, knr,
    integer INDEX, index,
     MAXR, maxr,
     MAXD, maxd,
     IUNITB, iunitb,
     IUNITD iunitd 
    @@ -1573,11 +1582,11 @@

    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.

    +

    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
      • @@ -1604,9 +1613,9 @@

    • 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())
      • +
    • 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
    @@ -1621,7 +1630,7 @@

    diff --git a/w3fi78_8f.js b/w3fi78_8f.js index 2ee1d783..1ff21dc9 100644 --- a/w3fi78_8f.js +++ b/w3fi78_8f.js @@ -1,14 +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 ] + [ "fi7801", "w3fi78_8f.html#a49815e08605c968b2fecd0dcbdabe304", null ], + [ "fi7802", "w3fi78_8f.html#af68f1a1dbbc01729e49a3f9b5d8ff62e", null ], + [ "fi7803", "w3fi78_8f.html#a9b9826d7fd1020f442d3d2a6c13a8239", null ], + [ "fi7804", "w3fi78_8f.html#a7f339d55f5933f4ab915a26098bb0e6e", null ], + [ "fi7805", "w3fi78_8f.html#ae8c42f7f8ccfa1726cb092ddd414c87a", null ], + [ "fi7806", "w3fi78_8f.html#a1ddd77e21e7b12f733c96d0d14092208", null ], + [ "fi7807", "w3fi78_8f.html#a4fe95ebc53f5ab1c5effb0a2cf9a1824", null ], + [ "fi7808", "w3fi78_8f.html#aab7538e5347a195c3eaae1a6bd035a5b", null ], + [ "fi7809", "w3fi78_8f.html#a3c7efbd2d1d06f5eadeb47912d1f1b88", null ], + [ "fi7810", "w3fi78_8f.html#aa7e94634a4e5b52d7a1fcc00d163180e", null ], + [ "w3fi78", "w3fi78_8f.html#a412826ca598b211d75aa9b6be5dded05", null ] ]; \ No newline at end of file diff --git a/w3fi78_8f_source.html b/w3fi78_8f_source.html index 9810b170..99326427 100644 --- a/w3fi78_8f_source.html +++ b/w3fi78_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi78.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,2795 +81,2823 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi78.f
    +
    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
    -
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    -
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    -
    w3fc05
    subroutine w3fc05(U, V, DIR, SPD)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition: w3fc05.f:29
    -
    fi7810
    subroutine fi7810(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
    Reformat profiler edition 2 data.
    Definition: w3fi78.f:2460
    -
    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
    -
    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
    -
    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
    -
    fi7809
    subroutine fi7809(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
    Reformat profiler w hgt increments.
    Definition: w3fi78.f:2067
    -
    fi7808
    subroutine fi7808(IPTR, IWORK, LF, LX, LY, JDESC, MAXD)
    Program history log:
    Definition: w3fi78.f:2009
    -
    fi7803
    subroutine fi7803(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, JDESC, MAXR, MAXD)
    Process compressed data.
    Definition: w3fi78.f:1151
    -
    fi7807
    subroutine fi7807(IPTR, IWORK, ITBLD, JDESC, MAXD)
    Process queue descriptor.
    Definition: w3fi78.f:1903
    -
    fi7804
    subroutine fi7804(IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC, MAXR, MAXD)
    Process serial data.
    Definition: w3fi78.f:1420
    -
    fi7805
    subroutine fi7805(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
    Process a replication descriptor.
    Definition: w3fi78.f:1589
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief BUFR Message decoder.
    +
    3C> @author Bill Cavanaugh @date 1988-08-31
    +
    4
    +
    5C> This set of routines will decode a BUFR message and
    +
    6C> place information extracted from the BUFR message into selected
    +
    7C> arrays for the user.The array kdata can now be sized by the user
    +
    8C> by indicating the maximum number of substes and the maximum
    +
    9C> number of descriptors that are expected in the course of decoding
    +
    10C> selected input data. This allows for realistic sizing of kdata
    +
    11C> and the mstack arrays. This version also allows for the inclusion
    +
    12C> of the unit numbers for tables b and d into the
    +
    13C> argument list. This routine does not include ifod processing.
    +
    14C>
    +
    15C> Program history log:
    +
    16C> - Bill Cavanaugh 88-08-31
    +
    17C> - Bill Cavanaugh 90-12-07 Now utilizing gbyte routines to gather
    +
    18C> and separate bit fields. This should improve
    +
    19C> (decrease) the time it takes to decode any
    +
    20C> BUFR message. Have entered coding that will
    +
    21C> permit processing BUFR editions 1 and 2.
    +
    22C> improved and corrected the conversion into
    +
    23C> ifod format of decoded BUFR messages.
    +
    24C> - Bill Cavanaugh 91-01-18 Program/routines modified to properly handle
    +
    25C> serial profiler data.
    +
    26C> - Bill Cavanaugh 91-04-04 Modified to handle text supplied thru
    +
    27C> descriptor 2 05 yyy.
    +
    28C> - Bill Cavanaugh 91-04-17 Errors in extracting and scaling data
    +
    29C> corrected. Improved handling of nested queue descriptors is added.
    +
    30C> - Bill Cavanaugh 91-05-10 Array 'data' has been enlarged to real*8
    +
    31C> to better contain very large numbers more accurately. the preious size
    +
    32C> real*4 could not contain sufficient significant digits. Coding has been
    +
    33C> introduced to process new table c descriptor 2 06 yyy which permits in
    +
    34C> line processing of a local descriptor even if the descriptor is not
    +
    35C> contained in the users table b. A second routine to process ifod messages
    +
    36C> (ifod0) has been removed in favor of the improved processing of the one
    +
    37C> remaining (ifod1). New coding has been introduced to permit processing of
    +
    38C> BUFR messages based on BUFR edition up to and including edition 2. Please
    +
    39C> note increased size requirements for arrays ident(20) and iptr(40).
    +
    40C> - Bill Cavanaugh 91-07-26 Add array mtime to calling sequence to
    +
    41C> permit inclusion of receipt/transfer times to ifod messages.
    +
    42C> - Bill Cavanaugh 91-09-25 All processing of decoded BUFR data into
    +
    43C> ifod (a local use reformat of BUFR data) has been isolated from this set
    +
    44C> of routines. For those interested in the ifod form, see w3fl05() in the
    +
    45C> w3lib routines.
    +
    46C> Processing of BUFR messages containing delayed replication has been altered
    +
    47C> so that single subsets (reports) and and a matching descriptor list for
    +
    48C> that particular subset will be passed to the user will be passed to the
    +
    49C> user one at a time to assure that each subset can be fully defined with a
    +
    50C> minimum of reprocessing.
    +
    51C> Processing of associated fields has been tested with messages containing
    +
    52C> non-compressed data.
    +
    53C> In order to facilitate user processing a matching list of scale factors are
    +
    54C> included with the expanded descriptor list (mstack).
    +
    55C> - Bill Cavanaugh 91-11-21 Processing of descriptor 2 03 yyy
    +
    56C> has corrected to agree with fm94 standards.
    +
    57C> - Bill Cavanaugh 91-12-19 Calls to fi7803() and fi7804() have been
    +
    58C> corrected to agree called program argument list. Some additional entries
    +
    59C> have been included for communicating with data access routines. Additional
    +
    60C> error exit provided for the case where table b is damaged.
    +
    61C> - Bill Cavanaugh 92-01-24 Routines fi7801(), fi7803() and fi7804()
    +
    62C> have been modified to handle associated fields all descriptors are set to
    +
    63C> echo to mstack(1,n)
    +
    64C> - Bill Cavanaugh 92-05-21 Further expansion of information collected
    +
    65C> from within upper air soundings has produced the necessity to expand some
    +
    66C> of the processing and output arrays. (see remarks below)
    +
    67C> - Bill Cavanaugh 92-06-29 Corrected descriptor denoting height of
    +
    68C> each wind level for profiler conversions.
    +
    69C> - Bill Cavanaugh 92-07-23 Expansion of table b requires adjustment
    +
    70C> of arrays to contain table b values needed to assist in the decoding
    +
    71C> process.
    +
    72C> ARRAYS CONTAINING DATA FROM TABLE B
    +
    73C> - KDESC Descriptor
    +
    74C> - ANAME Descriptor name
    +
    75C> - AUNITS Units for descriptor
    +
    76C> - MSCALE Scale for value of descriptor
    +
    77C> - MREF Reference value for descriptor
    +
    78C> - MWIDTH Bit width for value of descriptor
    +
    79C> - Bill Cavanaugh 92-09-09 First encounter with operator descriptor
    +
    80C> 2 05 yyy showed error in decoding. That error is corrected with this
    +
    81C> implementation. Further testing of upper air data has encountered
    +
    82C> the condition of large (many level) soundings arrays in the decoder have
    +
    83C> been expanded (again) to allow for this condition.
    +
    84C> - Bill Cavanaugh 92-10-02 Modified routine to reformat profiler data
    +
    85C> (fi7809) to show descriptors, scale value and data in proper order.
    +
    86C> Corrected an error that prevented user from assigning the second dimension
    +
    87C> of kdata(500,*).
    +
    88C> - Bill Cavanaugh 92-10-20 Removed error that prevented full implementation
    +
    89C> of previous corrections and made corrections to table b to bring it up to
    +
    90C> date. changes include proper reformat of profiler data and user capability
    +
    91C> for assigning second dimension of kdata array.
    +
    92C> - Bill Cavanaugh 92-12-09 Thanks to dennis keyser for the suggestions and
    +
    93C> coding, this implementation will allow the inclusion of unit numbers for
    +
    94C> tables b & d, and in addition allows for realistic sizing of kdata and
    +
    95C> mstack arrays by the user. As of this implementation, the upper size limit
    +
    96C> for a BUFR message allows for a message size greater than 10000 bytes.
    +
    97C> - Bill Cavanaugh 93-01-26 Subroutine fi7810() has been added to permit
    +
    98C> reformatting of profiler data in edition 2.
    +
    99C>
    +
    100C> @param[in] MSGA Array containing supposed BUFR message size is determined
    +
    101C> by user, can be greater than 10000 bytes.
    +
    102C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
    +
    103C> a BUFR message.
    +
    104C> @param[in] MAXD Maximum number of descriptor combinations that may be
    +
    105C> processed; Upper air data and some satellite data require a value for maxd
    +
    106C> of 1600, but for most other data a value for maxd of 500 will suffice.
    +
    107C> @param[in] IUNITB Unit number of data set holding table b
    +
    108C> @param[in] IUNITD Unit number of data set holding table d
    +
    109C> @param KNR
    +
    110C> @param[out] ISTACK Original array of descriptors extracted from source
    +
    111C> BUFR message.
    +
    112C> @param[out] MSTACK (A,B)
    +
    113C> - Level b - descriptor number (limited to value of
    +
    114C> input argument maxd)
    +
    115C> - level a = 1 descriptor = 2 10**N Scaling to return to original value
    +
    116C> @param[out] IPTR Utility array
    +
    117C> - IPTR( 1)- Error return.
    +
    118C> - IPTR( 2)- Byte count section 1.
    +
    119C> - IPTR( 3)- Pointer to start of section 1.
    +
    120C> - IPTR( 4)- Byte count section 2.
    +
    121C> - IPTR( 5)- Pointer to start of section 2.
    +
    122C> - IPTR( 6)- Byte count section 3.
    +
    123C> - IPTR( 7)- Pointer to start of section 3.
    +
    124C> - IPTR( 8)- Byte count section 4.
    +
    125C> - IPTR( 9)- Pointer to start of section 4.
    +
    126C> - IPTR(10)- Start of requested subset, reserved for dar.
    +
    127C> - IPTR(11)- Current descriptor ptr in iwork.
    +
    128C> - IPTR(12)- Last descriptor pos in iwork.
    +
    129C> - IPTR(13)- Last descriptor pos in istack.
    +
    130C> - IPTR(14)- Number of table b entries.
    +
    131C> - IPTR(15)- Requested subset pointer, reserved for dar.
    +
    132C> - IPTR(16)- Indicator for existance of section 2.
    +
    133C> - IPTR(17)- Number of reports processed.
    +
    134C> - IPTR(18)- Ascii/text event.
    +
    135C> - IPTR(19)- Pointer to start of BUFR message.
    +
    136C> - IPTR(20)- Number of lines from table d.
    +
    137C> - IPTR(21)- Table b switch.
    +
    138C> - IPTR(22)- Table d switch.
    +
    139C> - IPTR(23)- Code/flag table switch.
    +
    140C> - IPTR(24)- Aditional words added by text info.
    +
    141C> - IPTR(25)- Current bit number.
    +
    142C> - IPTR(26)- Data width change.
    +
    143C> - IPTR(27)- Data scale change.
    +
    144C> - IPTR(28)- Data reference value change.
    +
    145C> - IPTR(29)- Add data associated field.
    +
    146C> - IPTR(30)- Signify characters.
    +
    147C> - IPTR(31)- Number of expanded descriptors in mstack.
    +
    148C> - IPTR(32)- Current descriptor segment f.
    +
    149C> - IPTR(33)- Current descriptor segment x.
    +
    150C> - IPTR(34)- Current descriptor segment y.
    +
    151C> - IPTR(35)- Unused.
    +
    152C> - IPTR(36)- Next descriptor may be undecipherable.
    +
    153C> - IPTR(37)- Unused.
    +
    154C> - IPTR(38)- Unused.
    +
    155C> - IPTR(39)- Delayed replication flag.
    +
    156C> - 0 No delayed replication.
    +
    157C> - 1 Message contains delayed replication.
    +
    158C> - IPTR(40)- Number of characters in text for curr descriptor.
    +
    159C> @param[out] IDENT Array contains message information extracted from BUFR
    +
    160C> Message.
    +
    161C> - IDENT(1) Edition number (byte 4, section 1)
    +
    162C> - IDENT(2) Originating center (bytes 5-6, section 1)
    +
    163C> - IDENT(3) Update sequence (byte 7, section 1)
    +
    164C> - IDENT(4) Optional section (byte 8, section 1)
    +
    165C> - IDENT(5) BUFR message type (byte 9, section 1)
    +
    166C> - 0 = Surface (land).
    +
    167C> - 1 = Surface (ship).
    +
    168C> - 2 = Vertical soundings other than satellite.
    +
    169C> - 3 = Vertical soundings (satellite).
    +
    170C> - 4 = Sngl lvl upper-air other than satellite.
    +
    171C> - 5 = Sngl lvl upper-air (satellite).
    +
    172C> - 6 = Radar.
    +
    173C> - IDENT(6) BUFR msg sub-type (byte 10, section 1).
    +
    174C> | TYPE | SBTYP |
    +
    175C> | :--- | :---- |
    +
    176C> | 2 | 7 = PROFILER |
    +
    177C> - IDENT(7) (bytes 11-12, section 1).
    +
    178C> - IDENT(8) Year of century (byte 13, section 1).
    +
    179C> - IDENT(9) Month of year (byte 14, section 1).
    +
    180C> - IDENT(10) Day of month (byte 15, section 1).
    +
    181C> - IDENT(11) Hour of day (byte 16, section 1).
    +
    182C> - IDENT(12) Minute of hour (byte 17, section 1).
    +
    183C> - IDENT(13) Rsvd by adp centers (byte 18, section 1).
    +
    184C> - IDENT(14) Nr of data subsets (byte 5-6, section 3).
    +
    185C> - IDENT(15) Observed flag (byte 7, bit 1, section 3).
    +
    186C> - IDENT(16) Compression flag (byte 7, bit 2, section 3).
    +
    187C> - IDENT(17) Master table number(byte 4, section 1, ed 2 or gtr).
    +
    188C> @param[out] KDATA Array containing decoded reports from BUFR message.
    +
    189C> KDATA(report number,parameter number)
    +
    190C> (Report number limited to value of input argument maxr and parameter number
    +
    191C> limited to value of input argument maxd)
    +
    192C> Arrays containing data from table b:
    +
    193C> - ANAME Descriptor name
    +
    194C> - AUNITS Units for descriptor
    +
    195C> - MSCALE Scale for value of descriptor
    +
    196C> - MREF Reference value for descriptor
    +
    197C> - MWIDTH Bit width for value of descriptor
    +
    198C> @param[out] INDEX Pointer to available subset
    +
    199C>
    +
    200C> Error returns:
    +
    201C> IPTR(1):
    +
    202C> - 1 'BUFR' Not found in first 125 characters
    +
    203C> - 2 '7777' Not found in location determined by
    +
    204C> by using counts found in each section. one or
    +
    205C> more sections have an erroneous byte count or
    +
    206C> characters '7777' are not in test message.
    +
    207C> - 3 Message contains a descriptor with f=0 that does
    +
    208C> not exist in table b.
    +
    209C> - 4 Message contains a descriptor with f=3 that does
    +
    210C> not exist in table d.
    +
    211C> - 5 Message contains a descriptor with f=2 with the
    +
    212C> value of x outside the range 1-5.
    +
    213C> - 6 Descriptor element indicated to have a flag value
    +
    214C> does not have an entry in the flag table.
    +
    215C> (to be activated)
    +
    216C> - 7 Descriptor indicated to have a code value does
    +
    217C> not have an entry in the code table.
    +
    218C> (to be activated)
    +
    219C> - 8 Error reading table d
    +
    220C> - 9 Error reading table b
    +
    221C> - 10 Error reading code/flag table
    +
    222C> - 11 Descriptor 2 04 004 not followed by 0 31 021
    +
    223C> - 12 Data descriptor operator qualifier does not follow
    +
    224C> delayed replication descriptor.
    +
    225C> - 13 Bit width on ascii characters not a multiple of 8
    +
    226C> - 14 Subsets = 0, no content bulletin
    +
    227C> - 20 Exceeded count for delayed replication pass
    +
    228C> - 21 Exceeded count for non-delayed replication pass
    +
    229C> - 27 Non zero lowest on text data
    +
    230C> - 28 Nbinc not nr of characters
    +
    231C> - 29 Table b appears to be damaged
    +
    232C> - 99 No more subsets (reports) available in current
    +
    233C> BUFR mesage
    +
    234C> - 400 Number of subsets exceeds the value of input
    +
    235C> argument maxr; must increase maxr to value of
    +
    236C> ident(14) in calling program
    +
    237C> - 401 Number of parameters (and associated fields)
    +
    238C> exceeds limits of this program.
    +
    239C> - 500 Value for nbinc has been found that exceeds
    +
    240C> standard width plus any bit width change.
    +
    241C> check all bit widths up to point of error.
    +
    242C> - 501 Corrected width for descriptor is 0 or less
    +
    243C>
    +
    244C> On the initial call to w3fi78() with a BUFR message the argument
    +
    245C> index must be set to zero (index = 0). On the return from w3fi78()
    +
    246C> 'index' will be set to the next available subset/report. When
    +
    247C> there are no more subsets available a 99 err return will occur.
    +
    248C>
    +
    249C> If the original BUFR message does not contain delayed replication
    +
    250C> the BUFR message will be completely decoded and 'index' will point
    +
    251C> to the first decoded subset. The users will then have the option
    +
    252C> of indexing through the subsets on their own or by recalling this
    +
    253C> routine (without resetting 'index') to have the routine do the
    +
    254C> indexing.
    +
    255C>
    +
    256C> If the original BUFR message does contain delayed replication
    +
    257C> one subset/report will be decoded at a time and passed back to
    +
    258C> the user. This is not an option.
    +
    259C>
    +
    260C> =============================================
    +
    261C> TO USE THIS ROUTINE
    +
    262C> --------------------------------
    +
    263C> - 1. Read in BUFR message
    +
    264C> - 2. Set index = 0
    +
    265C> - 3. CALL W3FI78()
    +
    266C> - 4.
    +
    267C> @code
    +
    268C> IF (IPTR(1).EQ.99) THEN
    +
    269C> NO MORE SUBSETS
    +
    270C> EITHER GO TO 1
    +
    271C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    272C> END IF
    +
    273C> @endcode
    +
    274C> - 5.
    +
    275C> @code
    +
    276C> IF (IPTR(1).NE.0) THEN
    +
    277C> ERROR CONDITION
    +
    278C> EITHER GO TO 1
    +
    279C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    280C> END IF
    +
    281C> @endcode
    +
    282C> - 6. The value of index indicates the active subset so
    +
    283C> @code
    +
    284C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
    +
    285C> W3FL05 ( )
    +
    286C> ELSE
    +
    287C> PROCESS DECODED INFORMATION AS REQUIRED
    +
    288C> END IF
    +
    289C> @endcode
    +
    290C> - 7. GO TO 3
    +
    291C>
    +
    292C> The arrays to contain the output information are defined as follows:
    +
    293C> - KDATA(A,B) Is the a data entry (integer value) where a is the maximum
    +
    294C> number of reports/subsets that may be contained in the bufr message (this
    +
    295C> is now set to "maxr" which is passed as an input argument to w3fi78()), and
    +
    296C> where b is the maximum number of descriptor combinations that may be
    +
    297C> processed (this is now set to "maxd" which is also passed as an input
    +
    298C> argument to w3fi78(); Upper air data and some satellite data require a
    +
    299C> value for maxd of 1600, but for most other data a value for maxd of 500
    +
    300C> will suffice).
    +
    301C> - MSTACK(1,B) Contains the descriptor that matches the data entry (max.
    +
    302C> value for b is now "maxd" which is passed as an input argument to w3fi78())
    +
    303C> - MSTACK(2,B) Is the scale (power of 10) to be applied to the data (max.
    +
    304C> value for b is now "maxd" which is passed as an input argument to w3fi78())
    +
    305C>
    +
    306C> @author Bill Cavanaugh @date 1988-08-31
    +
    +
    307 SUBROUTINE w3fi78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
    +
    308 * MAXR,MAXD,IUNITB,IUNITD)
    +
    309C
    +
    310 CHARACTER*40 ANAME(700)
    +
    311 CHARACTER*24 AUNITS(700)
    +
    312C
    +
    313C
    +
    314C
    +
    315 INTEGER MSGA(*)
    +
    316 INTEGER IPTR(*)
    +
    317 INTEGER KDATA(MAXR,MAXD)
    +
    318 INTEGER MSTACK(2,MAXD)
    +
    319C
    +
    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
    +
    330C
    +
    331 CHARACTER*4 DIRID(2)
    +
    332C
    +
    333 LOGICAL SEC2
    +
    334C
    +
    335 SAVE
    +
    336C
    +
    337C PRINT *,' W3FI78 DECODER'
    +
    338C INITIALIZE ERROR RETURN
    +
    339 iptr(1) = 0
    +
    340 IF (index.GT.0) THEN
    +
    341C HAVE RE-ENTRY
    +
    342 index = index + 1
    +
    343C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
    +
    344 IF (index.GT.ident(14)) THEN
    +
    345C 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,
    +
    351C
    +
    352 * ivals,mstack,
    +
    353 * aunits,kdesc,mwidth,mref,mscale,knr,index,maxr,maxd,
    +
    354 * iunitb,iunitd)
    +
    355C
    +
    356 END IF
    +
    357 END IF
    +
    358 RETURN
    +
    359 ELSE
    +
    360 index = 1
    +
    361C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
    +
    362 END IF
    +
    363 iptr(39) = 0
    +
    364C 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
    +
    373C 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
    +
    384C TEST FOR EDITION NUMBER
    +
    385C ======================
    +
    386 CALL gbyte (msga,ident(1),inofst+24,8)
    +
    387C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
    +
    388C
    +
    389 IF (ident(1).GE.2) THEN
    +
    390C 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)
    +
    395C IF (ILAST.EQ.926365495) THEN
    +
    396C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
    +
    397C END IF
    +
    398 inofst = inofst + 32
    +
    399C GET SECTION 1 COUNT
    +
    400 iptr(3) = inofst
    +
    401 CALL gbyte (msga,ivals,inofst,24)
    +
    402C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    403 inofst = inofst + 24
    +
    404 iptr( 2) = ivals(1)
    +
    405C GET MASTER TABLE
    +
    406 CALL gbyte (msga,ivals,inofst,8)
    +
    407 inofst = inofst + 8
    +
    408 ident(17) = ivals(1)
    +
    409C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
    +
    410 ELSE
    +
    411 iptr(3) = inofst
    +
    412C GET SECTION 1 COUNT
    +
    413 CALL gbyte (msga,ivals,inofst,24)
    +
    414C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    415 inofst = inofst + 32
    +
    416 iptr( 2) = ivals(1)
    +
    417 END IF
    +
    418C ======================
    +
    419C ORIGINATING CENTER
    +
    420 CALL gbyte (msga,ivals,inofst,16)
    +
    421 inofst = inofst + 16
    +
    422 ident(2) = ivals(1)
    +
    423C UPDATE SEQUENCE
    +
    424 CALL gbyte (msga,ivals,inofst,8)
    +
    425 inofst = inofst + 8
    +
    426 ident(3) = ivals(1)
    +
    427C 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
    +
    433C PRINT *,' NO OPTIONAL SECTION 2'
    +
    434 sec2 = .false.
    +
    435 END IF
    +
    436 inofst = inofst + 8
    +
    437C MESSAGE TYPE
    +
    438 CALL gbyte (msga,ivals,inofst,8)
    +
    439 ident(5) = ivals(1)
    +
    440 inofst = inofst + 8
    +
    441C MESSAGE SUB-TYPE
    +
    442 CALL gbyte (msga,ivals,inofst,8)
    +
    443 ident(6) = ivals(1)
    +
    444 inofst = inofst + 8
    +
    445C IF BUFR EDITION 0 OR 1 THEN
    +
    446C NEXT 2 BYTES ARE BUFR TABLE VERSION
    +
    447C ELSE
    +
    448C BYTE 11 IS VER NR OF MASTER TABLE
    +
    449C 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
    +
    455C BYTE 11 IS VER NR OF MASTER TABLE
    +
    456 CALL gbyte (msga,ivals,inofst,8)
    +
    457 ident(18) = ivals(1)
    +
    458 inofst = inofst + 8
    +
    459C 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
    +
    465C YEAR OF CENTURY
    +
    466 CALL gbyte (msga,ivals,inofst,8)
    +
    467 ident(8) = ivals(1)
    +
    468 inofst = inofst + 8
    +
    469C MONTH
    +
    470 CALL gbyte (msga,ivals,inofst,8)
    +
    471 ident(9) = ivals(1)
    +
    472 inofst = inofst + 8
    +
    473C DAY
    +
    474C PRINT *,'DAY AT ',INOFST
    +
    475 CALL gbyte (msga,ivals,inofst,8)
    +
    476 ident(10) = ivals(1)
    +
    477 inofst = inofst + 8
    +
    478C HOUR
    +
    479 CALL gbyte (msga,ivals,inofst,8)
    +
    480 ident(11) = ivals(1)
    +
    481 inofst = inofst + 8
    +
    482C MINUTE
    +
    483 CALL gbyte (msga,ivals,inofst,8)
    +
    484 ident(12) = ivals(1)
    +
    485C RESET POINTER (INOFST) TO START OF
    +
    486C NEXT SECTION
    +
    487C (SECTION 2 OR SECTION 3)
    +
    488 inofst = iptr(3) + iptr(2) * 8
    +
    489 iptr(4) = 0
    +
    490 iptr(5) = inofst
    +
    491 IF (sec2) THEN
    +
    492C SECTION 2 COUNT
    +
    493 CALL gbyte (msga,iptr(4),inofst,24)
    +
    494 inofst = inofst + 32
    +
    495C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
    +
    496 kentry = (iptr(4) - 4) / 14
    +
    497C 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
    +
    512C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
    +
    513 2000 CONTINUE
    +
    514 END IF
    +
    515C RESET POINTER (INOFST) TO START OF
    +
    516C SECTION 3
    +
    517 inofst = iptr(5) + iptr(4) * 8
    +
    518 END IF
    +
    519C BIT OFFSET TO START OF SECTION 3
    +
    520 iptr( 7) = inofst
    +
    521C SECTION 3 COUNT
    +
    522 CALL gbyte (msga,iptr(6),inofst,24)
    +
    523C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
    +
    524 inofst = inofst + 24
    +
    525C SKIP RESERVED BYTE
    +
    526 inofst = inofst + 8
    +
    527C NUMBER OF DATA SUBSETS
    +
    528 CALL gbyte (msga,ident(14),inofst,16)
    +
    529C
    +
    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'
    +
    535C
    +
    536 iptr(1) = 400
    +
    537 RETURN
    +
    538 END IF
    +
    539 inofst = inofst + 16
    +
    540C OBSERVED DATA FLAG
    +
    541 CALL gbyte (msga,ivals,inofst,1)
    +
    542 ident(15) = ivals(1)
    +
    543 inofst = inofst + 1
    +
    544C COMPRESSED DATA FLAG
    +
    545 CALL gbyte (msga,ivals,inofst,1)
    +
    546 ident(16) = ivals(1)
    +
    547 inofst = inofst + 7
    +
    548C CALCULATE NUMBER OF DESCRIPTORS
    +
    549 nrdesc = (iptr( 6) - 8) / 2
    +
    550 iptr(12) = nrdesc
    +
    551 iptr(13) = nrdesc
    +
    552C EXTRACT DESCRIPTORS
    +
    553 CALL gbytes (msga,istack,inofst,16,0,nrdesc)
    +
    554C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
    +
    555 DO 10 l = 1, nrdesc
    +
    556 iwork(l) = istack(l)
    +
    557C PRINT *,L,ISTACK(L)
    +
    558 10 CONTINUE
    +
    559 iptr(13) = nrdesc
    +
    560C RESET POINTER TO START OF SECTION 4
    +
    561 inofst = iptr(7) + iptr(6) * 8
    +
    562C BIT OFFSET TO START OF SECTION 4
    +
    563 iptr( 9) = inofst
    +
    564C SECTION 4 COUNT
    +
    565 CALL gbyte (msga,ivals,inofst,24)
    +
    566C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    567 iptr( 8) = ivals(1)
    +
    568 inofst = inofst + 32
    +
    569C SET FOR STARTING BIT OF DATA
    +
    570 iptr(25) = inofst
    +
    571C FIND OUT IF '7777' TERMINATOR IS THERE
    +
    572 inofst = iptr(9) + iptr(8) * 8
    +
    573 CALL gbyte (msga,ivals,inofst,32)
    +
    574C 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
    +
    582C
    +
    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)
    +
    586C
    +
    587C PRINT *,'HAVE RETURNED FROM FI7801'
    +
    588C IF (IPTR(1).NE.0) THEN
    +
    589C RETURN
    +
    590C END IF
    +
    591C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
    +
    592 IF (ident(5).EQ.2) THEN
    +
    593 IF (ident(6).EQ.7) THEN
    +
    594C PRINT *,'BASIC PROFILER DATA'
    +
    595C DO 153 I = 1, KNR(INDEX)
    +
    596C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    597C 153 CONTINUE
    +
    598C PRINT *,'REFORMAT PROFILER DATA'
    +
    599C
    +
    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
    +
    605C DO 151 I = 1, 40
    +
    606C IF (I.LE.20) THEN
    +
    607C PRINT *,'IPTR(',I,')=',IPTR(I),
    +
    608C * ' IDENT(',I,')= ',IDENT(I)
    +
    609C ELSE
    +
    610C PRINT *,'IPTR(',I,')=',IPTR(I)
    +
    611C END IF
    +
    612C 151 CONTINUE
    +
    613 IF (iptr(1).NE.0) THEN
    +
    614 RETURN
    +
    615 END IF
    +
    616C
    +
    617C DO 154 I = 1, IPTR(31)
    +
    618C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    619C 154 CONTINUE
    +
    620 END IF
    +
    621 END IF
    +
    622 RETURN
    +
    +
    623 END
    +
    624C
    +
    625C> @brief Data extraction
    +
    626C> @author Bill Cavanaugh @date 1988-09-01
    +
    627
    +
    628C> Control the extraction of data from section 4 based on data descriptors.
    +
    629C>
    +
    630C> Program history log:
    +
    631C> - Bill Cavanaugh 1988-09-01
    +
    632C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
    +
    633C> data.
    +
    634C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
    +
    635C> delayed replication.
    +
    636C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
    +
    637C>
    +
    638C> @param[in] IPTR See w3fi78() routine docblock
    +
    639C> @param[in] IDENT See w3fi78() routine docblock
    +
    640C> @param[in] MSGA Array containing bufr message
    +
    641C> @param[inout] ISTACK Original array of descriptors extracted from
    +
    642C> source bufr message.
    +
    643C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
    +
    644C> factor
    +
    645C> @param[inout] KDESC Image of current descriptor
    +
    646C> @param[in] INDEX
    +
    647C> @param[in] MAXR maximum number of reports/subsets that may be
    +
    648C> contained in a bufr message
    +
    649C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    650C> may be processed; upper air data and some satellite data require a value
    +
    651C> for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    +
    652C> @param[in] IUNITB Unit number of data set holding table b
    +
    653C> @param[in] IUNITD Unit number of data set holding table d
    +
    654C> @param[out] IWORK Working descriptor list
    +
    655C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    656C> KDATA(Report number,parameter number)
    +
    657C> (report number limited to value of input argument maxr and parameter
    +
    658C> number limited to value of input argument maxd)
    +
    659C> arrays containing data from table b
    +
    660C> @param[out] ANAME Descriptor name
    +
    661C> @param[out] AUNITS Units for descriptor
    +
    662C> @param[out] MSCALE Scale for value of descriptor
    +
    663C> @param[out] MREF Reference value for descriptor
    +
    664C> @param[out] MWIDTH Bit width for value of descriptor
    +
    665C> @param IVALS
    +
    666C> @param KNR
    +
    667C>
    +
    668C> Error return:
    +
    669C> IPTR(1)
    +
    670C> - = 8 Error reading table b
    +
    671C> - = 9 Error reading table d
    +
    672C> - = 11 Error opening table b
    +
    673C>
    +
    674C> @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
    +
    680C
    +
    681 CHARACTER*40 ANAME(*)
    +
    682 CHARACTER*24 AUNITS(*)
    +
    683C
    +
    684C
    +
    685 INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
    +
    686C
    +
    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(*)
    +
    697C
    +
    698 INTEGER MSTACK(2,MAXD),KK
    +
    699C
    +
    700 INTEGER JDESC
    +
    701 INTEGER INDEX
    +
    702 INTEGER ITEST(30)
    +
    703C
    +
    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/
    +
    710C
    +
    711C PRINT *,' DECOLL FI7801'
    +
    712 IF (index.GT.1) THEN
    +
    713 GO TO 1000
    +
    714 END IF
    +
    715C --------- 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
    +
    723C INITIALIZE OUTPUT AREA
    +
    724C SET POINTER TO BEGINNING OF DATA
    +
    725C SET BIT
    +
    726 iptr(17) = 1
    +
    727 1000 CONTINUE
    +
    728C IPTR(12) = IPTR(13)
    +
    729 ll = 0
    +
    730 iptr(11) = 1
    +
    731 IF (iptr(10).EQ.0) THEN
    +
    732C RE-ENTRY POINT FOR MULTIPLE
    +
    733C 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
    +
    741C PRINT *,'FI7801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
    +
    742 iptr(24) = 0
    +
    743 iptr(31) = 0
    +
    744C POINTING AT NEXT AVAILABLE DESCRIPTOR
    +
    745 mm = 0
    +
    746 IF (iptr(21).EQ.0) THEN
    +
    747C PRINT *,' READING TABLE B'
    +
    748 DO 150 i = 1, 700
    +
    749 iptr(21) = i
    +
    750C
    +
    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
    +
    764C PRINT *,I
    +
    765C WRITE(6,21) MF,MX,MY,KDESC(I),
    +
    766C * (ANAME(I)(K:K),K=1,40),
    +
    767C * (AUNITS(I)(K:K),K=1,24),
    +
    768C * 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
    +
    775C
    +
    776C CLOSE(UNIT=IUNITB,STATUS='KEEP')
    +
    777C
    +
    778 iptr(21) = 1
    +
    779 END IF
    +
    780C DO WHILE MM <= MAXD
    +
    781 10 CONTINUE
    +
    782C PROCESS THRU THE FOLLOWING
    +
    783C 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
    +
    789C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
    +
    790 IF (iptr(11).GT.iptr(12)) THEN
    +
    791C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
    +
    792 IF (ident(16).NE.0) THEN
    +
    793C PRINT *,' PROCESSING COMPRESSED REPORTS'
    +
    794C REFORMAT DATA FROM DESCRIPTOR
    +
    795C FORM TO USER FORM
    +
    796 RETURN
    +
    797 ELSE
    +
    798C WRITE (6,1)
    +
    799C 1 FORMAT (1H1)
    +
    800C 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
    +
    809C RESET POINTERS
    +
    810 ll = 0
    +
    811 iptr(1) = 0
    +
    812 iptr(11) = 1
    +
    813 iptr(12) = iptr(13)
    +
    814C IS THIS LAST REPORT ?
    +
    815C PRINT *,'READY',IPTR(39),INDEX
    +
    816 IF (iptr(39).GT.0) THEN
    +
    817 IF (index.GT.0) THEN
    +
    818C 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
    +
    826C GET NEXT DESCRIPTOR
    +
    827 CALL fi7808 (iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    828C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
    +
    829C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
    +
    830C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
    +
    831C * ' FOR LOC',IPTR(17),IPTR(25)
    +
    832 IF (iptr(11).GT.1600) THEN
    +
    833 iptr(1) = 401
    +
    834 RETURN
    +
    835 END IF
    +
    836C
    +
    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
    +
    845C REPLICATION PROCESSING
    +
    846 IF (lf.EQ.1) THEN
    +
    847C ---------- 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
    +
    853C PRINT *,'FI7801-1',KPRM,MSTACK(1,KPRM),
    +
    854C * 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
    +
    862C
    +
    863C 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
    +
    872C PRINT *,'FI7801-2',KPRM,MSTACK(1,KPRM),
    +
    873C * 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
    +
    881C DESCRIPTOR SEQUENCE STRINGS
    +
    882 ELSE IF (lf.EQ.3) THEN
    +
    883C PRINT *,'F3 SEQUENCE DESCRIPTOR'
    +
    884 IF (iptr(22).EQ.0) THEN
    +
    885C READ IN TABLE D, BUT JUST ONCE
    +
    886 ierr = 0
    +
    887C 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
    +
    898C PRINT 16,(ITBLD(I,L),L=1,11)
    +
    899 GO TO 50
    +
    900 END IF
    +
    901 25 CONTINUE
    +
    902C 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
    +
    914C
    +
    915C STANDARD DESCRIPTOR PROCESSING
    +
    916 ELSE
    +
    917C 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)
    +
    921C 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
    +
    936C END IF
    +
    937C END DO WHILE
    +
    938 200 CONTINUE
    +
    939 IF (ident(16).NE.0) THEN
    +
    940C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
    +
    941 ELSE
    +
    942C 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
    +
    954C> @brief Process standard descriptor
    +
    955C> @author Bill Cavanaugh @date 1988-09-01
    +
    956
    +
    957C> Process a standard descriptor (f = 0) and store data
    +
    958C> in output array.
    +
    959C>
    +
    960C> Program history log:
    +
    961C> - Bill Cavanaugh 1988-09-01
    +
    962C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes
    +
    963C>
    +
    964C> @param[in] IPTR See w3fi78 routine docblock
    +
    965C> @param[in] IDENT See w3fi78 routine docblock
    +
    966C> @param[in] MSGA Array containing bufr message
    +
    967C> @param[inout] KDATA Array containing decoded reports from bufr message.
    +
    968C> KDATA(Report number,parameter number)
    +
    969C> (report number limited to value of input argument maxr and parameter
    +
    970C> number limited to value of input argument maxd)
    +
    971C> @param[inout] KDESC Image of current descriptor
    +
    972C> @param[in] MSTACK
    +
    973C> @param[in] MAXR maximum number of reports/subsets that may be contained in
    +
    974C> a bufr message
    +
    975C> @param[in] MAXD Maximum number of descriptor combinations that may be
    +
    976C> processed; upper air data and some satellite data require a value for maxd
    +
    977C> of 1600, but for most other data a value for maxd of 500 will suffice
    +
    978C> Arrays containing data from table B
    +
    979C> @param[out] AUNITS Units for descriptor
    +
    980C> @param[out] MSCALE Scale for value of descriptor
    +
    981C> @param[out] MREF Reference value for descriptor
    +
    982C> @param[out] MWIDTH Bit width for value of descriptor
    +
    983C> @param LL
    +
    984C> @param JDESC
    +
    985C> @param IVALS
    +
    986C> @param J
    +
    987C>
    +
    988C> Error return:
    +
    989C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
    +
    990C> in table b.
    +
    991C>
    +
    992C> @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
    +
    996C TABLE B ENTRY
    +
    997 CHARACTER*24 ASKEY
    +
    998 CHARACTER*24 AUNITS(*)
    +
    999C 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(*)
    +
    1008C TABLE B ENTRY
    +
    1009C
    +
    1010 DATA askey /'CCITT IA5 '/
    +
    1011C
    +
    1012C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR'
    +
    1013C GET A MATCH BETWEEN CURRENT
    +
    1014C DESCRIPTOR (JDESC) AND
    +
    1015C TABLE B ENTRY
    +
    1016C IF (KDESC(356).EQ.0) THEN
    +
    1017C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0'
    +
    1018C IPTR(1) = 600
    +
    1019C RETURN
    +
    1020C 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
    +
    1029C HAVE SKIP FLAG
    +
    1030 IF (ident(16).NE.0) THEN
    +
    1031C SKIP OVER COMPRESSED DATA
    +
    1032C LOWEST
    +
    1033 iptr(25) = iptr(25) + iptr(36)
    +
    1034C 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
    +
    1044C 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
    +
    1055C SKIP OVER NON-COMPRESSED DATA
    +
    1056C 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'
    +
    1065C DO 20 LL = 1, IPTR(14)
    +
    1066C PRINT *,LL,KDESC(LL)
    +
    1067C 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
    +
    1090C HAVE A MATCH
    +
    1091C 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
    +
    1099C 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
    +
    1106C 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
    +
    1112C> @brief Process compressed data
    +
    1113C> @author Bill Cavanaugh @date 1988-09-01
    +
    1114
    +
    1115C> Process compressed data and place individual elements
    +
    1116C> into output array.
    +
    1117C>
    +
    1118C> PROGRAM HISTORY LOG:
    +
    1119C> - Bill Cavanaugh 1988-09-01
    +
    1120C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1121C> modified to hanle width of fields in bytes.
    +
    1122C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1123C> and uncompressed form gave different results. This has been corrected.
    +
    1124C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
    +
    1125C> provide exact reproduction of all characters.
    +
    1126C>
    +
    1127C> @param[in] IPTR See w3fi78() routine docblock
    +
    1128C> @param[in] IDENT See w3fi78() routine docblock
    +
    1129C> @param[in] MSGA Array containing bufr message,mstack,
    +
    1130C> @param[in] IVALS Array of single parameter values
    +
    1131C> @param[inout] J
    +
    1132C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
    +
    1133C> a bufr message.
    +
    1134C> @param[in] MAXD Maximum number of descriptor combinations that may be
    +
    1135C> processed; Upper air data and some satellite data require a value for maxd
    +
    1136C> of 1600, but for most other data a value for maxd of 500 will suffice.
    +
    1137C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1138C> KDATA(Report number,parameter number)
    +
    1139C> (report number limited to value of input argument maxr and parameter number
    +
    1140C> limited to value of input argument maxd)
    +
    1141C> Arrays containing data from table B.
    +
    1142C> @param[out] MSCALE Scale for value of descriptor
    +
    1143C> @param[out] MREF Reference value for descriptor
    +
    1144C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1145C> @param MSTACK
    +
    1146C> @param JDESC
    +
    1147C>
    +
    1148C> @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
    +
    1153C
    +
    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)
    +
    1163C
    +
    1164 LOGICAL TEXT
    +
    1165C
    +
    1166 INTEGER MSK(28)
    +
    1167C
    +
    1168C
    +
    1169 DATA msk /1,3,7,15,31,63,127,
    +
    1170C 1 2 3 4 5 6 7
    +
    1171 * 255,511,1023,2047,4095,
    +
    1172C 8 9 10 11 12
    +
    1173 * 8191,16383,32767,65535,
    +
    1174C 13 14 15 16
    +
    1175 * 131071,262143,524287,
    +
    1176C 17 18 19
    +
    1177 * 1048575,2097151,4194303,
    +
    1178C 20 21 22
    +
    1179 * 8388607,16777215,33554431,
    +
    1180C 23 24 25
    +
    1181 * 67108863,134217727,268435455/
    +
    1182C 26 27 28
    +
    1183C
    +
    1184C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
    +
    1185C * ' 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
    +
    1191C PRINT *,'DESCRIPTOR',KPRM
    +
    1192 IF (.NOT.text) THEN
    +
    1193 IF (iptr(29).GT.0) THEN
    +
    1194C WORKING WITH ASSOCIATED FIELDS HERE
    +
    1195 iptr(31) = iptr(31) + 1
    +
    1196 kprm = iptr(31) + iptr(24)
    +
    1197C GET LOWEST
    +
    1198 CALL gbyte (msga,lowest,iptr(25),iptr(29))
    +
    1199 iptr(25) = iptr(25) + iptr(29)
    +
    1200C GET NBINC
    +
    1201 CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1202 iptr(25) = iptr(25) + 6
    +
    1203C 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
    +
    1223C SET PARAMETER
    +
    1224C ISOLATE STANDARD BIT WIDTH
    +
    1225 jwide = mwidth(j) + iptr(26)
    +
    1226C SINGLE VALUE FOR LOWEST
    +
    1227 nrvals = 1
    +
    1228C LOWEST
    +
    1229C PRINT *,'PARAM',KPRM
    +
    1230 CALL gbyte (msga,lowest,iptr(25),jwide)
    +
    1231C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
    +
    1232 iptr(25) = iptr(25) + jwide
    +
    1233C ISOLATE COMPRESSED BIT WIDTH
    +
    1234 CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1235C 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
    +
    1239C PRINT *,'FOR DESCRIPTOR',JDESC
    +
    1240C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
    +
    1241C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
    +
    1242C DO 110 I = 1, KPRM
    +
    1243C WRITE (6,111)I,(KDATA(J,I),J=1,6)
    +
    1244C 110 CONTINUE
    +
    1245 111 FORMAT (1x,5hdata ,i3,6(2x,i10))
    +
    1246 iptr(1) = 500
    +
    1247C 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
    +
    1253C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
    +
    1254C IF TEXT EVENT, PROCESS TEXT
    +
    1255C GET COMPRESSED VALUES
    +
    1256C 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
    +
    1263C RECALCULATE TO ORIGINAL VALUES
    +
    1264 DO 100 i = 1, nrvals
    +
    1265C 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
    +
    1276C 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
    +
    1293C 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
    +
    1300C WRITE (6,80) (DATA(I,KPRM),I=1,10)
    +
    1301C 80 FORMAT(2X,10(F10.2,1X))
    +
    1302 ELSE IF (text) THEN
    +
    1303C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
    +
    1304C GET LOWEST
    +
    1305C 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
    +
    1315C GET NBINC
    +
    1316 CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1317C 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
    +
    1324C 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
    +
    1334C 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
    +
    1339C CONVERTS ASCII TO EBCIDIC
    +
    1340C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1341C PRINT *,IDATA
    +
    1342C CALL W3AI39 (IDATA,4)
    +
    1343 mstack(1,kprm) = jdesc
    +
    1344 mstack(2,kprm) = 0
    +
    1345 kdata(n,kprm) = idata
    +
    1346C SET FOR NEXT PART
    +
    1347 kprm = kprm + 1
    +
    1348 iptr(24) = iptr(24) + 1
    +
    1349C 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
    +
    1361C CONVERTS ASCII TO EBCIDIC
    +
    1362C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1363C CALL W3AI39 (IDATA,4)
    +
    1364 mstack(1,kprm) = jdesc
    +
    1365 mstack(2,kprm) = 0
    +
    1366 kdata(n,kprm) = idata
    +
    1367C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
    +
    1368 nbits = 0
    +
    1369 END IF
    +
    1370C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
    +
    1371C1800 FORMAT (2X,I4,2X,3A4)
    +
    1372 1900 CONTINUE
    +
    1373 END IF
    +
    1374 RETURN
    +
    +
    1375 END
    +
    1376
    +
    1377C> @brief Process serial data.
    +
    1378C> @author Bill Cavanaugh @date 1988-09-01
    +
    1379
    +
    1380C> Process data that is not compressed.
    +
    1381C>
    +
    1382C> Program history log:
    +
    1383C> - Bill Cavanaugh 1988-09-01
    +
    1384C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
    +
    1385C> data.
    +
    1386C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1387C> modified to handle field width in bytes.
    +
    1388C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1389C> and uncompressed form gave different results.
    +
    1390C> this has been corrected.
    +
    1391C>
    +
    1392C> @param[in] IPTR See w3fi78 routine docblock
    +
    1393C> @param[in] MSGA Array containing bufr message
    +
    1394C> @param[inout] IVALS Array of single parameter values
    +
    1395C> @param[inout] J
    +
    1396C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1397C> contained in a bufr message
    +
    1398C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1399C> may be processed; upper air data and some satellite
    +
    1400C> data require a value for maxd of 1600, but for most
    +
    1401C> other data a value for maxd of 500 will suffice
    +
    1402C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1403C> KDATA(report number,parameter number)
    +
    1404C> (report number limited to value of input argument maxr and parameter number
    +
    1405C> limited to value of input argument maxd)
    +
    1406C> arrays containing data from table B
    +
    1407C> @param[out] MSCALE Scale for value of descriptor
    +
    1408C> @param[out] MREF Reference value for descriptor
    +
    1409C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1410C> @param MSTACK
    +
    1411C> @param LL
    +
    1412C> @param JDESC
    +
    1413C>
    +
    1414C> Error return:
    +
    1415C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
    +
    1416C>
    +
    1417C> @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
    +
    1421C
    +
    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
    +
    1430C
    +
    1431C
    +
    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/
    +
    1439C
    +
    1440C 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
    +
    1445C -------- NOCMP --------
    +
    1446C ISOLATE BIT WIDTH
    +
    1447 jwide = mwidth(j) + iptr(26)
    +
    1448C IF NOT TEXT EVENT, PROCESS
    +
    1449 IF (iptr(18).NE.1) THEN
    +
    1450C 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)
    +
    1460C PRINT *,'FI7804-A',KPRM,MSTACK(1,KPRM),
    +
    1461C * 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
    +
    1472C GET VALUES
    +
    1473C CALL TO GET DATA OF GIVEN BIT WIDTH
    +
    1474 CALL gbyte (msga,ivals,iptr(25),jwide)
    +
    1475C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
    +
    1476 iptr(25) = iptr(25) + jwide
    +
    1477C 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
    +
    1487C PRINT *,'FI7804-B',KPRM,MSTACK(1,KPRM),
    +
    1488C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1489C IF(JDESC.EQ.2049) THEN
    +
    1490C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
    +
    1491C END IF
    +
    1492C PRINT *,'FI7804 ',KPRM,MSTACK(1,KPRM),
    +
    1493C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1494 ELSE
    +
    1495C IF TEXT EVENT, PROCESS TEXT
    +
    1496C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
    +
    1497 nrchrs = iptr(40)
    +
    1498 nrbits = nrchrs * 8
    +
    1499C 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)
    +
    1506C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
    +
    1507C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
    +
    1508C CONVERTS ASCII TO EBCIDIC
    +
    1509C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1510C 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
    +
    1515C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1516C * 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
    +
    1522C PRINT *,'LAST TEXT WORD'
    +
    1523 CALL gbyte (msga,idata,iptr(25),nrbits)
    +
    1524 iptr(25) = iptr(25) + nrbits
    +
    1525C CONVERTS ASCII TO EBCIDIC
    +
    1526C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1527C 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
    +
    1534C PRINT 1723,IDATA
    +
    1535 1723 FORMAT (12x,z8)
    +
    1536 1722 CONTINUE
    +
    1537 END IF
    +
    1538 kdata(iptr(17),kprm) = idata
    +
    1539C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
    +
    1540 mstack(1,kprm) = jdesc
    +
    1541 mstack(2,kprm) = 0
    +
    1542C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1543C * KDATA(IPTR(17),KPRM)
    +
    1544 END IF
    +
    1545C TURN OFF TEXT
    +
    1546 iptr(18) = 0
    +
    1547 END IF
    +
    1548 RETURN
    +
    +
    1549 END
    +
    1550C> @brief Process a replication descriptor.
    +
    1551C> @author Bill Cavanaugh @date 1988-09-01
    +
    1552
    +
    1553C> Process a replication descriptor, must extract number
    +
    1554C> of replications of n descriptors from the data stream.
    +
    1555C>
    +
    1556C> Program history log:
    +
    1557C> - Bill Cavanaugh 1988-09-01
    +
    1558C>
    +
    1559C> @param[in] IWORK Working descriptor list
    +
    1560C> @param[in] IPTR See w3fi78 routine docblock
    +
    1561C> @param[in] IDENT See w3fi78 routine docblock
    +
    1562C> @param[inout] LX X portion of current descriptor
    +
    1563C> @param[inout] LY Y portion of current descriptor
    +
    1564C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1565C> contained in a bufr message.
    +
    1566C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1567C> may be processed; upper air data and some satellite
    +
    1568C> data require a value for maxd of 1600, but for most
    +
    1569C> other data a value for maxd of 500 will suffice
    +
    1570C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1571C> KDATA(report number,parameter number)
    +
    1572C> (report number limited to value of input argument
    +
    1573C> maxr and parameter number limited to value of input
    +
    1574C> argument maxd)
    +
    1575C> @param MSGA
    +
    1576C> @param LL
    +
    1577C> @param KNR
    +
    1578C> @param MSTACK
    +
    1579C>
    +
    1580C> Error return:
    +
    1581C> IPTR(1):
    +
    1582C> - = 12 Data descriptor qualifier does not follow delayed replication
    +
    1583C> descriptor
    +
    1584C> - = 20 Exceeded count for delayed replication pass
    +
    1585C>
    +
    1586C> @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
    +
    1591C
    +
    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(*)
    +
    1604C
    +
    1605C PRINT *,' REPLICATION FI7805'
    +
    1606C DO 100 I = 1, IPTR(13)
    +
    1607C PRINT *,I,IWORK(I)
    +
    1608C 100 CONTINUE
    +
    1609C NUMBER OF DESCRIPTORS
    +
    1610 nrset = lx
    +
    1611C NUMBER OF REPLICATIONS
    +
    1612 nrreps = ly
    +
    1613 icurr = iptr(11) - 1
    +
    1614 ipick = iptr(11) - 1
    +
    1615C
    +
    1616 IF (nrreps.EQ.0) THEN
    +
    1617 iptr(39) = 1
    +
    1618C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
    +
    1619C IPTR(31) = IPTR(31) + 1
    +
    1620C KPRM = IPTR(31) + IPTR(24)
    +
    1621C MSTACK(1,KPRM) = JDESC
    +
    1622C MSTACK(2,KPRM) = 0
    +
    1623C KDATA(IPTR(17),KPRM) = 0
    +
    1624C PRINT *,'FI7805-1',KPRM,MSTACK(1,KPRM),
    +
    1625C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1626C DELAYED REPLICATION - MUST GET NUMBER OF
    +
    1627C REPLICATIONS FROM DATA.
    +
    1628C GET NEXT DESCRIPTOR
    +
    1629 CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    1630C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
    +
    1631C MUST BE DATA DESCRIPTION
    +
    1632C 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
    +
    1642C SET SINGLE VALUE FOR SEQUENTIAL,
    +
    1643C MULTIPLE VALUES FOR COMPRESSED
    +
    1644 IF (ident(16).EQ.0) THEN
    +
    1645C NON COMPRESSED
    +
    1646 CALL gbyte (msga,kvals,iptr(25),jwide)
    +
    1647C 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)
    +
    1655C PRINT *,'FI7805-2',KPRM,MSTACK(1,KPRM),
    +
    1656C * 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
    +
    1672C PRINT *,'NOT DELAYED REPLICATION'
    +
    1673 END IF
    +
    1674C RESTRUCTURE WORKING STACK W/REPLICATIONS
    +
    1675C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
    +
    1676C 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
    +
    1680C PRINT *,'REPLICATION ',I,ITEMP(I)
    +
    1681 1000 CONTINUE
    +
    1682C MOVE TRAILING DESCRIPTORS TO HOLD AREA
    +
    1683 lax = iptr(12) - iptr(11) + 1
    +
    1684C 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
    +
    1688C PRINT *,' ',I,KTEMP(I)
    +
    1689 2000 CONTINUE
    +
    1690C REPLICATIONS INTO ISTACK
    +
    1691C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
    +
    1692C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
    +
    1693 DO 4000 i = 1, nrreps
    +
    1694 DO 3000 j = 1, nrset
    +
    1695 iwork(icurr) = itemp(j)
    +
    1696C PRINT *,'FI7805 A',ICURR,IWORK(ICURR)
    +
    1697 icurr = icurr + 1
    +
    1698 3000 CONTINUE
    +
    1699 4000 CONTINUE
    +
    1700C PRINT *,' TO LOC',ICURR-1
    +
    1701C RESTORE TRAILING DESCRIPTORS
    +
    1702C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
    +
    1703 DO 5000 i = 1, lax
    +
    1704 iwork(icurr) = ktemp(i)
    +
    1705C 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
    +
    1712C> @brief Process operator descriptors
    +
    1713C> @author Bill Cavanaugh @date 1988-09-01
    +
    1714
    +
    1715C> Extract and save indicated change values for use
    +
    1716C> until changes are rescinded, or extract text strings indicated
    +
    1717C> through 2 05 yyy.
    +
    1718C>
    +
    1719C> Program history log:
    +
    1720C> - Bill Cavanaugh 1988-09-01
    +
    1721C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
    +
    1722C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
    +
    1723C> table c descriptor 2 06 yyy.
    +
    1724C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
    +
    1725C> table c descriptor 2 03 yyy, the change
    +
    1726C> to new reference value for selected
    +
    1727C> descriptors.
    +
    1728C>
    +
    1729C> @param[in] IPTR See w3fi78 routine docblock
    +
    1730C> @param[in] LX X portion of current descriptor
    +
    1731C> @param[in] LY Y portion of current descriptor
    +
    1732C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1733C> contained in a bufr message
    +
    1734C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1735C> may be processed; upper air data and some satellite
    +
    1736C> data require a value for maxd of 1600, but for most
    +
    1737C> other data a value for maxd of 500 will suffice
    +
    1738C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1739C> KDATA(Report number,parameter number)
    +
    1740C> (report number limited to value of input argument maxr and parameter number
    +
    1741C> limited to value of input argument maxd)
    +
    1742C> Arrays containing data from table b
    +
    1743C> @param[out] MSCALE Scale for value of descriptor
    +
    1744C> @param[out] MREF Reference value for descriptor
    +
    1745C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1746C> @param IDENT
    +
    1747C> @param MSGA
    +
    1748C> @param IVALS
    +
    1749C> @param MSTACK
    +
    1750C> @param J
    +
    1751C> @param LL
    +
    1752C> @param KDESC
    +
    1753C> @param JDESC
    +
    1754C> @param IWORK
    +
    1755C>
    +
    1756C> Error return:
    +
    1757C> IPTR(1) = 5 - Erroneous X value in data descriptor operator
    +
    1758C>
    +
    1759C> @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
    +
    1773C
    +
    1774C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
    +
    1775 IF (lx.EQ.1) THEN
    +
    1776C CHANGE BIT WIDTH
    +
    1777 IF (ly.EQ.0) THEN
    +
    1778C PRINT *,' RETURN TO NORMAL WIDTH'
    +
    1779 iptr(26) = 0
    +
    1780 ELSE
    +
    1781C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
    +
    1782 iptr(26) = ly - 128
    +
    1783 END IF
    +
    1784 ELSE IF (lx.EQ.2) THEN
    +
    1785C CHANGE SCALE
    +
    1786 IF (ly.EQ.0) THEN
    +
    1787C RESET TO STANDARD SCALE
    +
    1788 iptr(27) = 0
    +
    1789 ELSE
    +
    1790C SET NEW SCALE
    +
    1791 iptr(27) = ly - 128
    +
    1792 END IF
    +
    1793 ELSE IF (lx.EQ.3) THEN
    +
    1794C CHANGE REFERENCE VALUE
    +
    1795C FOR EACH OF THOSE DESCRIPTORS BETWEEN
    +
    1796C 2 03 YYY WHERE Y LT 255 AND
    +
    1797C 2 03 255, EXTRACT THE NEW REFERENCE
    +
    1798C VALUE (BIT WIDTH YYY) AND PLACE
    +
    1799C IN TERTIARY TABLE B REF VAL POSITION,
    +
    1800C SET FLAG IN SECONDARY REFVAL POSITION
    +
    1801C THOSE DESCRIPTORS DO NOT HAVE DATA
    +
    1802C ASSOCIATED WITH THEM, BUT ONLY
    +
    1803C IDENTIFY THE TABLE B ENTRIES THAT
    +
    1804C ARE GETTING NEW REFERENCE VALUES.
    +
    1805 kyyy = ly
    +
    1806 IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
    +
    1807C START CYCLING THRU DESCRIPTORS UNTIL
    +
    1808C 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
    +
    1812C IF 2 03 255 THEN RETURN
    +
    1813 RETURN
    +
    1814 ELSE
    +
    1815C FIND MATCHING TABLE B ENTRY
    +
    1816 DO 500 lj = 1, iptr(14)
    +
    1817 IF (jdesc.EQ.kdesc(lj)) THEN
    +
    1818C TURN ON NEW REF VAL FLAG
    +
    1819 mref(lj,2) = 1
    +
    1820C INSERT NEW REF VAL
    +
    1821 CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
    +
    1822C GO GET NEXT DESCRIPTOR
    +
    1823 GO TO 300
    +
    1824 END IF
    +
    1825 500 CONTINUE
    +
    1826C 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
    +
    1831C MUST TURN OFF ALL NEW
    +
    1832C REFERENCE VALUES
    +
    1833 DO 400 i = 1, iptr(14)
    +
    1834 mref(i,2) = 0
    +
    1835 400 CONTINUE
    +
    1836 END IF
    +
    1837C LX = 3
    +
    1838C MUST BE CONCLUDED WITH Y=255
    +
    1839 ELSE IF (lx.EQ.4) THEN
    +
    1840C ASSOCIATED VALUES
    +
    1841 IF (ly.EQ.0) THEN
    +
    1842 iptr(29) = 0
    +
    1843C 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
    +
    1850C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
    +
    1851 END IF
    +
    1852 ELSE IF (lx.EQ.5) THEN
    +
    1853C PROCESS TEXT DATA
    +
    1854 iptr(40) = ly
    +
    1855 iptr(18) = 1
    +
    1856 IF (ident(16).EQ.0) THEN
    +
    1857C 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
    +
    1861C 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
    +
    1870C SKIP NEXT DESCRIPTOR
    +
    1871C SET TO PASS OVER DESCRIPTOR AND DATA
    +
    1872C IF DESCRIPTOR NOT IN TABLE B
    +
    1873 iptr(36) = ly
    +
    1874C 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
    +
    1884C> @brief Process queue descriptor.
    +
    1885C> @author Bill Cavanaugh @date 1988-09-01
    +
    1886
    +
    1887C> Substitute descriptor queue for queue descriptor.
    +
    1888C>
    +
    1889C> Program history log:
    +
    1890C> - Bill Cavanaugh 1988-09-01
    +
    1891C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
    +
    1892C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
    +
    1893C> based on tests with live data.
    +
    1894C>
    +
    1895C> @param[in] IWORK Working descriptor list
    +
    1896C> @param[in] IPTR See w3fi78 routine docblock
    +
    1897C> @param MAXD
    +
    1898C> @param[in] ITBLD Array containing descriptor queues
    +
    1899C> @param[in] JDESC Queue descriptor to be expanded
    +
    1900C>
    +
    1901C$$$
    +
    +
    1902 SUBROUTINE fi7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
    +
    1903
    +
    1904 SAVE
    +
    1905C
    +
    1906 INTEGER IPTR(*),JDESC
    +
    1907 INTEGER IWORK(*),IHOLD(2000)
    +
    1908 INTEGER ITBLD(500,11)
    +
    1909C
    +
    1910C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12)
    +
    1911C SET FOR BINARY SEARCH IN TABLE D
    +
    1912C DO 2020 I = 1, IPTR(12)
    +
    1913C PRINT *,'ENTRY IWORK',I,IWORK(I)
    +
    1914C2020 CONTINUE
    +
    1915 jlo = 1
    +
    1916 jhi = iptr(20)
    +
    1917C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
    +
    1918 10 CONTINUE
    +
    1919 jmid = (jlo + jhi) / 2
    +
    1920C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
    +
    1921C
    +
    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
    +
    1950C HAVE TABLE D MATCH
    +
    1951C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
    +
    1952C 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)
    +
    1959C 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
    +
    1967C NOTHING MORE TO APPEND
    +
    1968C PRINT *,'NOTHING MORE TO APPEND'
    +
    1969 ELSE
    +
    1970C APPEND TRAILING IWORK TO IHOLD
    +
    1971C 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
    +
    1977C RESET IHOLD TO IWORK
    +
    1978C 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
    +
    1985C PRINT *,' FI7807 F3 EXIT ',IPTR(11),IPTR(12)
    +
    1986C DO 2000 I = 1, IPTR(12)
    +
    1987C PRINT *,'EXIT IWORK',I,IWORK(I)
    +
    1988C2000 CONTINUE
    +
    1989C RESET POINTERS
    +
    1990 iptr(11) = iptr(11) - 1
    +
    1991 RETURN
    +
    +
    1992 END
    +
    1993C> @brief
    +
    1994C> @author Bill Cavanaugh @date 1988-09-01
    +
    1995
    +
    1996C> Program history log:
    +
    1997C> - Bill Cavanaugh 1988-09-01
    +
    1998C>
    +
    1999C> @param[inout] IPTR See w3fi78() routine docblock
    +
    2000C> @param[in] IWORK Working descriptor list
    +
    2001C> @param LF
    +
    2002C> @param LX
    +
    2003C> @param LY
    +
    2004C> @param JDESC
    +
    2005C> @param MAXD
    +
    2006C>
    +
    2007C> @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
    +
    2012C
    +
    2013C 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
    +
    2021C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
    +
    2022 iptr(11) = iptr(11) + 1
    +
    2023 RETURN
    +
    +
    2024 END
    +
    2025C> @brief Reformat profiler w hgt increments.
    +
    2026C> @author Bill Cavanaugh @date 1990-02-14
    +
    2027
    +
    2028C> Reformat decoded profiler data to show heights instead of
    +
    2029C> height increments.
    +
    2030C>
    +
    2031C> Program history log:
    +
    2032C> - Bill Cavanaugh 1990-02-14
    +
    2033C>
    +
    2034C> @param[in] IDENT Array contains message information extracted from BUFR
    +
    2035C> message:
    +
    2036C> - IDENT(1)- Edition number (byte 4, section 1)
    +
    2037C> - IDENT(2)- Originating center (bytes 5-6, section 1)
    +
    2038C> - IDENT(3)- Update sequence (byte 7, section 1)
    +
    2039C> - IDENT(4)- (byte 8, section 1)
    +
    2040C> - IDENT(5)- Bufr message type (byte 9, section 1)
    +
    2041C> - IDENT(6)- Bufr msg sub-type (byte 10, section 1)
    +
    2042C> - IDENT(7)- (bytes 11-12, section 1)
    +
    2043C> - IDENT(8)- Year of century (byte 13, section 1)
    +
    2044C> - IDENT(9)- Month of year (byte 14, section 1)
    +
    2045C> - IDENT(10)- Day of month (byte 15, section 1)
    +
    2046C> - IDENT(11)- Hour of day (byte 16, section 1)
    +
    2047C> - IDENT(12)- Minute of hour (byte 17, section 1)
    +
    2048C> - IDENT(13)- Rsvd by adp centers(byte 18, section 1)
    +
    2049C> - IDENT(14)- Nr of data subsets (byte 5-6, section 3)
    +
    2050C> - IDENT(15)- Observed flag (byte 7, bit 1, section 3)
    +
    2051C> - IDENT(16)- Compression flag (byte 7, bit 2, section 3)
    +
    2052C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2053C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2054C> KDATA(Report number,parameter number)
    +
    2055C> (report number limited to value of input argument maxr and parameter number
    +
    2056C> limited to value of input argument maxd)
    +
    2057C> @param[in] IPTR See w3fi78
    +
    2058C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2059C> contained in a bufr message
    +
    2060C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2061C> may be processed; upper air data and some satellite
    +
    2062C> data require a value for maxd of 1600, but for most
    +
    2063C> other data a value for maxd of 500 will suffice.
    +
    2064C>
    +
    2065C> @author Bill Cavanaugh @date 1990-02-14
    +
    +
    2066 SUBROUTINE fi7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
    +
    2067
    +
    2068 SAVE
    +
    2069C ----------------------------------------------------------------
    +
    2070C
    +
    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)
    +
    2077C
    +
    2078C ----------------------------------------------------------
    +
    2079C PRINT *,'FI7809'
    +
    2080C LOOP FOR NUMBER OF SUBSETS/REPORTS
    +
    2081 DO 3000 i = 1, ident(14)
    +
    2082C INIT FOR DATA INPUT ARRAY
    +
    2083 mk = 1
    +
    2084C INIT FOR DESC OUTPUT ARRAY
    +
    2085 jk = 0
    +
    2086C LOCATION
    +
    2087 isw = 0
    +
    2088 DO 200 j = 1, 3
    +
    2089C LATITUDE
    +
    2090 IF (mstack(1,mk).EQ.1282) THEN
    +
    2091 isw = isw + 1
    +
    2092 GO TO 100
    +
    2093C LONGITUDE
    +
    2094 ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2095 isw = isw + 2
    +
    2096 GO TO 100
    +
    2097C 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
    +
    2106C SAVE DESCRIPTOR
    +
    2107 kprofl(jk) = mstack(1,mk)
    +
    2108C SAVE SCALE
    +
    2109 kprof2(jk) = mstack(2,mk)
    +
    2110C 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
    +
    2119C TIME
    +
    2120 isw = 0
    +
    2121 DO 400 j = 1, 7
    +
    2122C YEAR
    +
    2123 IF (mstack(1,mk).EQ.1025) THEN
    +
    2124 isw = isw + 1
    +
    2125 GO TO 300
    +
    2126C MONTH
    +
    2127 ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2128 isw = isw + 2
    +
    2129 GO TO 300
    +
    2130C DAY
    +
    2131 ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2132 isw = isw + 4
    +
    2133 GO TO 300
    +
    2134C HOUR
    +
    2135 ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2136 isw = isw + 8
    +
    2137 GO TO 300
    +
    2138C MINUTE
    +
    2139 ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2140 isw = isw + 16
    +
    2141 GO TO 300
    +
    2142C 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
    +
    2153C SAVE DESCRIPTOR
    +
    2154 kprofl(jk) = mstack(1,mk)
    +
    2155C SAVE SCALE
    +
    2156 kprof2(jk) = mstack(2,mk)
    +
    2157C 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
    +
    2166C SURFACE DATA
    +
    2167 krg = 0
    +
    2168 isw = 0
    +
    2169 DO 600 j = 1, 10
    +
    2170C WIND SPEED
    +
    2171 IF (mstack(1,mk).EQ.2818) THEN
    +
    2172 isw = isw + 1
    +
    2173 GO TO 500
    +
    2174C WIND DIRECTION
    +
    2175 ELSE IF (mstack(1,mk).EQ.2817) THEN
    +
    2176 isw = isw + 2
    +
    2177 GO TO 500
    +
    2178C PRESS REDUCED TO MSL
    +
    2179 ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2180 isw = isw + 4
    +
    2181 GO TO 500
    +
    2182C TEMPERATURE
    +
    2183 ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2184 isw = isw + 8
    +
    2185 GO TO 500
    +
    2186C RAINFALL RATE
    +
    2187 ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2188 isw = isw + 16
    +
    2189 GO TO 500
    +
    2190C RELATIVE HUMIDITY
    +
    2191 ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2192 isw = isw + 32
    +
    2193 GO TO 500
    +
    2194C 1ST RANGE GATE OFFSET
    +
    2195 ELSE IF (mstack(1,mk).EQ.1982.OR.
    +
    2196 * mstack(1,mk).EQ.1983) THEN
    +
    2197C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
    +
    2198C 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
    +
    2208C PRINT *,'INITIAL INCR =',INCRHT
    +
    2209 ELSE
    +
    2210 lhgt = 500 + ihgt - kdata(i,mk)
    +
    2211 isw = isw + 64
    +
    2212C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
    +
    2213 END IF
    +
    2214 END IF
    +
    2215C MODE #1
    +
    2216 ELSE IF (mstack(1,mk).EQ.8128) THEN
    +
    2217 isw = isw + 128
    +
    2218 GO TO 500
    +
    2219C 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
    +
    2226C SAVE DESCRIPTOR
    +
    2227 jk = jk + 1
    +
    2228 kprofl(jk) = mstack(1,mk)
    +
    2229C SAVE SCALE
    +
    2230 kprof2(jk) = mstack(2,mk)
    +
    2231C SAVE DATA
    +
    2232 kset2(jk) = kdata(i,mk)
    +
    2233C IF (I.EQ.1) THEN
    +
    2234C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2235C 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
    +
    2244C 43 LEVELS
    +
    2245 DO 2000 l = 1, 43
    +
    2246 2020 CONTINUE
    +
    2247 isw = 0
    +
    2248C HEIGHT INCREMENT
    +
    2249 IF (mstack(1,mk).EQ.1982) THEN
    +
    2250C 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
    +
    2259C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
    +
    2260C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
    +
    2261 lhgt = lhgt + incrht
    +
    2262C PRINT *,'LEVEL ',L,LHGT
    +
    2263 IF (l.EQ.37) THEN
    +
    2264 lhgt = lhgt + incrht
    +
    2265 END IF
    +
    2266 jk = jk + 1
    +
    2267C SAVE DESCRIPTOR
    +
    2268 kprofl(jk) = 1798
    +
    2269C SAVE SCALE
    +
    2270 kprof2(jk) = 0
    +
    2271C SAVE DATA
    +
    2272 kset2(jk) = lhgt
    +
    2273C IF (I.EQ.10) THEN
    +
    2274C PRINT *,' '
    +
    2275C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
    +
    2276C 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
    +
    2282C 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
    +
    2292C 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
    +
    2301C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
    +
    2302C DESCRIPTORS AND DATA
    +
    2303 IF (iand(isw,1).NE.0) THEN
    +
    2304 IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2305C SAVE DD DESCRIPTOR
    +
    2306 jk = jk + 1
    +
    2307 kprofl(jk) = 2817
    +
    2308C SAVE SCALE
    +
    2309 kprof2(jk) = 0
    +
    2310C SAVE DD DATA
    +
    2311 kset2(jk) = 32767
    +
    2312C SAVE FFF DESCRIPTOR
    +
    2313 jk = jk + 1
    +
    2314 kprofl(jk) = 2818
    +
    2315C SAVE SCALE
    +
    2316 kprof2(jk) = 1
    +
    2317C SAVE FFF DATA
    +
    2318 kset2(jk) = 32767
    +
    2319 ELSE
    +
    2320C GENERATE DDFFF
    +
    2321 CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2322 ndir = dir
    +
    2323 spd = spd
    +
    2324 nspd = spd
    +
    2325C PRINT *,' ',NDIR,NSPD
    +
    2326C SAVE DD DESCRIPTOR
    +
    2327 jk = jk + 1
    +
    2328 kprofl(jk) = 2817
    +
    2329C SAVE SCALE
    +
    2330 kprof2(jk) = 0
    +
    2331C SAVE DD DATA
    +
    2332 kset2(jk) = dir
    +
    2333C IF (I.EQ.1) THEN
    +
    2334C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2335C END IF
    +
    2336C SAVE FFF DESCRIPTOR
    +
    2337 jk = jk + 1
    +
    2338 kprofl(jk) = 2818
    +
    2339C SAVE SCALE
    +
    2340 kprof2(jk) = 1
    +
    2341C SAVE FFF DATA
    +
    2342 kset2(jk) = spd
    +
    2343C IF (I.EQ.1) THEN
    +
    2344C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2345C END IF
    +
    2346 END IF
    +
    2347 END IF
    +
    2348 GO TO 800
    +
    2349C W VECTOR VALUE
    +
    2350 ELSE IF (mstack(1,mk).EQ.3010) THEN
    +
    2351 isw = isw + 4
    +
    2352 GO TO 700
    +
    2353C Q/C TEST RESULTS
    +
    2354 ELSE IF (mstack(1,mk).EQ.8130) THEN
    +
    2355 isw = isw + 8
    +
    2356 GO TO 700
    +
    2357C 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
    +
    2361C 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
    +
    2365C SPECTRAL PEAK POWER
    +
    2366 ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2367 isw = isw + 64
    +
    2368 GO TO 700
    +
    2369C U,V VARIABILITY
    +
    2370 ELSE IF (mstack(1,mk).EQ.3011) THEN
    +
    2371 isw = isw + 128
    +
    2372 GO TO 700
    +
    2373C 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
    +
    2384C SAVE DESCRIPTOR
    +
    2385 kprofl(jk) = mstack(1,mk)
    +
    2386C SAVE SCALE
    +
    2387 kprof2(jk) = mstack(2,mk)
    +
    2388C SAVE DATA
    +
    2389 kset2(jk) = kdata(i,mk)
    +
    2390 mk = mk + 1
    +
    2391C IF (I.EQ.1) THEN
    +
    2392C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2393C 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
    +
    2402C MOVE DATA BACK INTO KDATA ARRAY
    +
    2403 DO 4000 ll = 1, jk
    +
    2404 kdata(i,ll) = kset2(ll)
    +
    2405 4000 CONTINUE
    +
    2406 3000 CONTINUE
    +
    2407C PRINT *,'REBUILT ARRAY'
    +
    2408 DO 5000 ll = 1, jk
    +
    2409C DESCRIPTOR
    +
    2410 mstack(1,ll) = kprofl(ll)
    +
    2411C SCALE
    +
    2412 mstack(2,ll) = kprof2(ll)
    +
    2413C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
    +
    2414 5000 CONTINUE
    +
    2415C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
    +
    2416 iptr(31) = jk
    +
    2417 RETURN
    +
    +
    2418 END
    +
    2419C> @brief Reformat profiler edition 2 data.
    +
    2420C> @author Bill Cavanaugh @date 1993-01-21
    +
    2421
    +
    2422C> Reformat profiler data in edition 2.
    +
    2423C>
    +
    2424C> Program history log:
    +
    2425C> - Bill Cavanaugh 1993-01-27
    +
    2426C>
    +
    2427C> @param[in] IDENT Array contains message information extracted from
    +
    2428C> bufr message:
    +
    2429C> - IDENT(1) - Edition number (byte 4, section 1)
    +
    2430C> - IDENT(2) - Originating center (bytes 5-6, section 1)
    +
    2431C> - IDENT(3) - Update sequence (byte 7, section 1)
    +
    2432C> - IDENT(4) - (byte 8, section 1)
    +
    2433C> - IDENT(5) - Bufr message type (byte 9, section 1)
    +
    2434C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
    +
    2435C> - IDENT(7) - (bytes 11-12, section 1)
    +
    2436C> - IDENT(8) - Year of century (byte 13, section 1)
    +
    2437C> - IDENT(9) - Month of year (byte 14, section 1)
    +
    2438C> - IDENT(10) - Day of month (byte 15, section 1)
    +
    2439C> - IDENT(11) - Hour of day (byte 16, section 1)
    +
    2440C> - IDENT(12) - Minute of hour (byte 17, section 1)
    +
    2441C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
    +
    2442C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
    +
    2443C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
    +
    2444C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
    +
    2445C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2446C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2447c> kdata(report number,parameter number)
    +
    2448c> (report number limited to value of input argument maxr and parameter number
    +
    2449C> limited to value of input argument maxd)
    +
    2450C> @param[in] IPTR See w3fi78
    +
    2451C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2452C> contained in a bufr message
    +
    2453C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2454C> may be processed; upper air data and some satellite
    +
    2455C> data require a value for maxd of 1600, but for most
    +
    2456C> other data a value for maxd of 500 will suffice
    +
    2457C>
    +
    2458C> @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)
    +
    2467C LOOP FOR NUMBER OF SUBSETS
    +
    2468 DO 3000 i = 1, ident(14)
    +
    2469 mk = 1
    +
    2470 jk = 0
    +
    2471 isw = 0
    +
    2472C PRINT *,'IDENTIFICATION'
    +
    2473 DO 200 j = 1, 5
    +
    2474 IF (mstack(1,mk).EQ.257) THEN
    +
    2475C BLOCK NUMBER
    +
    2476 isw = isw + 1
    +
    2477 ELSE IF (mstack(1,mk).EQ.258) THEN
    +
    2478C STATION NUMBER
    +
    2479 isw = isw + 2
    +
    2480 ELSE IF (mstack(1,mk).EQ.1282) THEN
    +
    2481C LATITUDE
    +
    2482 isw = isw + 4
    +
    2483 ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2484C LONGITUDE
    +
    2485 isw = isw + 8
    +
    2486 ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2487C 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)
    +
    2498C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2499 mk = mk + 1
    +
    2500 200 CONTINUE
    +
    2501C PRINT *,'LOCATION ',ISW
    +
    2502 IF (isw.NE.31) THEN
    +
    2503 print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2504 iptr(10) = 200
    +
    2505 RETURN
    +
    2506 END IF
    +
    2507C PROCESS TIME ELEMENTS
    +
    2508 isw = 0
    +
    2509 DO 400 j = 1, 7
    +
    2510 IF (mstack(1,mk).EQ.1025) THEN
    +
    2511C YEAR
    +
    2512 isw = isw + 1
    +
    2513 ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2514C MONTH
    +
    2515 isw = isw + 2
    +
    2516 ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2517C DAY
    +
    2518 isw = isw + 4
    +
    2519 ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2520C HOUR
    +
    2521 isw = isw + 8
    +
    2522 ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2523C MINUTE
    +
    2524 isw = isw + 16
    +
    2525 ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2526C TIME SIGNIFICANCE
    +
    2527 isw = isw + 32
    +
    2528 ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2529C 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)
    +
    2539C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2540 mk = mk + 1
    +
    2541 400 CONTINUE
    +
    2542C PRINT *,'TIME ',ISW
    +
    2543 IF (isw.NE.127) THEN
    +
    2544 print *,'TIME ERROR PROCESSING PROFILER'
    +
    2545 iptr(1) = 201
    +
    2546 RETURN
    +
    2547 END IF
    +
    2548C SURFACE DATA
    +
    2549 isw = 0
    +
    2550C PRINT *,'SURFACE'
    +
    2551 DO 600 k = 1, 8
    +
    2552C 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
    +
    2568C PRINT *,'INITIAL INCREMENT = ',INCRHT
    +
    2569 mk = mk + 1
    +
    2570C 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)
    +
    2579C 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
    +
    2592C MUST SAVE THIS HEIGHT VALUE
    +
    2593 lhgt = 500 + ihgt - kdata(i,mk)
    +
    2594C 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
    +
    2599C PROCESS LEVEL DATA
    +
    2600C PRINT *,'LEVEL DATA'
    +
    2601 DO 2000 l = 1, 43
    +
    2602 2020 CONTINUE
    +
    2603C PRINT *,'DESC',MK,MSTACK(1,MK),JK
    +
    2604 isw = 0
    +
    2605C HEIGHT INCREMENT
    +
    2606 IF (mstack(1,mk).EQ.1797) THEN
    +
    2607 incrht = kdata(i,mk)
    +
    2608C 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
    +
    2616C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
    +
    2617C AT THIS POINT
    +
    2618 lhgt = lhgt + incrht
    +
    2619C PRINT *,'LEVEL ',L,LHGT
    +
    2620 IF (l.EQ.37) THEN
    +
    2621 lhgt = lhgt + incrht
    +
    2622 END IF
    +
    2623 jk = jk + 1
    +
    2624C SAVE DESCRIPTOR
    +
    2625 kprofl(jk) = 1798
    +
    2626C SAVE SCALE
    +
    2627 kprof2(jk) = 0
    +
    2628C SAVE DATA
    +
    2629 kset2(jk) = lhgt
    +
    2630C PRINT *,KPROFL(JK),KSET2(JK),JK
    +
    2631 isw = 0
    +
    2632 icon = 1
    +
    2633 DO 800 j = 1, 10
    +
    2634750 CONTINUE
    +
    2635 IF (mstack(1,mk).EQ.1797) THEN
    +
    2636 GO TO 2020
    +
    2637 ELSE IF (mstack(1,mk).EQ.6432) THEN
    +
    2638C HI/LO MODE
    +
    2639 isw = isw + 1
    +
    2640 ELSE IF (mstack(1,mk).EQ.6434) THEN
    +
    2641C Q/C TEST
    +
    2642 isw = isw + 2
    +
    2643 ELSE IF (mstack(1,mk).EQ.2070) THEN
    +
    2644 IF (icon.EQ.1) THEN
    +
    2645C FIRST PASS - U,V CONSENSUS
    +
    2646 isw = isw + 4
    +
    2647 icon = icon + 1
    +
    2648 ELSE
    +
    2649C SECOND PASS - W CONSENSUS
    +
    2650 isw = isw + 64
    +
    2651 END IF
    +
    2652 ELSE IF (mstack(1,mk).EQ.2819) THEN
    +
    2653C 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
    +
    2663C 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
    +
    2672C SAVE DD DESCRIPTOR
    +
    2673 jk = jk + 1
    +
    2674 kprofl(jk) = 2817
    +
    2675 kprof2(jk) = 0
    +
    2676 kset2(jk) = 32767
    +
    2677C 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
    +
    2687C PRINT *,' ',NDIR,NSPD
    +
    2688C SAVE DD DESCRIPTOR
    +
    2689 jk = jk + 1
    +
    2690 kprofl(jk) = 2817
    +
    2691 kprof2(jk) = 0
    +
    2692 kset2(jk) = ndir
    +
    2693C IF (I.EQ.1) THEN
    +
    2694C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2695C ENDIF
    +
    2696C SAVE FFF DESCRIPTOR
    +
    2697 jk = jk + 1
    +
    2698 kprofl(jk) = 2818
    +
    2699 kprof2(jk) = 1
    +
    2700 kset2(jk) = nspd
    +
    2701C IF (I.EQ.1) THEN
    +
    2702C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2703C ENDIF
    +
    2704 END IF
    +
    2705 mk = mk + 1
    +
    2706 GO TO 800
    +
    2707 END IF
    +
    2708 ELSE IF (mstack(1,mk).EQ.2866) THEN
    +
    2709C SPEED STD DEVIATION
    +
    2710 isw = isw + 32
    +
    2711C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
    +
    2712 ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2713C SIGNAL POWER
    +
    2714 isw = isw + 128
    +
    2715 ELSE IF (mstack(1,mk).EQ.2822) THEN
    +
    2716C W COMPONENT
    +
    2717 isw = isw + 256
    +
    2718 ELSE IF (mstack(1,mk).EQ.2867) THEN
    +
    2719C VERT STD DEVIATION
    +
    2720 isw = isw + 512
    +
    2721 ELSE
    +
    2722 mk = mk + 1
    +
    2723 GO TO 750
    +
    2724 END IF
    +
    2725 jk = jk + 1
    +
    2726C SAVE DESCRIPTOR
    +
    2727 kprofl(jk) = mstack(1,mk)
    +
    2728C SAVE SCALE
    +
    2729 kprof2(jk) = mstack(2,mk)
    +
    2730C SAVE DATA
    +
    2731 kset2(jk) = kdata(i,mk)
    +
    2732 mk = mk + 1
    +
    2733C 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
    +
    2742C MOVE DATA BACK INTO KDATA ARRAY
    +
    2743 DO 5000 ll = 1, jk
    +
    2744C DATA
    +
    2745 kdata(i,ll) = kset2(ll)
    +
    2746 5000 CONTINUE
    +
    2747 3000 CONTINUE
    +
    2748 DO 5005 ll = 1, jk
    +
    2749C DESCRIPTOR
    +
    2750 mstack(1,ll) = kprofl(ll)
    +
    2751C SCALE
    +
    2752 mstack(2,ll) = kprof2(ll)
    +
    2753C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
    +
    2754C 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
    +
    gbyte
    subroutine gbyte(ipackd, iunpkd, noff, nbits)
    This is the fortran version of gbyte.
    Definition gbyte.f:27
    +
    gbytes
    subroutine gbytes(ipackd, iunpkd, noff, nbits, iskip, iter)
    Program history log:
    Definition gbytes.f:26
    +
    w3fc05
    subroutine w3fc05(u, v, dir, spd)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition w3fc05.f:29
    +
    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
    +
    fi7809
    subroutine fi7809(ident, mstack, kdata, iptr, maxr, maxd)
    Reformat profiler w hgt increments.
    Definition w3fi78.f:2067
    +
    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
    +
    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
    +
    fi7804
    subroutine fi7804(iptr, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, ll, jdesc, maxr, maxd)
    Process serial data.
    Definition w3fi78.f:1420
    +
    fi7803
    subroutine fi7803(iptr, ident, msga, kdata, ivals, mstack, mwidth, mref, mscale, j, jdesc, maxr, maxd)
    Process compressed data.
    Definition w3fi78.f:1151
    +
    fi7810
    subroutine fi7810(ident, mstack, kdata, iptr, maxr, maxd)
    Reformat profiler edition 2 data.
    Definition w3fi78.f:2460
    +
    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
    +
    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
    diff --git a/w3fi82_8f.html b/w3fi82_8f.html index 7fd15bed..202711a3 100644 --- a/w3fi82_8f.html +++ b/w3fi82_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi82.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi82.f File Reference
    +
    w3fi82.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi82 (ifld, fval1, fdiff1, npts, pds, igds)
     Accept an input array, convert to array of second differences.
     

    Detailed Description

    Convert to second diff array.

    @@ -107,8 +113,8 @@

    Definition in file w3fi82.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi82()

    + +

    ◆ w3fi82()

    @@ -117,37 +123,37 @@

    subroutine w3fi82 ( integer, dimension(*)  - IFLD, + ifld, real  - FVAL1, + fval1, real  - FDIFF1, + fdiff1, integer  - NPTS, + npts, character*1, dimension(*)  - PDS, + pds, integer, dimension(*)  - IGDS  + igds  @@ -197,7 +203,7 @@

    diff --git a/w3fi82_8f.js b/w3fi82_8f.js index 211de566..065c8c1c 100644 --- a/w3fi82_8f.js +++ b/w3fi82_8f.js @@ -1,4 +1,4 @@ var w3fi82_8f = [ - [ "w3fi82", "w3fi82_8f.html#a9d5c017171cdbf13bde5edff05dcd997", null ] + [ "w3fi82", "w3fi82_8f.html#a2888bd47bed9eb1b569ec4da20dcac8f", null ] ]; \ No newline at end of file diff --git a/w3fi82_8f_source.html b/w3fi82_8f_source.html index ed3738c0..30fd26f3 100644 --- a/w3fi82_8f_source.html +++ b/w3fi82_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi82.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,113 +81,121 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi82.f
    +
    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
    -
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    -
    w3fi82
    subroutine w3fi82(IFLD, FVAL1, FDIFF1, NPTS, PDS, IGDS)
    Accept an input array, convert to array of second differences.
    Definition: w3fi82.f:31
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert to second diff array
    +
    3C> @author Bill Cavanaugh @date 1993-07-14
    +
    4
    +
    5C> Accept an input array, convert to array of second
    +
    6C> differences. return the original first value and the first
    +
    7C> first-difference as separate values. align data in
    +
    8C> boustrephedonic style, (alternate row reversal).
    +
    9C>
    +
    10C> Program history log:
    +
    11C> - Bill Cavanaugh 1993-07-14
    +
    12C> - Bill Cavanaugh 1994-01-27 Added reversal of even numbered rows
    +
    13C> (boustrophedonic processing)
    +
    14C> - Bill Cavanaugh 1994-03-02 Corrected improper ordering of even
    +
    15C> numbered rows
    +
    16C> - Ebisuzaki 1999-12-06 Linux port
    +
    17C>
    +
    18C> @param[inout] IFLD
    +
    19C> - [in] Integer input array
    +
    20C> - [out] Second differenced field
    +
    21C> @param[in] NPTS Number of points in array
    +
    22C> @param[in] IGDS
    +
    23C> - (5) Number of rows in array
    +
    24C> - (4) Number of columns in array
    +
    25C> @param[in] PDS (8) Flag indicating presence of gds section
    +
    26C> @param[out] FVAL1 Floating point original first value
    +
    27C> @param[out] FDIFF1 Floating point first first-difference
    +
    28C>
    +
    29C> @author Bill Cavanaugh @date 1993-07-14
    +
    +
    30 SUBROUTINE w3fi82 (IFLD,FVAL1,FDIFF1,NPTS,PDS,IGDS)
    +
    31C
    +
    32 REAL FVAL1,FDIFF1
    +
    33C
    +
    34 INTEGER IFLD(*),NPTS,NBOUST(300),IGDS(*)
    +
    35C
    +
    36 CHARACTER*1 PDS(*)
    +
    37C
    +
    38C ---------------------------------------------
    +
    39C TEST FOR PRESENCE OF GDS
    +
    40C
    +
    41c 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)
    +
    46C
    +
    47C LAY OUT DATA BOUSTROPHEDONIC STYLE
    +
    48C
    +
    49C PRINT*, ' DATA SET UP BOUSTROPHEDON'
    +
    50C
    +
    51 DO 210 i = 2, nrow, 2
    +
    52C
    +
    53C REVERSE THE EVEN NUMBERED ROWS
    +
    54C
    +
    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
    +
    64C
    +
    65C
    +
    66 END IF
    +
    67C =================================================================
    +
    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
    +
    74C
    +
    75C SPECIAL FOR GRIB
    +
    76C FLOAT OUTPUT OF FIRST POINTS TO ANTICIPATE
    +
    77C GRIB FLOATING POINT OUTPUT
    +
    78C
    +
    79 fval1 = ifld(1)
    +
    80 fdiff1 = ifld(2)
    +
    81C
    +
    82C SET FIRST TWO POINTS TO SECOND DIFF VALUE FOR BETTER PACKING
    +
    83C
    +
    84 ifld(1) = ifld(3)
    +
    85 ifld(2) = ifld(3)
    +
    86C -----------------------------------------------------------
    +
    87 RETURN
    +
    +
    88 END
    +
    gbytec
    subroutine gbytec(in, iout, iskip, nbyte)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition gbytec.f:14
    +
    w3fi82
    subroutine w3fi82(ifld, fval1, fdiff1, npts, pds, igds)
    Accept an input array, convert to array of second differences.
    Definition w3fi82.f:31
    diff --git a/w3fi83_8f.html b/w3fi83_8f.html index 6c877f1a..8c7a52c6 100644 --- a/w3fi83_8f.html +++ b/w3fi83_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi83.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi83.f File Reference
    +
    w3fi83.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3fi83 (data, npts, fval1, fdiff1, iscal2, isc10, kpds, kgds)
     Restore delta packed data to original values restore from boustrephedonic alignment.
     

    Detailed Description

    Restore delta packed data to original.

    @@ -107,8 +113,8 @@

    Definition in file w3fi83.f.

    Function/Subroutine Documentation

    - -

    ◆ w3fi83()

    + +

    ◆ w3fi83()

    @@ -117,49 +123,49 @@

    subroutine w3fi83 ( real, dimension(*)  - DATA, + data, integer  - NPTS, + npts, real  - FVAL1, + fval1, real  - FDIFF1, + fdiff1,   - ISCAL2, + iscal2, integer  - ISC10, + isc10, integer, dimension(*)  - KPDS, + kpds, integer, dimension(*)  - KGDS  + kgds  @@ -208,7 +214,7 @@

    diff --git a/w3fi83_8f.js b/w3fi83_8f.js index 1663fec1..1dc6f03d 100644 --- a/w3fi83_8f.js +++ b/w3fi83_8f.js @@ -1,4 +1,4 @@ var w3fi83_8f = [ - [ "w3fi83", "w3fi83_8f.html#abaae8db75615b215003d0b2591b4e49d", null ] + [ "w3fi83", "w3fi83_8f.html#ad0372b453a84bbc270281245dbbad82e", null ] ]; \ No newline at end of file diff --git a/w3fi83_8f_source.html b/w3fi83_8f_source.html index 4df8ec98..8cd6b3f3 100644 --- a/w3fi83_8f_source.html +++ b/w3fi83_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi83.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,123 +81,131 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi83.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Restore delta packed data to original.
    +
    3C> @author Bill Cavanaugh @date 1993-08-18
    +
    4
    +
    5C> Restore delta packed data to original values
    +
    6C> restore from boustrephedonic alignment.
    +
    7C>
    +
    8C> Program history log:
    +
    9C> - Bill Cavanaugh 1993-07-14
    +
    10C> - John Satckpole 1993-07-22 Additions to fix scaling.
    +
    11C> - Bill Cavanaugh 1994-01-27 Added reversal of even numbered rows
    +
    12C> (boustrophedonic processing) to restore
    +
    13C> data to original sequence.
    +
    14C> - Bill Cavanaugh 1994-03-02 Corrected reversal of even numbered rows.
    +
    15C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    16C>
    +
    17C> @param[inout] DATA
    +
    18C> - [in] Second order differences.
    +
    19C> - [out] Expanded original data values.
    +
    20C> @param[in] NPTS Number of points in array.
    +
    21C> @param[in] FVAL1 Original first entry in array.
    +
    22C> @param[in] FDIFF1 Original first first-difference.
    +
    23C> @param[in] ISCAL2 Power-of-two exponent for unscaling.
    +
    24C> @param[in] ISC10 Power-of-ten exponent for unscaling.
    +
    25C> @param[in] KPDS Array of information for pds.
    +
    26C> @param[in] KGDS Array of information for gds.
    +
    27C>
    +
    28C> @note Subprogram can be called from a multiprocessing environment.
    +
    29C>
    +
    30C> @author Bill Cavanaugh @date 1993-08-18
    +
    +
    31 SUBROUTINE w3fi83 (DATA,NPTS,FVAL1,FDIFF1,ISCAL2,
    +
    32 * ISC10,KPDS,KGDS)
    +
    33C
    +
    34 REAL FVAL1,FDIFF1
    +
    35 REAL DATA(*),BOUST(200)
    +
    36 INTEGER NPTS,NROW,NCOL,KPDS(*),KGDS(*),ISC10
    +
    37C ---------------------------------------
    +
    38C
    +
    39C REMOVE DECIMAL UN-SCALING INTRODUCED DURING UNPACKING
    +
    40C
    +
    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
    +
    52C
    +
    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
    +
    60C
    +
    61C NOW REMOVE THE BINARY SCALING FROM THE RECONSTRUCTED FIELD
    +
    62C AND THE DECIMAL SCALING TOO
    +
    63C
    +
    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
    +
    72C ==========================================================
    +
    73 IF (iand(kpds(4),128).NE.0) THEN
    +
    74 nrow = kgds(3)
    +
    75 ncol = kgds(2)
    +
    76C
    +
    77C DATA LAID OUT BOUSTROPHEDONIC STYLE
    +
    78C
    +
    79C
    +
    80C PRINT*, ' REVERSE BOUSTROPHEDON'
    +
    81 DO 210 i = 2, nrow, 2
    +
    82C
    +
    83C REVERSE THE EVEN NUMBERED ROWS
    +
    84C
    +
    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
    +
    94C
    +
    95C
    +
    96 END IF
    +
    97C =================================================================
    +
    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/w3fi85_8f.html b/w3fi85_8f.html index 91696f4a..458f9dde 100644 --- a/w3fi85_8f.html +++ b/w3fi85_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi85.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi85.f File Reference
    +
    w3fi85.f File Reference
    @@ -94,41 +100,41 @@

    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...
     
    subroutine fi8501 (kary, istep, kclass, kseg, idata, rdata, kdata, nsub, kdesc, nrdesc, ierrtn)
     Perform replication of descriptors.
     
    subroutine fi8502 (, kbufr, kclass, kseg, kdesc, nrdesc, i, istep, kary, kdata, isect3, krfvsw, newrfv, ldesc, ierrtn, indexb)
     Process an operator descriptor.
     
    subroutine fi8503 (i, kdesc, nrdesc, isect3, iunitd, kseq, knum, klist, ierrtn)
     Expand sequence descriptor.
     
    subroutine fi8505 (mif, mdesc, nr, ierrtn)
     Convert descriptors fxy to decimal.
     
    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.
     
    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.
     
    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.
     
    subroutine fi8511 (isect3, kary, jif, jdesc, newnr, kif, kdesc, nrdesc, ierrtn)
     Rebuild kdesc from jdesc.
     
    subroutine fi8512 (iunitb, isect3, kdesc, nrdesc, kary, ierrtn, ldesc, aname, aunits, kscale, krfval, kwidth, krfvsw, iunitd, kseq, knum, klist, indexb)
     Read in table B.
     
    subroutine fi8513 (iunitd, isect3, kseq, knum, klist, ierrtn)
     Read in table D.
     
    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).
     

    Detailed Description

    Generate bufr message.

    @@ -137,8 +143,8 @@

    Definition in file w3fi85.f.

    Function/Subroutine Documentation

    - -

    ◆ fi8501()

    + +

    ◆ fi8501()

    @@ -147,67 +153,67 @@

    subroutine fi8501 ( integer, dimension(*)  - KARY, + kary, integer  - ISTEP, + istep, integer  - KCLASS, + kclass, integer  - KSEG, + kseg, integer, dimension(*)  - IDATA, + idata, real, dimension(*)  - RDATA, + rdata, integer, dimension(500,*)  - KDATA, + kdata,   - NSUB, + nsub, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, integer  - IERRTN  + ierrtn  @@ -252,8 +258,8 @@

    -

    ◆ fi8502()

    + +

    ◆ fi8502()

    @@ -262,91 +268,91 @@

    subroutine fi8502 (   - KBUFR, + kbufr, integer  - KCLASS, + kclass, integer  - KSEG, + kseg, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, integer  - I, + i,   - ISTEP, + istep, integer, dimension(*)  - KARY, + kary, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - ISECT3, + isect3, integer, dimension(*)  - KRFVSW, + krfvsw, integer, dimension(*)  - NEWRFV, + newrfv, integer, dimension(*)  - LDESC, + ldesc, integer  - IERRTN, + ierrtn,   - INDEXB  + indexb  @@ -392,8 +398,8 @@

    -

    ◆ fi8503()

    + +

    ◆ fi8503()

    @@ -402,55 +408,55 @@

    subroutine fi8503 ( integer  - I, + i, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, integer, dimension(*)  - ISECT3, + isect3, integer  - IUNITD, + iunitd, integer, dimension(*)  - KSEQ, + kseq, integer, dimension(*)  - KNUM, + knum, integer, dimension(300,*)  - KLIST, + klist, integer  - IERRTN  + ierrtn  @@ -487,8 +493,8 @@

    -

    ◆ fi8505()

    + +

    ◆ fi8505()

    @@ -497,25 +503,25 @@

    subroutine fi8505 (   - MIF, + mif, integer, dimension(3,*)  - MDESC, + mdesc, integer  - NR, + nr,   - IERRTN  + ierrtn  @@ -547,8 +553,8 @@

    -

    ◆ fi8506()

    + +

    ◆ fi8506()

    @@ -557,139 +563,139 @@

    subroutine fi8506 ( integer  - ISTEP, + istep, integer, dimension(*)  - ISECT3, + isect3, integer, dimension(*)  - KARY, + kary, integer, dimension(3,*)  - JDESC, + jdesc, integer  - NEWNR, + newnr, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, integer, dimension(*)  - LDESC, + ldesc, character*40, dimension(*)  - ANAME, + aname, character*25, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - KSCALE, + kscale, integer, dimension(*)  - KRFVAL, + krfval, integer, dimension(*)  - KWIDTH, + kwidth, integer, dimension(*)  - KRFVSW, + krfvsw, integer, dimension(*)  - NEWRFV, + newrfv, integer, dimension(*)  - KSEQ, + kseq, integer, dimension(*)  - KNUM, + knum, integer, dimension(300,*)  - KLIST, + klist,   - IBFSIZ, + ibfsiz, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - KBUFR, + kbufr, integer  - IERRTN, + ierrtn, integer, dimension(*)  - INDEXB  + indexb  @@ -704,11 +710,11 @@

    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-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-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)
    @@ -747,8 +753,8 @@

    -

    ◆ fi8508()

    + +

    ◆ fi8508()

    @@ -757,145 +763,145 @@

    subroutine fi8508 ( integer  - ISTEP, + istep, integer  - IUNITB, + iunitb, integer, dimension(*)  - IDATA, + idata, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, character*1, dimension(*)  - ATEXT, + atext, integer  - KSUB, + ksub, integer, dimension(*)  - KARY, + kary, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - LDESC, + ldesc, character*40, dimension(*)  - ANAME, + aname, character*25, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - KSCALE, + kscale, integer, dimension(*)  - KRFVAL, + krfval, integer, dimension(*)  - KRFVSW, + krfvsw, integer, dimension(*)  - ISECT3, + isect3, integer, dimension(*)  - KWIDTH, + kwidth, integer, dimension(*)  - KASSOC, + kassoc, integer  - IUNITD, + iunitd, integer, dimension(*)  - KSEQ, + kseq, integer, dimension(*)  - KNUM, + knum, integer, dimension(300,*)  - KLIST, + klist,   - IERRTN, + ierrtn, integer, dimension(*)  - INDEXB  + indexb  @@ -910,10 +916,10 @@

    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-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
    @@ -953,8 +959,8 @@

    -

    ◆ fi8509()

    + +

    ◆ fi8509()

    @@ -963,145 +969,145 @@

    subroutine fi8509 ( integer  - ISTEP, + istep, integer  - IUNITB, + iunitb, real, dimension(*)  - RDATA, + rdata, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, character*1, dimension(*)  - ATEXT, + atext, integer  - KSUB, + ksub, integer, dimension(*)  - KARY, + kary, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - LDESC, + ldesc, character*40, dimension(*)  - ANAME, + aname, character*25, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - KSCALE, + kscale, integer, dimension(*)  - KRFVAL, + krfval, integer, dimension(*)  - KRFVSW, + krfvsw, integer, dimension(*)  - ISECT3, + isect3, integer, dimension(*)  - KWIDTH, + kwidth, integer, dimension(*)  - KASSOC, + kassoc, integer  - IUNITD, + iunitd, integer, dimension(*)  - KSEQ, + kseq, integer, dimension(*)  - KNUM, + knum, integer, dimension(300,*)  - KLIST, + klist, integer  - IERRTN, + ierrtn, integer, dimension(*)  - INDEXB  + indexb  @@ -1158,8 +1164,8 @@

    -

    ◆ fi8511()

    + +

    ◆ fi8511()

    @@ -1168,55 +1174,55 @@

    subroutine fi8511 ( integer, dimension(*)  - ISECT3, + isect3, integer, dimension(*)  - KARY, + kary, integer  - JIF, + jif, integer, dimension(3,*)  - JDESC, + jdesc, integer  - NEWNR, + newnr, integer  - KIF, + kif, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, integer  - IERRTN  + ierrtn  @@ -1257,8 +1263,8 @@

    -

    ◆ fi8512()

    + +

    ◆ fi8512()

    @@ -1267,109 +1273,109 @@

    subroutine fi8512 ( integer  - IUNITB, + iunitb, integer, dimension(*)  - ISECT3, + isect3, integer, dimension(3,*)  - KDESC, + kdesc, integer  - NRDESC, + nrdesc, integer, dimension(*)  - KARY, + kary, integer  - IERRTN, + ierrtn, integer, dimension(*)  - LDESC, + ldesc, character*40, dimension(*)  - ANAME, + aname, character*25, dimension(*)  - AUNITS, + aunits, integer, dimension(*)  - KSCALE, + kscale, integer, dimension(*)  - KRFVAL, + krfval, integer, dimension(*)  - KWIDTH, + kwidth, integer, dimension(*)  - KRFVSW, + krfvsw, integer  - IUNITD, + iunitd, integer, dimension(*)  - KSEQ, + kseq, integer, dimension(*)  - KNUM, + knum, integer, dimension(300,*)  - KLIST, + klist, integer, dimension(*)  - INDEXB  + indexb  @@ -1417,8 +1423,8 @@

    -

    ◆ fi8513()

    + +

    ◆ fi8513()

    @@ -1427,37 +1433,37 @@

    subroutine fi8513 ( integer  - IUNITD, + iunitd, integer, dimension(*)  - ISECT3, + isect3, integer, dimension(*)  - KSEQ, + kseq, integer, dimension(*)  - KNUM, + knum, integer, dimension(300,*)  - KLIST, + klist,   - IERRTN  + ierrtn  @@ -1491,8 +1497,8 @@

    -

    ◆ w3fi85()

    + +

    ◆ w3fi85()

    @@ -1501,133 +1507,133 @@

    subroutine w3fi85 (   - ISTEP, + istep,   - IUNITB, + iunitb,   - IUNITD, + iunitd,   - IBFSIZ, + ibfsiz, integer, dimension(*)  - ISECT1, + isect1, integer, dimension(*)  - ISECT3, + isect3,   - JIF, + jif, integer, dimension(3,*)  - JDESC, + jdesc, integer  - NEWNR, + newnr, integer, dimension(*)  - IDATA, + idata, real, dimension(*)  - RDATA, + rdata, character*1, dimension(*)  - ATEXT, + atext, integer, dimension(*)  - KASSOC, + kassoc,   - KIF, + kif, integer, dimension(3,*)  - KDESC, + kdesc,   - NRDESC, + nrdesc, integer, dimension(255)  - ISEC2D, + isec2d, integer  - ISEC2B, + isec2b, integer, dimension(500,*)  - KDATA, + kdata, integer, dimension(*)  - KARY, + kary, integer, dimension(*)  - KBUFR, + kbufr,   - IERRTN  + ierrtn  @@ -1643,10 +1649,10 @@

    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()
    • +
  • 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
    @@ -1828,7 +1834,7 @@

    diff --git a/w3fi85_8f.js b/w3fi85_8f.js index 79aabc01..7bd30e4d 100644 --- a/w3fi85_8f.js +++ b/w3fi85_8f.js @@ -1,14 +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 ] + [ "fi8501", "w3fi85_8f.html#aa0c98da314499613dded4ed29bd67007", null ], + [ "fi8502", "w3fi85_8f.html#aeeb668d3a0405f063fc381f2b6fadf1e", null ], + [ "fi8503", "w3fi85_8f.html#a2288a2988c66dc8a5e48981f36ba4d38", null ], + [ "fi8505", "w3fi85_8f.html#a7a5c1f8087abe23f5aa386dcc6578b88", null ], + [ "fi8506", "w3fi85_8f.html#ab119068cfe66eb960c13bf8fcf3fdd18", null ], + [ "fi8508", "w3fi85_8f.html#ad0e2adc571586558aa11ae9c6220f19b", null ], + [ "fi8509", "w3fi85_8f.html#a2d4241923113f9d2570abb615cf6e6f9", null ], + [ "fi8511", "w3fi85_8f.html#a0ccde573a90a01365eb9e289a1d7cd65", null ], + [ "fi8512", "w3fi85_8f.html#ae31c2999baedbd4f7d4e8b6ee4bbd319", null ], + [ "fi8513", "w3fi85_8f.html#aff8d7f9b19c5927af493f76286da2192", null ], + [ "w3fi85", "w3fi85_8f.html#a7b304c2b30215c2ca98f21d240d4335b", null ] ]; \ No newline at end of file diff --git a/w3fi85_8f_source.html b/w3fi85_8f_source.html index 328d688e..ff7fd53f 100644 --- a/w3fi85_8f_source.html +++ b/w3fi85_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi85.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,2500 +81,2528 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3fi85.f
    +
    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
    -
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    -
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    -
    w3ai38
    subroutine w3ai38(IE, NC)
    Convert EBCDIC to ASCII by character.
    Definition: w3ai38.f:37
    -
    fi8513
    subroutine fi8513(IUNITD, ISECT3, KSEQ, KNUM, KLIST, IERRTN)
    Read in table D.
    Definition: w3fi85.f:2423
    -
    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
    -
    fi8505
    subroutine fi8505(MIF, MDESC, NR, IERRTN)
    Convert descriptors fxy to decimal.
    Definition: w3fi85.f:1393
    -
    fi8503
    subroutine fi8503(I, KDESC, NRDESC, ISECT3, IUNITD, KSEQ, KNUM, KLIST, IERRTN)
    Expand sequence descriptor.
    Definition: w3fi85.f:1307
    -
    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
    -
    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
    -
    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
    -
    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
    -
    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
    -
    fi8511
    subroutine fi8511(ISECT3, KARY, JIF, JDESC, NEWNR, KIF, KDESC, NRDESC, IERRTN)
    Rebuild kdesc from jdesc.
    Definition: w3fi85.f:2205
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Generate bufr message
    +
    3C> @author Bill Cavanaugh @date 1993-09-29
    +
    4
    +
    5C> Using information available in supplied arrays, generate
    +
    6C> a bufr message (wmo code fm94). there may be a section 2
    +
    7C> included in the bufr message if the user follows proper procedure.
    +
    8C> messages are constructed in accordance with bufr edition 2. entries
    +
    9C> for section 1 must be passed to this routine in the isect1 array.
    +
    10C> entries for section 3 must be passed to this routine in isect3.
    +
    11C>
    +
    12C>
    +
    13C> In the event that the user requests a reduction of reports
    +
    14C> in a bufr message if a particular message becomes oversized, the
    +
    15C> possibility exists of the last block of data producing an oversized
    +
    16C> message. the user must verify that isect3(6) does in fact equal
    +
    17C> zero to assure that all of the data has been included as output.
    +
    18C>
    +
    19C> Program history log:
    +
    20C> - Bill Cavanaugh 1993-09-29
    +
    21C> - J. Hoppa 1994-03-22 Corrected an error when writing the
    +
    22C> descriptors into the bufr message
    +
    23C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list
    +
    24C> of subroutine fi8501()
    +
    25C> - J. Hoppa 1994-04-15 Added kbufr to the parameter list of
    +
    26C> subroutine fi8502()
    +
    27C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the
    +
    28C> parameter list of subroutine fi8501()
    +
    29C> - J. Hoppa 1995-04-29 Changed nq and n to kary(2) changed jk to kary(11)
    +
    30C> added an assignment to kary(2) so have something to pass to subroutines
    +
    31C> deleted jk and ll from call to fi8501()
    +
    32C>
    +
    33C> @param[in] ISTEP Key for selection of processing step
    +
    34C> - 1 = Process integer/text array into kdata.
    +
    35C> - 2 = Process real/text array into kdata.
    +
    36C> - 3 = Construct bufr message.
    +
    37C> @param[in] IUNITB Unit number of device containing table b
    +
    38C> @param[in] IUNITD Unit number of device containing table d
    +
    39C> @param[in] IBFSIZ Size in bytes of bufr message array (kbufr)
    +
    40C> should be a multiple of word size.
    +
    41C> @param[in] ISECT1 Contains information to enter into section 1
    +
    42C> (1) Edition number
    +
    43C> (2) Bufr master table number
    +
    44C> 0 = meteorological
    +
    45C> others not yet defined
    +
    46C> (3) Originating center - subcenter number
    +
    47C> (4) Originating center number
    +
    48C> (5) Update sequence number
    +
    49C> (6) Optional section flag should be set to zero unless user write
    +
    50C> additional code to enter local information into section 3
    +
    51C> (7) Bufr message type
    +
    52C> (8) Bufr message sub_type
    +
    53C> (9) Master table version number
    +
    54C> (10) Local table version number
    +
    55C> (11) Year of century - representative of data
    +
    56C> (12) Month - representative of data
    +
    57C> (13) Day - representative of data
    +
    58C> (14) Hour - representative of data
    +
    59C> (15) Minute - representative of data
    +
    60C> (16)-(20) Unused
    +
    61C> @param[in] ISECT3 Values to be inserted into section 3, and to control
    +
    62C> report reduction for oversized messages
    +
    63C> - (1) Number of subsets
    +
    64C> Defines the number of subsets being passed to the encoder routine for
    +
    65C> inclusion into a bufr message. If the user has specified the use of the
    +
    66C> subset/report reduction activation switch, then a part of those subsets may
    +
    67C> be used for the current message and the remainder retained for a subsequent
    +
    68C> message.
    +
    69C> - (2) Observed flag
    +
    70C> - 0 = observed data
    +
    71C> - 1 = other data
    +
    72C> - (3) Compressed flag
    +
    73C> - 0 = noncompressed
    +
    74C> - 1 = compressed
    +
    75C> - (4) Subset/report reduction activation switch used to control the number
    +
    76C> of reports entered into a bufr message when maximum message size is exceeded
    +
    77C> - 0 = option not active
    +
    78C> - 1 = option is active. unused subsets will be shifted to low order
    +
    79C> positions of entry array.
    +
    80C> - 2 = option is active. unused subsets will remain in entry positions.
    +
    81C> @note If this flag is set to any other values, program will be terminated
    +
    82C> with an error condition.
    +
    83C> - (5) Number of reports to decrement by, if oversized message
    +
    84C> (minimum value = one). If zero is entered, it will
    +
    85C> be replaced by one.
    +
    86C> - (6) Number of unused reports returned to user
    +
    87C> - (7) Number of reports included in message
    +
    88C> - (8) Number of table b entries available to decoder
    +
    89C> - (9) Number of table d entries available to decoder
    +
    90C> - (10) Text input flag
    +
    91C> - 0 = ASCII input
    +
    92C> - 1 = EBCIDIC input
    +
    93C> @param[in] JIF JDESC input format flag
    +
    94C> - 0 = F X Y
    +
    95C> - 1 = Decimal format
    +
    96C> @param[in] JDESC List of descriptors to go into section 3
    +
    97C> Each descriptor = F * 16384 + X * 256 + Y
    +
    98C> They may or may not be an exact match of the working descriptor list in kdesc.
    +
    99C> This set of descriptors may contain sequence descriptors to provide additional
    +
    100C> compression within the bufr message. There may be as few as one sequence
    +
    101C> descriptor, or as many descriptors as there are in kdesc.
    +
    102C> @param[in] NEWNR NR of descriptors in JDESC
    +
    103C> @param[in] IDATA Integer array dimensioned by the number of descriptors to
    +
    104C> be used
    +
    105C> @param[in] RDATA Real array dimensioned by the number of descriptors to be
    +
    106C> used
    +
    107C> @param[in] ATEXT Array containing all text data associated with a specific
    +
    108C> report. All data identified as text data must be in ASCII.
    +
    109C> @param[in] KASSOC Integer array dimensioned by the number of descriptors
    +
    110C> to be used, containing the associated field values for any entry in the
    +
    111C> descriptor list.
    +
    112C> @param[in] KIF KDESC input format flag
    +
    113C> - 0 = F X Y
    +
    114C> - 1 = DECIMAL FORMAT
    +
    115C> @param[in] KDESC List of descriptors to go into section 3 fully expanded set of working
    +
    116C> descriptors. there should be an element descriptor for every data entry, but
    +
    117C> there should be no sequence descriptors.
    +
    118C> @param[in] NRDESC NR of descriptors in kdesc
    +
    119C> @param[in] ISEC2D Data or text to be entered into section 2
    +
    120C> @param[in] ISEC2B Number of bytes of data in isec2d
    +
    121C> @param[out] KDATA Source data array . a 2-dimension integer array where
    +
    122C> kdata(subset,param) subset = subset number param = parameter number.
    +
    123C> @param[out] KARY Working array for message under construction
    +
    124C> - (1) unused
    +
    125C> - (2) parameter pointer
    +
    126C> - (3) message bit pointer
    +
    127C> - (4) delayed replication flag
    +
    128C> - 0 = no delayed replication
    +
    129C> - 1 = contains delayed replication
    +
    130C> - (5) bit pointer for start of section 4
    +
    131C> - (6) unused
    +
    132C> - (7) nr of bits for parameter/data packing
    +
    133C> - (8) total bits for ascii data
    +
    134C> - (9) scale change value
    +
    135C> - (10) indicator (used in w3fi85)
    +
    136C> - 1 = numeric data
    +
    137C> - 2 = text data
    +
    138C> - (11) pointer to current pos in kdesc
    +
    139C> - (12) unused
    +
    140C> - (13) unused
    +
    141C> - (14) unused
    +
    142C> - (15) data type
    +
    143C> - (16) unused
    +
    144C> - (17) unused
    +
    145C> - (18) words added for text or associated fields
    +
    146C> - (19) location for total byte count
    +
    147C> - (20) size of section 0
    +
    148C> - (21) size of section 1
    +
    149C> - (22) size of section 2
    +
    150C> - (23) size of section 3
    +
    151C> - (24) size of section 4
    +
    152C> - (25) size of section 5
    +
    153C> - (26) nr bits added by table c operator
    +
    154C> - (27) bit width of associated field
    +
    155C> - (28) jdesc input form flag
    +
    156C> - 0 = Descriptor in f x y form
    +
    157C> - F in JDESC(1,I)
    +
    158C> - X in JDESC(2,I)
    +
    159C> - Y in JDESC(3,I)
    +
    160C> - 1 = DEscriptor in decimal form in jdesc(1,i)
    +
    161C> - (29) kdesc input form flag
    +
    162C> - 0 = Descriptor in F X Y form
    +
    163C> - F in KDESC(1,I)
    +
    164C> - X in KDESC(2,I)
    +
    165C> - Y in KDESC(3,I)
    +
    166C> - 1 = Descriptor in decimal form in kdesc(1,i)
    +
    167C> - (30) bufr message total byte count
    +
    168C> @param[out] KBUFR Array to contain completed bufr message
    +
    169C> @param[out] IERRTN Error return flag
    +
    170C>
    +
    171C> IERRTN:
    +
    172C> - = 0 Normal return, bufr message resides in kbufr
    +
    173C> - if isect3(4)= 0, all reports have been processed into a bufr message
    +
    174C> - if isect3(4)= 1, a bufr message has been generated with all or part of
    +
    175C> the data passed to this routine. isect3(6) contains the number of reports
    +
    176C> that were not used but are being held for the next message.
    +
    177C> - = 1 bufr message construction was halted because contents exceeded maximum size
    +
    178C> (only when isect3(4) = 0)
    +
    179C> - = 2 bufr message construction was halted because of encounter with a
    +
    180C> descriptor not found in table b.
    +
    181C> - = 3 routine was called with no subsets
    +
    182C> - = 4 error occured while reading table b
    +
    183C> - = 5 an attempt was made to expand jdesc into kdesc, but a descriptor indicating
    +
    184C> delayed replication was encountered
    +
    185C> - = 6 error occured while reading table d
    +
    186C> - = 7 data value could not be contained in specified bit width
    +
    187C> - = 8 delayed replication not permitted in compressed data format
    +
    188C> - = 9 an operator descriptor 2 04 yyy opening an associated field (yyy not eq zero)
    +
    189C> was not followed by the defining descriptor 0 31 021 (7957 decimal).
    +
    190C> - = 10 delayed replication descriptor was not followed by descriptor for delayed
    +
    191C> replication factor.
    +
    192C> - 0 31 001
    +
    193C> - 0 31 002
    +
    194C> - 0 31 011
    +
    195C> - 0 31 012
    +
    196C> - = 11 encountered a reference value that forced a data element to become negative
    +
    197C> - = 12 no matching table d entry for sequence descriptor.
    +
    198C> - = 13 encountered a non-acceptable data entry flag. isect3(6) should be 0 or 1.
    +
    199C> - = 14 converting descriptors fxy->decimal, number to convert = 0
    +
    200C> - = 15 no descriptors specified for section 3
    +
    201C> - = 16 incomplete table b, number of descriptors in table b does not match number of
    +
    202C> descriptors needed to construct bufr message
    +
    203C> - = 20 incorrect entry of replication or sequence descriptor in list of reference
    +
    204C> value changes
    +
    205C> - = 21 incorrect operator descriptor in list of reference value changes
    +
    206C> - = 22 attempting to enter new reference value into table b, but descriptor
    +
    207C> does not exist in current modified table b
    +
    208C>
    +
    209C> @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)
    +
    214C
    +
    215 REAL RDATA(*)
    +
    216C
    +
    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
    +
    228C =====================================
    +
    229C 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(*)
    +
    237C =====================================
    +
    238C 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)
    +
    245C =====================================
    +
    246C TABLE D INFORMATION
    +
    247 INTEGER KSEQ(300),KNUM(300)
    +
    248 INTEGER KLIST(300,10)
    +
    249C =====================================
    +
    250 SAVE
    +
    251C
    +
    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/
    +
    264C =====================================
    +
    265C THERE MUST BE DESCRIPTORS IN JDESC
    +
    266C AND A COUNT IN NEWNR
    +
    267C =====================================
    +
    268 IF (newnr.EQ.0) THEN
    +
    269 ierrtn = 15
    +
    270 RETURN
    +
    271 END IF
    +
    272C =====================================
    +
    273C IF INPUT FORM IS F X Y SEGMENTS THEN
    +
    274C CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL
    +
    275C =====================================
    +
    276 IF (jif.EQ.0) THEN
    +
    277C CONVERT TO DECIMAL
    +
    278 CALL fi8505(jif,jdesc,newnr,ierrtn)
    +
    279 IF (ierrtn.NE.0) THEN
    +
    280 RETURN
    +
    281 END IF
    +
    282 END IF
    +
    283C =====================================
    +
    284C IF PROCESSING DELAYED REPLICATION, MUST RELOAD
    +
    285C KDESC FROM JDESC
    +
    286C =====================================
    +
    287 IF (kary(4).NE.0) THEN
    +
    288 nrdesc = 0
    +
    289 END IF
    +
    290C =====================================
    +
    291C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
    +
    292C =====================================
    +
    293C 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
    +
    301C KDESC ALL READY EXISTS
    +
    302 IF (kif.EQ.0) THEN
    +
    303C 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
    +
    310C =====================================
    +
    311C READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE
    +
    312C =====================================
    +
    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
    +
    319C =====================================
    +
    320C ROUTE TO SELECTED PROCESSING
    +
    321C =====================================
    +
    322 ksub = isect3(1)
    +
    323 IF (istep.EQ.1) THEN
    +
    324C 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
    +
    330C 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
    +
    339C =====================================
    +
    340C IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION
    +
    341C =====================================
    +
    342 IF (isect3(1).LE.0) THEN
    +
    343 ierrtn = 3
    +
    344 RETURN
    +
    345 END IF
    +
    346C =====================================
    +
    347C SET FOR BUFR MESSAGE
    +
    348C =====================================
    +
    349C
    +
    350C CLEAR OUTPUT AREA
    +
    351C BYTES IN EACH FULL WORD
    +
    352 kword = 4
    +
    353C
    +
    354C GET NUMBER OF SUBSETS
    +
    355C
    +
    356 mxrpts = isect3(1)
    +
    357 isect3(7) = isect3(1)
    +
    358 isect3(6) = isect3(1)
    +
    359C
    +
    360C RE-START POINT FOR PACKING FEWER SUBSETS ?
    +
    361C
    +
    362 5 CONTINUE
    +
    363C
    +
    364 kary(18) = 0
    +
    365 kary(26) = 0
    +
    366C =====================================
    +
    367C ENTER 'BUFR' - SECTION 0
    +
    368C CONSTRUCT UNDER RULES OF EDITION 2
    +
    369C =====================================
    +
    370 kary(3) = 0
    +
    371 nbufr = 1112884818
    +
    372 CALL sbyte (kbufr,nbufr,kary(3),32)
    +
    373 kary(3) = kary(3) + 32
    +
    374C SAVE POINTER FOR TOTAL BYTE COUNT
    +
    375C IN MESSAGE
    +
    376 kary(19) = kary(3)
    +
    377 kary(3) = kary(3) + 24
    +
    378C SET EDITION NR IN PLACE
    +
    379 CALL sbyte (kbufr,2,kary(3),8)
    +
    380 kary(3) = kary(3) + 8
    +
    381 kary(20) = 8
    +
    382C PRINT *,'SECTION 0'
    +
    383C =====================================
    +
    384C COMPLETE ENTRIES FOR - SECTION 1
    +
    385C =====================================
    +
    386C ----- 1,3 SECTION COUNT
    +
    387 kary(21) = 18
    +
    388 CALL sbyte (kbufr,kary(21),kary(3),24)
    +
    389 kary(3) = kary(3) + 24
    +
    390C ----- 4 RESERVED
    +
    391 CALL sbyte (kbufr,0,kary(3),8)
    +
    392 kary(3) = kary(3) + 8
    +
    393C ----- 5 ORIGINATING SUB-CENTER
    +
    394 CALL sbyte (kbufr,isect1(3),kary(3),8)
    +
    395 kary(3) = kary(3) + 8
    +
    396C ----- 6 ORIGINATING CENTER
    +
    397 CALL sbyte (kbufr,isect1(4),kary(3),8)
    +
    398 kary(3) = kary(3) + 8
    +
    399C ----- 7 UPDATE SEQUENCE NUMBER
    +
    400 CALL sbyte (kbufr,isect1(5),kary(3),8)
    +
    401 kary(3) = kary(3) + 8
    +
    402C ----- 8
    +
    403C 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
    +
    408C ----- 9 BUFR MESSAGE TYPE
    +
    409 CALL sbyte (kbufr,isect1(7),kary(3),8)
    +
    410 kary(3) = kary(3) + 8
    +
    411C ----- 10 BUFR MESSAGE SUB-TYPE
    +
    412 CALL sbyte (kbufr,isect1(8),kary(3),8)
    +
    413 kary(3) = kary(3) + 8
    +
    414C ----- 11 VERSION OF MASTER TABLE
    +
    415 CALL sbyte (kbufr,isect1(9),kary(3),8)
    +
    416 kary(3) = kary(3) + 8
    +
    417C ----- 12 VERSION OF LOCAL TABLE
    +
    418 CALL sbyte (kbufr,isect1(10),kary(3),8)
    +
    419 kary(3) = kary(3) + 8
    +
    420C ----- 13 YEAR
    +
    421 CALL sbyte (kbufr,isect1(11),kary(3),8)
    +
    422 kary(3) = kary(3) + 8
    +
    423C ----- 14 MONTH
    +
    424 CALL sbyte (kbufr,isect1(12),kary(3),8)
    +
    425 kary(3) = kary(3) + 8
    +
    426C ---- 15 DAY
    +
    427 CALL sbyte (kbufr,isect1(13),kary(3),8)
    +
    428 kary(3) = kary(3) + 8
    +
    429C ----- 16 HOUR
    +
    430 CALL sbyte (kbufr,isect1(14),kary(3),8)
    +
    431 kary(3) = kary(3) + 8
    +
    432C ----- 17 MINUTE
    +
    433 CALL sbyte (kbufr,isect1(15),kary(3),8)
    +
    434 kary(3) = kary(3) + 8
    +
    435C ----- 18 FILL
    +
    436 CALL sbyte (kbufr,0,kary(3),8)
    +
    437 kary(3) = kary(3) + 8
    +
    438C PRINT *,'SECTION 1'
    +
    439C =====================================
    +
    440C SKIP - SECTION 2
    +
    441C =====================================
    +
    442 IF (isect1(6).NE.0) THEN
    +
    443C BUILD SECTION COUNT
    +
    444 kary(22) = 4 + isec2b
    +
    445 IF (mod(kary(22),2).NE.0) kary(22) = kary(22) + 1
    +
    446C INSERT SECTION COUNT
    +
    447 CALL sbyte (kbufr,kary(22),kary(3),24)
    +
    448 kary(3) = kary(3) + 24
    +
    449C INSERT RESERVED POSITION
    +
    450 CALL sbyte (kbufr,0,kary(3),8)
    +
    451 kary(3) = kary(3) + 8
    +
    452C 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
    +
    462C =====================================
    +
    463C MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS
    +
    464C =====================================
    +
    465 kary(23) = 7 + newnr*2 + 1
    +
    466C SECTION 3 SIZE
    +
    467 CALL sbyte (kbufr,kary(23),kary(3),24)
    +
    468 kary(3) = kary(3) + 24
    +
    469C RESERVED BYTE
    +
    470 CALL sbyte (kbufr,0,kary(3),8)
    +
    471 kary(3) = kary(3) + 8
    +
    472C NUMBER OF SUBSETS
    +
    473 CALL sbyte (kbufr,isect3(1),kary(3),16)
    +
    474 kary(3) = kary(3) + 16
    +
    475C SET OBSERVED DATA SWITCH
    +
    476 CALL sbyte (kbufr,isect3(2),kary(3),1)
    +
    477 kary(3) = kary(3) + 1
    +
    478C 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
    +
    483C =====================================
    +
    484C DESCRIPTORS - SECTION 3
    +
    485C =====================================
    +
    486 DO 37 kh = 1, newnr
    +
    487C 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
    +
    491C FILL TO TWO BYTE BOUNDARY
    +
    492 CALL sbyte (kbufr,0,kary(3),8)
    +
    493 kary(3) = kary(3) + 8
    +
    494C PRINT *,'SECTION 3'
    +
    495C =====================================
    +
    496C INITIALIZE FOR - SECTION 4
    +
    497C =====================================
    +
    498C SAVE POINTER TO COUNT POSITION
    +
    499C 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
    +
    504C SKIP TO FIRST DATA POSITION
    +
    505C =====================================
    +
    506C BIT PATTERNS - SECTION 4
    +
    507C =====================================
    +
    508 kend4 = ibfsiz * 8 - 32
    +
    509C PACK ALL DATA INTO BUFR MESSAGE
    +
    510C
    +
    511 IF (isect3(3).EQ.0) THEN
    +
    512C **********************************************
    +
    513C * *
    +
    514C * PROCESS AS NON-COMPRESSED MESSAGE *
    +
    515C * *
    +
    516C **********************************************
    +
    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
    +
    526C **********************************************
    +
    527C * *
    +
    528C * PROCESS AS COMPRESSED MESSAGE *
    +
    529C * *
    +
    530C **********************************************
    +
    531 kary(18) = 0
    +
    532C 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
    +
    538C DO 5000 JK = 1, NRDESC
    +
    539C RE-ENTRY POINT FOR INSERTION OF
    +
    540C REPLICATION OR SEQUENCES
    +
    541 4000 CONTINUE
    +
    542C ISOLATE TABLE
    +
    543 kfunc = kdesc(1,kary(11)) / 16384
    +
    544C 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
    +
    549C DELAYED REPLICATION NOT ALLOWED
    +
    550C IN COMPRESSED MESSAGE
    +
    551 IF (kseg.EQ.0) THEN
    +
    552 ierrtn = 8
    +
    553 RETURN
    +
    554 END IF
    +
    555C REPLICATION DESCRIPTOR
    +
    556 CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
    +
    557 * kdata,ll,kdesc,nrdesc,ierrtn)
    +
    558C 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
    +
    575C FALL THRU WITH ELEMENT DESCRIPTOR
    +
    576C POINT TO CORRECT TABLE B ENTRY
    +
    577 l = indexb(kdesc(1,kary(11)))
    +
    578 IF (l.LT.0) THEN
    +
    579 ierrtn = 2
    +
    580C PRINT *,'W3FI85 - IERRTN = 2'
    +
    581 RETURN
    +
    582 END IF
    +
    583C
    +
    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)
    +
    590C
    +
    591 IF (text) THEN
    +
    592C 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
    +
    597C NBINC IS NUMBER OF CHARS
    +
    598 nbinc = kary(7) / 8
    +
    599C 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
    +
    604C HOW MANY FULL WORDS
    +
    605 nkpass = kary(7) / 32
    +
    606C HOW MANY BYTES IN PARTIAL WORD
    +
    607 krem = mod(kary(7),32)
    +
    608C KSKIP = KARY(7) - 32
    +
    609 DO 4080 nss = 1, isect3(1)
    +
    610C POINT TO TEXT FOR THIS SUBSET
    +
    611 kary(2) = kary(11) + kary(18)
    +
    612 IF (nkpass.GE.1) THEN
    +
    613C PROCESS TEXT IN A SUBSET
    +
    614 DO 4070 npp = 1, nkpass
    +
    615C 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
    +
    622C POINT TO NEXT DATA WORD FOR MORE TEXT
    +
    623 kary(2) = kary(2) + 1
    +
    624 4070 CONTINUE
    +
    625 END IF
    +
    626C 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
    +
    636C 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
    +
    642C -------------------------------------------------------------
    +
    643 GO TO 5000
    +
    644 ELSE
    +
    645 kary(2) = kary(11) + kary(18)
    +
    646 kary(7) = kwidth(l) + kary(26)
    +
    647C
    +
    648C NON TEXT/NUMERIC DATA
    +
    649C
    +
    650C 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
    +
    661C 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
    +
    667C 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)
    +
    676C ENTER NBINC
    +
    677 CALL sbyte (kbufr,nbinc,kary(3),6)
    +
    678 kary(3) = kary(3) + 6
    +
    679 ELSE
    +
    680C MIX OF MISSING AND VALUES
    +
    681C 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
    +
    711C 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
    +
    728C 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
    +
    733C 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
    +
    747C 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
    +
    754C ---------------------------------------------------
    +
    755C STANDARD DATA
    +
    756C ---------------------------------------------------
    +
    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
    +
    768C 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
    +
    774C 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)
    +
    783C ENTER NBINC
    +
    784 CALL sbyte (kbufr,nbinc,kary(3),6)
    +
    785 kary(3) = kary(3) + 6
    +
    786 ELSE
    +
    787C MIX OF MISSING AND VALUES
    +
    788C 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))
    +
    801C PRINT *,' '
    +
    802C PRINT *,'START VALUES',LOWEST,MAXVAL,
    +
    803C * '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))
    +
    812C PRINT *,'NEW LOWEST=',LOWEST,J
    +
    813 ELSE IF (kdata(j,kary(2)).GT.maxval) THEN
    +
    814 maxval = kdata(j,kary(2))
    +
    815C PRINT *,'NEW MAXVAL=',MAXVAL,J
    +
    816 END IF
    +
    817 END IF
    +
    818 4036 CONTINUE
    +
    819 mxdiff = maxval - lowest
    +
    820C 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
    +
    831C PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST,
    +
    832C * MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7)
    +
    833C4444 FORMAT(9(1X,I8))
    +
    834C ENTER LOWEST
    +
    835C 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
    +
    850C 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
    +
    864C 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
    +
    871C -------------------------------------------------------------
    +
    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
    +
    881C THE SEGMENT OF CODE BETWEEN STATEMENTS
    +
    882C 5500-6000 ARE ACTIVATED IF AND WHEN THE
    +
    883C MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED
    +
    884C
    +
    885C ARE WE REDUCING IF OVERSIZED ???
    +
    886 IF (isect3(4).NE.0) THEN
    +
    887C INCREMENT REDUCTION COUNT
    +
    888 isect3(6) = isect3(6) + isect3(5)
    +
    889C 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
    +
    899C ---------------------------------------------------------------
    +
    900C FILL IN SECTION 4 OCTET COUNT
    +
    901 nbufr = mod((kary(3) - kary(5)),16)
    +
    902C 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)
    +
    908C PRINT *,'SECTION 4'
    +
    909C =====================================
    +
    910C ENDING KEY '7777' - SECTION 5
    +
    911C =====================================
    +
    912 kary(25) = 4
    +
    913 nbufr = 926365495
    +
    914 CALL sbyte (kbufr,nbufr,kary(3),32)
    +
    915 kary(3) = kary(3) + 32
    +
    916C CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0
    +
    917 itotal = kary(3) / 8
    +
    918 CALL sbyte (kbufr,itotal,32,24)
    +
    919 kary(30) = itotal
    +
    920C WRITE (6,8601) ITOTAL
    +
    921 8601 FORMAT (1x,22hthis message CONTAINS ,i10,6h bytes)
    +
    922C =======================================
    +
    923C KBUFR CONTAINS A COMPLETED MESSAGE
    +
    924 IF (isect3(4).NE.0.AND.isect3(5).NE.0) THEN
    +
    925C 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
    +
    938C =======================================
    +
    939 ierrtn = 0
    +
    940 9000 CONTINUE
    +
    941 RETURN
    +
    +
    942 END
    +
    943C> @brief Perform replication of descriptors
    +
    944C> @author Bill Cavanaugh @date 1993-12-03
    +
    945
    +
    946C> Have encountered a replication descriptor. It may include
    +
    947C> delayed replication or not. That decision should have been
    +
    948C> made prior to calling this routine.
    +
    949C>
    +
    950C> Program history log:
    +
    951C> - Bill Cavanaugh 1993-12-03
    +
    952C> - J. Hoppa 1994-03-25 Added line to initialize nxtptr to correct
    +
    953C> an error in the standard replication.
    +
    954C> - J. Hoppa 1994-03-28 Corrected an error in the standard replication
    +
    955C> that was adding extra zeros to the bufr message after the replicated data.
    +
    956C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list.
    +
    957C> corrected the equation for the number of replications with delayed replication.
    +
    958C> (istart and k don't exist)
    +
    959C> - J. Hoppa 1994-04-19 Switched the variables next and nxtprt
    +
    960C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the parameter
    +
    961C> list. In the assignment of nreps when have delayed replication, changed index
    +
    962C> in kdata from n to k.
    +
    963C> - J. Hoppa 1994-04-29 Removed n and k from the input list changed n to
    +
    964C> kary(11) and k to kary(2)
    +
    965C>
    +
    966C> @param[in] ISTEP
    +
    967C> @param[in] KCLASS
    +
    968C> @param[in] KSEG
    +
    969C> @param[in] IDATA
    +
    970C> @param[in] RDATA
    +
    971C> @param[in] KDATA
    +
    972C> @param[in] NSUB Current subset
    +
    973C> @param[inout] KDESC (modified [out]) List of descriptors
    +
    974C> @param[inout] NRDESC Number of (new [out]) descriptors in kdesc
    +
    975C> @param[out] IERRTN Error return value
    +
    976C> @param KARY
    +
    977C>
    +
    978C> @author Bill Cavanaugh @date 1993-12-03
    +
    +
    979 SUBROUTINE fi8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
    +
    980 * KDATA,NSUB,KDESC,NRDESC,IERRTN)
    +
    981
    +
    982C
    +
    983 REAL RDATA(*)
    +
    984C
    +
    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
    +
    991C
    +
    992 SAVE
    +
    993C
    +
    994C TEST KFUNC FOR DESCRIPTOR TYPE
    +
    995C DO REPLICATION
    +
    996C ****************************************************************
    +
    997 ierrtn = 0
    +
    998C REPLICATION DESCRIPTOR
    +
    999C STANDARD REPLICATION WILL SIMPLY
    +
    1000C BE PROCESSED FROM ITS DESCRIPTOR
    +
    1001C PARTS
    +
    1002C
    +
    1003C DELAYED REPLICATION DESCRIPTOR
    +
    1004C MUST BE FOLLOWED BY ONE OF THE
    +
    1005C DESCRIPTORS FOR A DELAYED
    +
    1006C REPLICATION FACTOR
    +
    1007C 0 31 001 (7937 DECIMAL)
    +
    1008C 0 31 002 (7938 DECIMAL)
    +
    1009C 0 31 011 (7947 DECIMAL)
    +
    1010C 0 31 012 (7948 DECIMAL)
    +
    1011 IF (kseg.NE.0) THEN
    +
    1012C 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
    +
    1022C PRINT *,'HAVE DELAYED REPLICATION'
    +
    1023 kary(4) = 1
    +
    1024C MOVE REPLICATION DEFINITION
    +
    1025 kdesc(1,kary(11)) = kdesc(1,kary(11)+1)
    +
    1026C 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
    +
    1037C POINT TO REPLICATION DESCRIPTOR
    +
    1038 END IF
    +
    1039 ELSE
    +
    1040 ierrtn = 10
    +
    1041 RETURN
    +
    1042 END IF
    +
    1043C EXTRACT DESCRIPTORS TO BE REPLICATED
    +
    1044C IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO
    +
    1045C BE USED IN DEFINING THE DATA,
    +
    1046C OTHERWISE
    +
    1047C 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
    +
    1053C SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS
    +
    1054 END IF
    +
    1055C SAVE OFF TAIL OF DESC STREAM
    +
    1056C 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
    +
    1062C 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
    +
    1071C RESTORE TAIL
    +
    1072 DO 1400 itl = 1, igot
    +
    1073 kdesc(1,iput) = itail(itl)
    +
    1074 iput = iput + 1
    +
    1075 1400 CONTINUE
    +
    1076C
    +
    1077C RESET NUMBER OF DESCRIPTORS IN KDESC
    +
    1078 nrdesc = iput - 1
    +
    1079C ****************************************************************
    +
    1080 RETURN
    +
    +
    1081 END
    +
    1082C> @brief Process an operator descriptor.
    +
    1083C> @author Bill Cavanaugh @date 193-12-03
    +
    1084
    +
    1085C> Have encountered an operator descriptor.
    +
    1086C>
    +
    1087C> Program history log:
    +
    1088C> - Bill Cavanaugh 1993-12-03
    +
    1089C> - J. Hoppa 1994-04-15 Added kbufr to input parameter list.
    +
    1090C> added block of data to correctly use sbyte when writing a 205yyy descriptor to the
    +
    1091C> bufr message. The previous way didn't work because kdata was getting incremeted
    +
    1092C> by the ksub value, not the param value.
    +
    1093C> - J. Hoppa 1994-04-29 Changed k to kary(2) removed a line that became obsolete with
    +
    1094C> above change
    +
    1095C> - J. Hoppa 1994-05-18 Added a kary(2) increment
    +
    1096C>
    +
    1097C> @param[in] KCLASS
    +
    1098C> @param[in] KSEG
    +
    1099C> @param[inout] KDESC
    +
    1100C> @param[inout] NRDESC
    +
    1101C> @param[in] I
    +
    1102C> @param[in] ISTEP
    +
    1103C> @param[inout] KARY
    +
    1104C> @param[out] IERRTN Error return value
    +
    1105C> @param KBUFR
    +
    1106C> @param KDATA
    +
    1107C> @param ISECT3
    +
    1108C> @param KRFVSW
    +
    1109C> @param NEWRFV
    +
    1110C> @param LDESC
    +
    1111C> @param INDEXB
    +
    1112C>
    +
    1113C> @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
    +
    1117C
    +
    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
    +
    1125C
    +
    1126 SAVE
    +
    1127C
    +
    1128 DATA zeroes/255*0/
    +
    1129C
    +
    1130C ****************************************************************
    +
    1131 ierrtn = 0
    +
    1132C OPERATOR DESCRIPTOR
    +
    1133 IF (kclass.EQ.1) THEN
    +
    1134C 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
    +
    1143C 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
    +
    1152C CHANGE REFERENCE VALUE
    +
    1153C MUST ACCEPT INTO OUTPUT THE
    +
    1154C REFERENCE VALUE CHANGE AND ACTIVATE
    +
    1155C THE CHANGE WHILE PROCESSING
    +
    1156 IF (istep.EQ.3) THEN
    +
    1157C HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES
    +
    1158 IF (kseg.EQ.0) THEN
    +
    1159 DO 100 iq = 1, isect3(8)
    +
    1160C RESET ALL NEW REFERENCE VALUES
    +
    1161 krfvsw(iq) = 0
    +
    1162 100 CONTINUE
    +
    1163 END IF
    +
    1164 200 CONTINUE
    +
    1165C GET NEXT DESCRIPTOR
    +
    1166 kary(11) = kary(11) + 1
    +
    1167 IF (kdesc(1,kary(11)).GT.16383) THEN
    +
    1168C 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
    +
    1189C ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE
    +
    1190C 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
    +
    1201C 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
    +
    1206C SET TO PROCESS TEXT/ASCII DATA
    +
    1207C SET TO TEXT
    +
    1208C PROCESS TEXT
    +
    1209
    +
    1210 kary(2) = kary(11) + kary(18)
    +
    1211 IF (istep.EQ.3) THEN
    +
    1212C 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
    +
    1218C POINT AT CORRECT KDATA WORD
    +
    1219 IF (isect3(3).NE.0) THEN
    +
    1220C COMPRESSED
    +
    1221C ---------------------------------------------------
    +
    1222 CALL sbytes(kbufr,zeroes,kary(3),32,0,iter)
    +
    1223 kary(3) = kary(3) + kseg * 8
    +
    1224C
    +
    1225 CALL sbyte (kbufr,kseg*8,kary(3),6)
    +
    1226 kary(3) = kary(3) + 6
    +
    1227C TEXT ENTRY BY SUBSET
    +
    1228 DO 2000 m = 1, isect3(1)
    +
    1229 jay = kary(3)
    +
    1230C NUMBER OF SUBSETS
    +
    1231 DO 1950 kl = 1, iter
    +
    1232C 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
    +
    1242C ---------------------------------------------------
    +
    1243 ELSE
    +
    1244C NOT COMPRESSED
    +
    1245
    +
    1246C CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE).
    +
    1247C AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN
    +
    1248C 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
    +
    1262C 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
    +
    1268C SET TO SKIP PROCESSING OF NEXT DESCRIPTOR
    +
    1269C IF IT IS NOT IN BUFR TABLE B
    +
    1270C DURING THE ENCODING PROCESS, THIS HAS NO MEANING
    +
    1271C ELIMINATE IN PROCESSING
    +
    1272C MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART
    +
    1273C 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
    +
    1282C ****************************************************************
    +
    1283 RETURN
    +
    +
    1284 END
    +
    1285C> @brief Expand sequence descriptor.
    +
    1286C> @author Bill Cavanaugh @date 1993-12-03
    +
    1287
    +
    1288C> Have encountered a sequence descriptor. must perform proper replacment of
    +
    1289C> descriptors in line.
    +
    1290C>
    +
    1291C> Program history log:
    +
    1292C> - Bill Cavanaugh 1993-12-03
    +
    1293C>
    +
    1294C> @param[inout] I Current position in descriptor list
    +
    1295C> @param[inout] KDESC List (modified [out]) of descriptors
    +
    1296C> @param[inout] NRDESC Number (new [out]) of descriptors in kdesc
    +
    1297C> @param[in] IUNITD
    +
    1298C> @param[in] KSEQ
    +
    1299C> @param[in] KNUM
    +
    1300C> @param[in] KLIST
    +
    1301C> @param[out] IERRTN Error return value
    +
    1302C> @param ISECT3
    +
    1303C>
    +
    1304C> @author Bill Cavanaugh @date 1993-12-03
    +
    +
    1305 SUBROUTINE fi8503(I,KDESC,NRDESC,
    +
    1306 * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
    +
    1307
    +
    1308C
    +
    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)
    +
    1319C INTEGER IHOLD(200)
    +
    1320C
    +
    1321 SAVE
    +
    1322C
    +
    1323C ****************************************************************
    +
    1324 ierrtn = 0
    +
    1325C 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
    +
    1330C PRINT *,'EXIT FI8503A'
    +
    1331 RETURN
    +
    1332 END IF
    +
    1333 END IF
    +
    1334C HAVE TABLE D
    +
    1335C
    +
    1336C FIND MATCHING SEQUENCE DESCRIPTOR
    +
    1337 DO 100 l = 1, isect3(9)
    +
    1338 IF (kdesc(1,i).EQ.kseq(l)) THEN
    +
    1339C JEN - DELETE NEXT PRINT LINE
    +
    1340C PRINT *,'FOUND ',KDESC(1,I)
    +
    1341C HAVE A MATCH
    +
    1342 GO TO 200
    +
    1343 END IF
    +
    1344 100 CONTINUE
    +
    1345 ierrtn = 12
    +
    1346 RETURN
    +
    1347 200 CONTINUE
    +
    1348C REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE
    +
    1349 iput = i
    +
    1350C 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
    +
    1357C INSERT SEQUENCE OF DESCRIPTORS AT
    +
    1358C 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
    +
    1365C RESTORE TAIL
    +
    1366 DO 800 kl = 1, kk
    +
    1367 kdesc(1,iput) = itail(kl)
    +
    1368 iput = iput + 1
    +
    1369 800 CONTINUE
    +
    1370C RESET NUMBER OF DESCRIPTORS IN KDESC
    +
    1371 nrdesc = iput - 1
    +
    1372C JEN - DELETE NEXT PRINT LINE
    +
    1373C PRINT *,' NRDESC IS ',NRDESC
    +
    1374
    +
    1375C RESET CURRENT POSITION & RETURN
    +
    1376 RETURN
    +
    +
    1377 END
    +
    1378C> @brief Convert descriptors fxy to decimal
    +
    1379C> @author Bill Cavanaugh @date 1993-12-03
    +
    1380
    +
    1381C> Construct decimal descriptor values from f x and y segments
    +
    1382C>
    +
    1383C> Program history log:
    +
    1384C> - Bill Cavanaugh 1993-12-03
    +
    1385C>
    +
    1386C> @param[in] MIF input flag
    +
    1387C> @param[inout] MDESC list of descriptors in f x y (decimal [out]) form
    +
    1388C> @param[in] NR number of descriptors in mdesc
    +
    1389C> @param[out] IERRTN error return value
    +
    1390C>
    +
    1391C> @author Bill Cavanaugh @date 1993-12-03
    +
    +
    1392 SUBROUTINE fi8505(MIF,MDESC,NR,IERRTN)
    +
    1393
    +
    1394C
    +
    1395 INTEGER MDESC(3,*), NR
    +
    1396C
    +
    1397 SAVE
    +
    1398C
    +
    1399 IF (nr.EQ.0) THEN
    +
    1400 ierrtn = 14
    +
    1401 RETURN
    +
    1402 END IF
    +
    1403C
    +
    1404 DO 100 i = 1, nr
    +
    1405 mdesc(1,i) = mdesc(1,i) * 16384 + mdesc(2,i) * 256
    +
    1406 * + mdesc(3,i)
    +
    1407C JEN - DELETE NEXT PRINT LINE
    +
    1408C PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I)
    +
    1409 100 CONTINUE
    +
    1410 mif = 1
    +
    1411 RETURN
    +
    +
    1412 END
    +
    1413C> @brief Process data in non-compressed format
    +
    1414C> @author Bill Cavanaugh @date 1993-12-03
    +
    1415
    +
    1416C> Process data into non-compressed format for inclusion into
    +
    1417C> section 4 of the bufr message
    +
    1418C>
    +
    1419C> Program history log:
    +
    1420C> - Bill Cavanaugh 1993-12-03
    +
    1421C> - J. Hoppa 1994-03-24 Changed the inner loop from a do loop to a
    +
    1422C> goto loop so nrdesc isn't a set value.
    +
    1423C> corrected a value in the call to fi8503().
    +
    1424C> - J. Hoppa 1994-03-31 Corrected an error in sending the subset
    +
    1425C> number rather than the descriptor number
    +
    1426C> to subroutine fi8501(). Added the subset number to the fi8501() parameter list.
    +
    1427C> - J. Hoppa 1994-04015 Added line to keep the parameter pointer
    +
    1428C> kary(2) up to date. this variable is used
    +
    1429C> in subroutine fi8502().
    +
    1430C> added kbufr to the parameter list in the call
    +
    1431C> to subroutine fi8502().
    +
    1432C> corrected an infinite loop when have an
    +
    1433C> operator descriptor that was caused by
    +
    1434C> a correction made 94-03-24
    +
    1435C> - J. Hoppa 1994-04-20 Added k to call to subroutine w3fi01
    +
    1436C> - J. Hoppa 1994-04-29 Changed n to kary(11) and k to kary(2)
    +
    1437C> removed k and n from the call to fi8501()
    +
    1438C> - J. Hoppa 1994-05-03 Added an increment to kary(11) to prevent
    +
    1439C> and infinite loop when have a missing value
    +
    1440C> - J. Hoppa 1994-05-18 Changed so increments kary(2) after each
    +
    1441C> call to sbyte and deleted
    +
    1442C> kary(2) = kary(11) + kary(18)
    +
    1443C>
    +
    1444C> @param[in] ISTEP
    +
    1445C> @param[in] ISECT3
    +
    1446C> @param[in] KARY
    +
    1447C> @param[in] JDESC
    +
    1448C> @param[in] NEWNR
    +
    1449C> @param[in] KDESC
    +
    1450C> @param[in] NRDESC
    +
    1451C> @param[in] LDESC
    +
    1452C> @param[in] ANAME
    +
    1453C> @param[in] AUNITS
    +
    1454C> @param[in] KSCALE
    +
    1455C> @param[in] KRFVAL
    +
    1456C> @param[in] KWIDTH
    +
    1457C> @param[in] KRFVSW
    +
    1458C> @param[in] NEWRFV
    +
    1459C> @param[in] KSEQ
    +
    1460C> @param[in] KNUM
    +
    1461C> @param[in] KLIST
    +
    1462C> @param[out] KDATA
    +
    1463C> @param[out] KBUFR
    +
    1464C> @param[out] IERRTN
    +
    1465C> @param IBFSIZ
    +
    1466C> @param INDEXB
    +
    1467C>
    +
    1468C> @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
    +
    1474C
    +
    1475C -------------------------------------------------------------
    +
    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
    +
    1492C
    +
    1493 SAVE
    +
    1494C -------------------------------------------------------------
    +
    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/
    +
    1505C -------------------------------------------------------------
    +
    1506 kend = ibfsiz * 8 - 32
    +
    1507C **********************************************
    +
    1508C * *
    +
    1509C * PROCESS AS NON-COMPRESSED MESSAGE *
    +
    1510C * *
    +
    1511C * I POINTS TO SUBSET *
    +
    1512C * N POINTS TO DESCRIPTOR *
    +
    1513C * K ADJUSTS N TO CORRECT DATA ENTRY *
    +
    1514C * *
    +
    1515C **********************************************
    +
    1516 DO 4500 i = 1, isect3(1)
    +
    1517C OUTER LOOP FOR EACH SUBSET
    +
    1518C DO UNTIL ALL DESCRIPTORS HAVE
    +
    1519C BEEN PROCESSED
    +
    1520C SET ADDED BIT FOR WIDTH TO 0
    +
    1521 kary(26) = 0
    +
    1522C SET ASSOCIATED FIELD WIDTH TO 0
    +
    1523 kary(27) = 0
    +
    1524 kary(18) = 0
    +
    1525C IF MESSAGE CONTAINS DELAYED REPLICATION
    +
    1526C WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST
    +
    1527C TO MATCH THE INPUT DATA.
    +
    1528C 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
    +
    1539C INNER LOOP FOR PARAMETER
    +
    1540 4200 CONTINUE
    +
    1541C KARY(2) = KARY(11) + KARY(18)
    +
    1542C PRINT *,'LOOKING AT DESCRIPTOR',KARY(11),
    +
    1543C * KDESC(1,KARY(11)),
    +
    1544C * KARY(2),KDATA(I,KARY(2))
    +
    1545C
    +
    1546C PROCESS ONE DESCRIPTOR AT A TIME
    +
    1547C
    +
    1548C ISOLATE TABLE
    +
    1549C
    +
    1550 kfunc = kdesc(1,kary(11)) / 16384
    +
    1551C 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
    +
    1555C 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
    +
    1563C 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
    +
    1573C 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
    +
    1581C FALL THRU WITH ELEMENT DESCRIPTOR
    +
    1582C FIND MATCHING TABLE B ENTRY
    +
    1583 lk = indexb(kdesc(1,kary(11)))
    +
    1584 IF (lk.LT.1) THEN
    +
    1585C 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
    +
    1591C
    +
    1592 IF (aunits(lk).EQ.ccitt) THEN
    +
    1593 text = .true.
    +
    1594 ELSE
    +
    1595 text = .false.
    +
    1596 END IF
    +
    1597C
    +
    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
    +
    1611C ADD A WORD HERE ONLY
    +
    1612 kary(18) = kary(18) + 1
    +
    1613C 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
    +
    1642C NOT TEXT
    +
    1643 IF (kary(27).NE.0.AND.kdesc(1,kary(11)).NE.7957) THEN
    +
    1644C 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
    +
    1653C KARY(2) = KARY(11) + KARY(18)
    +
    1654 kary(2) = kary(2) + 1
    +
    1655 END IF
    +
    1656C
    +
    1657 jwide = kwidth(lk) + kary(26)
    +
    1658 IF (kdata(i,kary(2)).EQ.misg) THEN
    +
    1659C 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
    +
    1670C CAN DATA BE CONTAINED IN SPECIFIED
    +
    1671C BIT WIDTH, IF NOT - ERROR
    +
    1672 IF (kdata(i,kary(2)).GT.ibits(jwide)) THEN
    +
    1673 ierrtn = 1
    +
    1674 RETURN
    +
    1675 END IF
    +
    1676C ADJUST WITH REFERENCE VALUE
    +
    1677 IF (krfvsw(lk).EQ.0) THEN
    +
    1678 jrv = krfval(lk)
    +
    1679 ELSE
    +
    1680 jrv = newrfv(lk)
    +
    1681 END IF
    +
    1682C
    +
    1683 kdata(i,kary(2)) = kdata(i,kary(2)) - jrv
    +
    1684C IF NEW VALUE IS NEGATIVE - ERROR
    +
    1685 IF (kdata(i,kary(2)).LT.0) THEN
    +
    1686 ierrtn = 11
    +
    1687 RETURN
    +
    1688 END IF
    +
    1689C 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
    +
    1701C 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
    +
    1708C> @brief Combine integer/text data
    +
    1709C> @author Bill Cavanaugh @date 1993-12-03
    +
    1710
    +
    1711C> Construct integer subset from real and text data
    +
    1712C>
    +
    1713C> Program history log:
    +
    1714C> - Bill Cavanaugh 1993-12-03
    +
    1715C> - J. Hoppa 1994-03-31 added ksub to fi8501() parameter list.
    +
    1716C> - J. Hoppa 1994-04-18 added dummy variable idum to fi8502() parameter list.
    +
    1717C> - J. Hoppa 1994-04-20 added dummy variable ll to fi8501() parameter list.
    +
    1718C> - J. Hoppa 1994-04-29 changed i to kary(11) added a kary(2) assignment so have something
    +
    1719C> to pass to subroutines ** test this ** removed i and ll from call to fi8501()
    +
    1720C> - J. Hoppa 1994-05-13 added code to calculate kwords when kfunc=2
    +
    1721C> - J. Hoppa 1994-05-18 deleted kary(2) assignment
    +
    1722C>
    +
    1723C> @param[in] ISTEP
    +
    1724C> @param[in] IUNITB Unit number of device containing table b
    +
    1725C> @param[in] IDATA Integer working array
    +
    1726C> @param[in] KDESC Expanded descriptor set
    +
    1727C> @param[in] NRDESC Number of descriptors in kdesc
    +
    1728C> @param[in] ATEXT Text data for ccitt ia5 and text operator fields
    +
    1729C> @param[in] KSUB Subset number
    +
    1730C> @param[in] KARY Working array
    +
    1731C> @param[in] ISECT3
    +
    1732C> @param[out] KDATA Array containing integer subsets
    +
    1733C> @param[out] LDESC List of table b descriptors (decimal)
    +
    1734C> @param[out] ANAME List of descriptor names
    +
    1735C> @param[out] AUNITS Units for each descriptor
    +
    1736C> @param[out] KSCALE Base 10 scale factor for each descriptor
    +
    1737C> @param[out] KRFVAL Reference value for each descriptor
    +
    1738C> @param[out] KRFVSW
    +
    1739C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
    +
    1740C> @param[out] KASSOC
    +
    1741C> @param[out] IERRTN Error return flag
    +
    1742C> @param IUNITD
    +
    1743C> @param KSEQ
    +
    1744C> @param KNUM
    +
    1745C> @param KLIST
    +
    1746C> @param INDEXB
    +
    1747C>
    +
    1748C> @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
    +
    1753C TAKE EACH NON-TEXT ENTRY OF SECTION 2
    +
    1754C ACCEPT IT
    +
    1755C
    +
    1756C TAKE EACH TEXT ENTRY
    +
    1757C INSERT INTO INTEGER ARRAY,
    +
    1758C ADDING FULL WORDS AS NECESSARY
    +
    1759C MAKE SURE ANY LAST WORD HAS TEXT DATA
    +
    1760C RIGHT JUSTIFIED
    +
    1761C ---------------------------------------------------------------------
    +
    1762C PASS BACK CONVERTED ENTRY TO LOCATION
    +
    1763C SPECIFIED BY USER
    +
    1764C
    +
    1765C REFERENCE VALUE WILL BE APPLIED DURING
    +
    1766C ENCODING OF MESSAGE
    +
    1767C ---------------------------------------------------------------------
    +
    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(*)
    +
    1788C
    +
    1789 SAVE
    +
    1790C
    +
    1791 equivalence(ahold1,ihold4)
    +
    1792C
    +
    1793C =====================================
    +
    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/
    +
    1804C
    +
    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
    +
    1813C HAVE TABLE B AVAILABLE NOW
    +
    1814C
    +
    1815C LOOK AT EACH DATA ENTRY
    +
    1816C CONVERT NON TEXT
    +
    1817C MOVE TEXT
    +
    1818C
    +
    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
    +
    1825C
    +
    1826C RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S
    +
    1827C
    +
    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)
    +
    1833C KARY(2) = KARY(11) + KARY(18)
    +
    1834 IF (kfunc.EQ.1) THEN
    +
    1835C 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
    +
    1844C HANDLE TEXT OPERATORS
    +
    1845CC
    +
    1846 kavail = idata(kary(11))
    +
    1847C 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
    +
    1854CC
    +
    1855 jwide = kseg * 8
    +
    1856 GO TO 1200
    +
    1857 END IF
    +
    1858 ELSE IF (kfunc.EQ.3) THEN
    +
    1859C 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
    +
    1867C
    +
    1868C FIND MATCHING DESCRIPTOR
    +
    1869C
    +
    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
    +
    1877C 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
    +
    1883C 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
    +
    1892C IF NOT MISSING DATA
    +
    1893 IF (idata(kary(11)).EQ.99999) THEN
    +
    1894 kpos = kpos + 1
    +
    1895 kdata(ksub,kpos) = misg
    +
    1896 ELSE
    +
    1897C PROCESS INTEGER VALUES
    +
    1898 kpos = kpos + 1
    +
    1899 kdata(ksub,kpos) = idata(kary(11))
    +
    1900 END IF
    +
    1901 ELSE
    +
    1902C PROCESS TEXT
    +
    1903C NUMBER OF BYTES REQUIRED BY TABLE B
    +
    1904 kreq = kwidth(k) / 8
    +
    1905C NUMBER BYTES AVAILABLE IN ATEXT
    +
    1906 kavail = idata(kary(11))
    +
    1907C 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
    +
    1914C 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
    +
    1933C> @brief Convert real/text input to integer
    +
    1934C> @author Bill Cavanaugh @date 1993-12-03
    +
    1935
    +
    1936C> Construct integer subset from real and text data.
    +
    1937C>
    +
    1938C> Program history log:
    +
    1939C> - Bill Cavanaugh 1993-12-03
    +
    1940C> - J. Hoppa 1994-03-31 Added ksub to the fi8501 parameter list.
    +
    1941C> - J. Hoppa 1994-04-18 Added dummy variable idum to fi8502 parameter list.
    +
    1942C> - J. Hoppa 1994-04-20 Added dummy variable ll to fi8501 parameter list.
    +
    1943C> - J. Hoppa 1994-04-29 Changed i to kary(11) added a kary(2) assignment so have something
    +
    1944C> to pass to subroutines ** test this ** removed i and ll from call to fi8501
    +
    1945C> - J. Hoppa 1994-05-18 Deleted kary(2) assignment
    +
    1946C>
    +
    1947C> @param[in] IUNITB unit number of device containing table b
    +
    1948C> @param[in] RDATA real working array
    +
    1949C> @param[in] KDESC expanded descriptor set
    +
    1950C> @param[in] NRDESC number of descriptors in kdesc
    +
    1951C> @param[in] ATEXT text data for ccitt ia5 and text operator fields
    +
    1952C> @param[in] KSUB subset number
    +
    1953C> @param[in] KARY working array
    +
    1954C> @param[in] ISECT3
    +
    1955C> @param[in] IUNITD
    +
    1956C> @param[out] KDATA Array containing integer subsets
    +
    1957C> @param[out] LDESC List of table b descriptors (decimal)
    +
    1958C> @param[out] ANAME List of descriptor names
    +
    1959C> @param[out] AUNITS Units for each descriptor
    +
    1960C> @param[out] KSCALE Base 10 scale factor for each descriptor
    +
    1961C> @param[out] KRFVAL Reference value for each descriptor
    +
    1962C> @param[out] KRFVSW
    +
    1963C> @param[out] KASSOC
    +
    1964C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
    +
    1965C> @param[out] IERRTN Error return flag
    +
    1966C> @param[out] KNUM
    +
    1967C> @param[out] KLIST
    +
    1968C> @param ISTEP
    +
    1969C> @param KSEQ
    +
    1970C> @param INDEXB
    +
    1971C>
    +
    1972C> @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
    +
    1977C TAKE EACH NON-TEXT ENTRY OF SECTION 2
    +
    1978C SCALE IT
    +
    1979C ROUND IT
    +
    1980C CONVERT TO INTEGER
    +
    1981C
    +
    1982C TAKE EACH TEXT ENTRY
    +
    1983C INSERT INTO INTEGER ARRAY,
    +
    1984C ADDING FULL WORDS AS NECESSARY
    +
    1985C MAKE SURE ANY LAST WORD HAS TEXT DATA
    +
    1986C RIGHT JUSTIFIED
    +
    1987C PASS BACK CONVERTED ENTRY TO LOCATION
    +
    1988C SPECIFIED BY USER
    +
    1989C
    +
    1990C REFERENCE VALUE WILL BE APPLIED DURING
    +
    1991C ENCODING OF MESSAGE
    +
    1992C ---------------------------------------------------------------------
    +
    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(*)
    +
    2016C
    +
    2017 SAVE
    +
    2018C =====================================
    +
    2019 equivalence(ahold1,ihold4)
    +
    2020C
    +
    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'/
    +
    2029C
    +
    2030 DATA ccitt /'CCITT IA5 '/
    +
    2031 DATA misg /99999/
    +
    2032C =====================================
    +
    2033C
    +
    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
    +
    2042C HAVE TABLE B AVAILABLE NOW
    +
    2043C
    +
    2044C LOOK AT EACH DATA ENTRY
    +
    2045C CONVERT NON TEXT
    +
    2046C MOVE TEXT
    +
    2047C
    +
    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
    +
    2054C RE-ENRY POINT FOR REPLICATION AND
    +
    2055C 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)
    +
    2061C KARY(2) = KARY(11) + KARY(18)
    +
    2062 IF (kfunc.EQ.1) THEN
    +
    2063C 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
    +
    2071C HANDLE OPERATORS
    +
    2072 IF (kclass.EQ.5) THEN
    +
    2073C NUMBER BYTES AVAILABLE IN ATEXT
    +
    2074 kavail = rdata(kary(11))
    +
    2075C 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
    +
    2093C 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
    +
    2101C
    +
    2102C FIND MATCHING DESCRIPTOR
    +
    2103C
    +
    2104 k = indexb(kdesc(1,kary(11)))
    +
    2105 IF (k.LT.1) THEN
    +
    2106 ierrtn = 2
    +
    2107C PRINT *,'FI8509 - IERRTN = 2'
    +
    2108 RETURN
    +
    2109 END IF
    +
    2110C 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
    +
    2116C 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
    +
    2125C IF NOT MISSING DATA
    +
    2126 IF (rdata(kary(11)).EQ.99999.) THEN
    +
    2127 kpos = kpos + 1
    +
    2128 kdata(ksub,kpos) = misg
    +
    2129 ELSE
    +
    2130C PROCESS REAL VALUES
    +
    2131 IF (kscale(k).NE.0) THEN
    +
    2132C 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
    +
    2140C PERFORM ROUNDING
    +
    2141 rdata(kary(11)) = rdata(kary(11)) +
    +
    2142 * sign(0.5,rdata(kary(11)))
    +
    2143C CONVERT TO INTEGER
    +
    2144 kpos = kpos + 1
    +
    2145 kdata(ksub,kpos) = rdata(kary(11))
    +
    2146C
    +
    2147 END IF
    +
    2148 ELSE
    +
    2149C PROCESS TEXT
    +
    2150C NUMBER OF BYTES REQUIRED BY TABLE B
    +
    2151 kreq = kwidth(k) / 8
    +
    2152C NUMBER BYTES AVAILABLE IN ATEXT
    +
    2153 kavail = rdata(kary(11))
    +
    2154C 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
    +
    2161C 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
    +
    2178C DO 2000 I = 1, KPOS
    +
    2179C2000 CONTINUE
    +
    2180 RETURN
    +
    +
    2181 END
    +
    2182C> @brief Rebuild kdesc from jdesc
    +
    2183C> @author Bill Cavanaugh @date 1993-12-03
    +
    2184
    +
    2185C> Construct working descriptor list from list of descriptors in section 3.
    +
    2186C>
    +
    2187C> Program history log:
    +
    2188C> - Bill Cavanaugh 1993-12-03
    +
    2189C>
    +
    2190C> @param[in] ISECT3
    +
    2191C> @param[in] KARY Utility - array see main routine
    +
    2192C> @param[in] JIF Descriptor input form flag
    +
    2193C> @param[in] JDESC List of descriptors for section 3
    +
    2194C> @param[in] NEWNR Number of descriptors in jdesc
    +
    2195C> @param[out] KIF Descriptor form
    +
    2196C> @param[out] KDESC Working list of descriptors
    +
    2197C> @param[out] NRDESC Number of descriptors in kdesc
    +
    2198C> @param[out] IERRTN Error return
    +
    2199C> - IERRTN = 0 Normal return
    +
    2200C> - IERRTN = 5 Found delayed replication during expansion
    +
    2201C>
    +
    2202C> @author Bill Cavanaugh @date 1993-12-03
    +
    +
    2203 SUBROUTINE fi8511(ISECT3,KARY,JIF,JDESC,NEWNR,
    +
    2204 * KIF,KDESC,NRDESC,IERRTN)
    +
    2205
    +
    2206C
    +
    2207 INTEGER JDESC(3,*), NEWNR, KDESC(3,*), NRDESC
    +
    2208 INTEGER KARY(*),IERRTN,KIF,JIF
    +
    2209 INTEGER ISECT3(*)
    +
    2210C
    +
    2211 SAVE
    +
    2212C
    +
    2213 IF (NEWNR.EQ.0) THEN
    +
    2214 IERRTN = 3
    +
    2215 return
    +
    2216 END IF
    +
    2217C
    +
    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
    +
    2235C> @brief Read in table B
    +
    2236C> @author Bill Cavanaugh @date 1993-12-03
    +
    2237
    +
    2238C> Read in tailored set of table B descriptors.
    +
    2239C>
    +
    2240C> Program history log:
    +
    2241C> - Bill Cavanaugh 1993-12-03
    +
    2242C> - J. Hoppa 1994-04-18 An error has been corrected to prevent later
    +
    2243C> searching table b if there are only operator
    +
    2244C> descriptors in the descriptor list.
    +
    2245C> - J. Hoppa 1994-05-17 Changed the loop for expanding sequence
    +
    2246C> descriptors from a do loop to a goto loop
    +
    2247C>
    +
    2248C> @param[in] IUNITB Unit where table b entries reside
    +
    2249C> @param[in] KDESC Working descriptor list
    +
    2250C> @param[in] NRDESC Number of descriptors in kdesc
    +
    2251C> @param[in] IUNITD Unit where table d entries reside
    +
    2252C> @param[out] KARY
    +
    2253C> @param[out] IERRTN
    +
    2254C> @param[out] LDESC Descriptors in table b (decimal values)
    +
    2255C> @param[out] ANAME Array containing names of descriptors
    +
    2256C> @param[out] AUNITS Array containing units of descriptors
    +
    2257C> @param[out] KSCALE Scale values for each descriptor
    +
    2258C> @param[out] KRFVAL Reference values for each descriptor
    +
    2259C> @param[out] KWIDTH Bit width of each descriptor
    +
    2260C> @param[out] KRFVSW New reference value switch
    +
    2261C> @param[out] KSEQ Sequence descriptor
    +
    2262C> @param[out] KNUM Number of descriptors in sequence
    +
    2263C> @param[out] KLIST Sequence of descriptors
    +
    2264C> @param ISECT3
    +
    2265C> @param INDEXB
    +
    2266C>
    +
    2267C> @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
    +
    2272C
    +
    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(*)
    +
    2279C
    +
    2280 INTEGER MDESC(800),MR,I,J
    +
    2281C
    +
    2282 SAVE
    +
    2283C
    +
    2284C ===================================================================
    +
    2285 ierrtn = 0
    +
    2286 DO 100 i = 1, 30
    +
    2287 kary(i) = 0
    +
    2288 100 CONTINUE
    +
    2289C INITIALIZE DESCRIPTOR POINTERS TO MISSING
    +
    2290 DO 105 i = 1, 16383
    +
    2291 indexb(i) = -1
    +
    2292 105 CONTINUE
    +
    2293C
    +
    2294C ===================================================================
    +
    2295C MAKE A COPY OF THE DESCRIPTOR LIST
    +
    2296C 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
    +
    2305C ===================================================================
    +
    2306C REPLACE ALL SEQUENCE DESCRIPTORS
    +
    2307C JEN - FIXED NEXT BLOCK
    +
    2308C 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
    +
    2323C 300 CONTINUE
    +
    2324C ===================================================================
    +
    2325C ISOLATE SINGLE COPIES OF DESCRIPTORS
    +
    2326 mr = 1
    +
    2327C THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN
    +
    2328C 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
    +
    2340C ===================================================================
    +
    2341C SORT INTO ASCENDING ORDER
    +
    2342C 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
    +
    2355C ===================================================================
    +
    2356 rewind iunitb
    +
    2357C
    +
    2358C READ IN A MODIFIED TABLE B -
    +
    2359C MODIFIED TABLE B CONTAINS ONLY
    +
    2360C THOSE DESCRIPTORS ASSOCIATED WITH
    +
    2361C CURRENT DATA.
    +
    2362C
    +
    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
    +
    2371C
    +
    2372 IF (ldesc(nrtblb).EQ.mdesc(nrtblb)) THEN
    +
    2373C PRINT *,'1001',NRTBLB,LDESC(NRTBLB)
    +
    2374C PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB),
    +
    2375C * KRFVAL(NRTBLB),KWIDTH(NRTBLB)
    +
    2376 ktry = ktry + 1
    +
    2377 indexb(ldesc(nrtblb)) = ktry
    +
    2378C PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY
    +
    2379 ELSE IF (ldesc(nrtblb).GT.mdesc(nrtblb)) THEN
    +
    2380C 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
    +
    2392C DO 1998 I = 1, 16383, 30
    +
    2393C WRITE (6,1999) (INDEXB(I+J),J=0,23)
    +
    2394C1998 CONTINUE
    +
    2395C1999 FORMAT(30(1X,I3))
    +
    2396C
    +
    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
    +
    2406C> @brief Read in table D
    +
    2407C> @author Bill Cavanaugh @date 1993-12-03
    +
    2408
    +
    2409C> Read in table D
    +
    2410C>
    +
    2411C> Program history log:
    +
    2412C> - Bill Cavanaugh 1993-12-03
    +
    2413C>
    +
    2414C> @param[in] IUNITD Unit number of input device
    +
    2415C> @param[out] KSEQ Key for sequence descriptors
    +
    2416C> @param[out] KNUM Number if descriptors in list
    +
    2417C> @param[out] KLIST Descriptors list
    +
    2418C> @param[out] IERRTN Error return flag
    +
    2419C> @param ISECT3
    +
    2420C>
    +
    2421C> @author Bill Cavanaugh @date 1993-12-03
    +
    +
    2422 SUBROUTINE fi8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
    +
    2423
    +
    2424C
    +
    2425 INTEGER IUNITD, ISECT3(*)
    +
    2426 INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
    +
    2427 INTEGER KKF(10),KKX(10),KKY(10),KF,KX,KY
    +
    2428C
    +
    2429 SAVE
    +
    2430C
    +
    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
    +
    2448C BUILD SEQUENCE KEY
    +
    2449 kseq(j) = 16384*kf + 256*kx + ky
    +
    2450 DO 2000 lm = 1, 10
    +
    2451C 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
    +
    gbyte
    subroutine gbyte(ipackd, iunpkd, noff, nbits)
    This is the fortran version of gbyte.
    Definition gbyte.f:27
    +
    sbyte
    subroutine sbyte(iout, in, iskip, nbyte)
    Definition sbyte.f:12
    +
    w3ai38
    subroutine w3ai38(ie, nc)
    Convert EBCDIC to ASCII by character.
    Definition w3ai38.f:37
    +
    fi8511
    subroutine fi8511(isect3, kary, jif, jdesc, newnr, kif, kdesc, nrdesc, ierrtn)
    Rebuild kdesc from jdesc.
    Definition w3fi85.f:2205
    +
    fi8503
    subroutine fi8503(i, kdesc, nrdesc, isect3, iunitd, kseq, knum, klist, ierrtn)
    Expand sequence descriptor.
    Definition w3fi85.f:1307
    +
    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
    +
    fi8505
    subroutine fi8505(mif, mdesc, nr, ierrtn)
    Convert descriptors fxy to decimal.
    Definition w3fi85.f:1393
    +
    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
    +
    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
    +
    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
    +
    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
    +
    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
    +
    fi8513
    subroutine fi8513(iunitd, isect3, kseq, knum, klist, ierrtn)
    Read in table D.
    Definition w3fi85.f:2423
    diff --git a/w3fi88_8f.html b/w3fi88_8f.html index c314b5f1..2420d16f 100644 --- a/w3fi88_8f.html +++ b/w3fi88_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi88.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3fi88.f File Reference
    +
    w3fi88.f File Reference
    @@ -94,65 +100,58 @@

    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...
     
    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.
     
    subroutine fi8802 (iptr, ident, msga, kdata, kfxy1, ll, mstack, aunit1, iwide1, irfvl1, iscal1, jdesc, ivals, j, maxr, maxd, kptrb)
     Process element descriptor.
     
    subroutine fi8803 (iptr, ident, msga, kdata, ivals, mstack, iwide1, irfvl1, iscal1, j, jdesc, maxr, maxd)
     Process compressed data.
     
    subroutine fi8804 (iptr, msga, kdata, ivals, mstack, iwide1, irfvl1, iscal1, j, ll, jdesc, maxr, maxd)
     Process serial data.
     
    subroutine fi8805 (iptr, ident, msga, iwork, lx, ly, kdata, ll, knr, mstack, maxr, maxd)
     Process a replication descriptor.
     
    subroutine fi8806 (iptr, lx, ly, ident, msga, kdata, ivals, mstack, iwide1, irfvl1, iscal1, j, ll, kfxy1, iwork, jdesc, maxr, maxd, kptrb)
     Process operator descriptors.
     
    subroutine fi8807 (iptr, iwork, itbld, itbld2, jdesc, kptrd)
     Process queue descriptor.
     
    subroutine fi8808 (iptr, iwork, lf, lx, ly, jdesc)
     Program history log:
     
    subroutine fi8809 (ident, mstack, kdata, iptr, maxr, maxd)
     Reformat profiler w hgt increments.
     
    subroutine fi8810 (ident, mstack, kdata, iptr, maxr, maxd)
     Reformat profiler edition 2 data.
     
    subroutine fi8811 (iptr, ident, mstack, kdata, knr, ldata, lstack, maxd, maxr)
     Expand data/descriptor replication.
     
    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.
     

    Detailed Description

    BUFR message decoder.

    @@ -161,8 +160,8 @@

    Definition in file w3fi88.f.

    Function/Subroutine Documentation

    - -

    ◆ fi8801()

    + +

    ◆ fi8801()

    @@ -171,229 +170,229 @@

    subroutine fi8801 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(*)  - ISTACK, + istack, integer, dimension(*)  - IWORK, + iwork, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(maxr)  - KNR, + knr, integer  - INDEX, + index, integer  - MAXR, + maxr, integer  - MAXD, + maxd, integer, dimension(*)  - KFXY1, + kfxy1, character*40, dimension(*)  - ANAME1, + aname1, character*24, dimension(*)  - AUNIT1, + aunit1, integer, dimension(*)  - ISCAL1, + iscal1, integer, dimension(3,*)  - IRFVL1, + irfvl1, integer, dimension(*)  - IWIDE1, + iwide1,   - IRF1SW, + irf1sw,   - INEWVL, + inewvl, integer, dimension(*)  - KFXY2, + kfxy2, character*64, dimension(*)  - ANAME2, + aname2, character*24, dimension(*)  - AUNIT2, + aunit2, integer, dimension(*)  - ISCAL2, + iscal2, integer, dimension(*)  - IRFVL2, + irfvl2, integer, dimension(*)  - IWIDE2, + iwide2, integer, dimension(200)  - KFXY3, + kfxy3, character*64, dimension(200)  - ANAME3, + aname3, character*24, dimension(200)  - AUNIT3, + aunit3, integer, dimension(200)  - ISCAL3, + iscal3, integer, dimension(200)  - IRFVL3, + irfvl3, integer, dimension(200)  - IWIDE3, + iwide3,   - IUNITB, + iunitb,   - IUNITD, + iunitd, integer, dimension(20,*)  - ITBLD, + itbld, integer, dimension(20,*)  - ITBLD2, + itbld2, integer, dimension(*)  - KPTRB, + kptrb, integer, dimension(*)  - KPTRD  + kptrd  @@ -415,8 +414,8 @@

    Parameters
    - - + + @@ -444,7 +443,11 @@

    - +
    [in]IPTRSee w3fi88() routine docblock
    [in]IDENTSee w3fi88() routine docblock
    [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
    KNR
    IVALS
    IRF1SW
    INEWVLError return:
      +
    INEWVL
    +
    + +

    Error return:

    • IPTR(1)
      • = 8 Error reading table b
      • = 9 Error reading table d
        • @@ -452,10 +455,6 @@

        Author
        Bill Cavanaugh
        Date
        1988-09-01
        @@ -463,8 +462,8 @@

        -

        ◆ fi8802()

        + +

        ◆ fi8802()

        @@ -473,103 +472,103 @@

        subroutine fi8802 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - KFXY1, + kfxy1,   - LL, + ll, integer, dimension(2,maxd)  - MSTACK, + mstack, character*24, dimension(*)  - AUNIT1, + aunit1, integer, dimension(*)  - IWIDE1, + iwide1, integer, dimension(3,*)  - IRFVL1, + irfvl1, integer, dimension(*)  - ISCAL1, + iscal1, integer  - JDESC, + jdesc, integer, dimension(*)  - IVALS, + ivals, integer  - J, + j,   - MAXR, + maxr,   - MAXD, + maxd, integer, dimension(*)  - KPTRB  + kptrb  @@ -601,10 +600,11 @@

        JDESC IVALS J - KPTRBError return: IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist in table b. + KPTRB +

        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
        @@ -612,8 +612,8 @@

        -

        ◆ fi8803()

        + +

        ◆ fi8803()

        @@ -622,79 +622,79 @@

        subroutine fi8803 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(*)  - IWIDE1, + iwide1, integer, dimension(3,*)  - IRFVL1, + irfvl1, integer, dimension(*)  - ISCAL1, + iscal1, integer  - J, + j, integer  - JDESC, + jdesc, integer  - MAXR, + maxr, integer  - MAXD  + maxd  @@ -740,8 +740,8 @@

        -

        ◆ fi8804()

        + +

        ◆ fi8804()

        @@ -750,79 +750,79 @@

        subroutine fi8804 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(*)  - IWIDE1, + iwide1, integer, dimension(3,*)  - IRFVL1, + irfvl1, integer, dimension(*)  - ISCAL1, + iscal1, integer  - J, + j, integer  - LL, + ll, integer  - JDESC, + jdesc, integer  - MAXR, + maxr, integer  - MAXD  + maxd  @@ -843,7 +843,7 @@

        Parameters
        - + @@ -855,10 +855,11 @@

        [out]

        - +
        [in]IPTRSee w3fi88() routine docblock
        [in]IPTRSee w3fi88() routine docblock
        [in]MSGAArray containing bufr message
        [in,out]IVALSArray of single parameter values
        [in,out]J
        IWIDE1Bit width for value of descriptorE
        MSTACK
        LL
        JDESCError return: IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
        JDESC
         +

        Error return: IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8

        Author
        Bill Cavanaugh
        Date
        1988-09-01
        @@ -866,8 +867,8 @@

        -

        ◆ fi8805()

        + +

        ◆ fi8805()

        @@ -876,73 +877,73 @@

        subroutine fi8805 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(*)  - IWORK, + iwork, integer  - LX, + lx, integer  - LY, + ly, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer  - LL, + ll, integer, dimension(maxr)  - KNR, + knr, integer, dimension(2,maxd)  - MSTACK, + mstack,   - MAXR, + maxr,   - MAXD  + maxd  @@ -971,17 +972,17 @@

        MSGA LL KNR - MSTACKError return:
          + MSTACK + + + +

          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
          @@ -989,8 +990,8 @@

          -

          ◆ fi8806()

          + +

          ◆ fi8806()

          @@ -999,115 +1000,115 @@

          subroutine fi8806 ( integer, dimension(*)  - IPTR, + iptr, integer  - LX, + lx, integer  - LY, + ly, integer, dimension(*)  - IDENT, + ident, integer, dimension(*)  - MSGA, + msga, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IVALS, + ivals, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(*)  - IWIDE1, + iwide1, integer, dimension(3,*)  - IRFVL1, + irfvl1, integer, dimension(*)  - ISCAL1, + iscal1, integer  - J, + j, integer  - LL, + ll, integer, dimension(*)  - KFXY1, + kfxy1, integer, dimension(*)  - IWORK, + iwork, integer  - JDESC, + jdesc,   - MAXR, + maxr,   - MAXD, + maxd, integer, dimension(*)  - KPTRB  + kptrb  @@ -1146,10 +1147,11 @@

          KFXY1 IWORK JDESC - KPTRBError return: IPTR(1) = 5 - Erroneous x value in data descriptor operator + KPTRB +

          Error return: IPTR(1) = 5 - Erroneous x value in data descriptor operator

          Author
          Bill Cavanaugh
          Date
          1988-09-01
          @@ -1157,8 +1159,8 @@

          -

          ◆ fi8807()

          + +

          ◆ fi8807()

          @@ -1167,37 +1169,37 @@

          subroutine fi8807 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IWORK, + iwork, integer, dimension(20,*)  - ITBLD, + itbld, integer, dimension(20,*)  - ITBLD2, + itbld2, integer  - JDESC, + jdesc, integer, dimension(*)  - KPTRD  + kptrd  @@ -1232,8 +1234,8 @@

          -

          ◆ fi8808()

          + +

          ◆ fi8808()

          @@ -1242,37 +1244,37 @@

          subroutine fi8808 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IWORK, + iwork, integer  - LF, + lf, integer  - LX, + lx, integer  - LY, + ly, integer  - JDESC  + jdesc  @@ -1303,8 +1305,8 @@

          -

          ◆ fi8809()

          + +

          ◆ fi8809()

          @@ -1313,37 +1315,37 @@

          subroutine fi8809 ( integer, dimension(*)  - IDENT, + ident, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IPTR, + iptr,   - MAXR, + maxr,   - MAXD  + maxd  @@ -1395,8 +1397,8 @@

          -

          ◆ fi8810()

          + +

          ◆ fi8810()

          @@ -1405,37 +1407,37 @@

          subroutine fi8810 ( integer, dimension(*)  - IDENT, + ident, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(*)  - IPTR, + iptr,   - MAXR, + maxr,   - MAXD  + maxd  @@ -1488,8 +1490,8 @@

          -

          ◆ fi8811()

          + +

          ◆ fi8811()

          @@ -1498,55 +1500,55 @@

          subroutine fi8811 ( integer, dimension(*)  - IPTR, + iptr, integer, dimension(*)  - IDENT, + ident, integer, dimension(2,maxd)  - MSTACK, + mstack, integer, dimension(maxr,maxd)  - KDATA, + kdata, integer, dimension(maxr)  - KNR, + knr, integer, dimension(maxd)  - LDATA, + ldata, integer, dimension(2,maxd)  - LSTACK, + lstack,   - MAXD, + maxd,   - MAXR  + maxr  @@ -1572,13 +1574,13 @@

          [in,out]MSTACKList of descriptors and scale values KNR LDATA - LSTACKError return:
            -
          • IPTR(1)
            • -
          - + LSTACK +

          Error return:

            +
          • IPTR(1)
            • +
          Author
          Bill Cavanaugh
          Date
          1993-05-12
          @@ -1586,95 +1588,311 @@

          -

          ◆ w3fi88()

          + +

          ◆ fi8812()

          - + - + + + + + + + + + + + + + + + + + + + + + + + + + - + - + + + + + + + - + - - + + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          subroutine w3fi88 subroutine fi8812 ( integer, dimension(*) IPTR, iptr,
          integer iunitb,
          integer iunitd,
          integer, dimension(*) istack,
          integer nrdesc,
          integer, dimension(*) IDENT, kptrb,
          integer, dimension(*) MSGA, kptrd,
           irf1sw,
          integer, dimension(*) ISTACK, newref,
          integer, dimension(2,maxd) MSTACK, integer, dimension(20,*) itbld,
          integer, dimension(maxr,maxd) KDATA, integer, dimension(20,*) itbld2,
          integer, dimension(maxr) KNR, integer, dimension(*) kfxy1,
          character*40, dimension(*) aname1,
          character*24, dimension(*) aunit1,
          integer, dimension(*) iscal1,
          integer, dimension(3,*) irfvl1,
          integer, dimension(*) iwide1,
          integer, dimension(*) kfxy2,
          character*64, dimension(*) aname2,
          character*24, dimension(*) aunit2,
          integer, dimension(*) iscal2,
          integer, dimension(*) irfvl2,
          integer, dimension(*) iwide2 
          )
          +
          + +

          Definition at line 3311 of file w3fi88.f.

          + +
          +
          + +

          ◆ fi8813()

          + +
          +
          + + + + + + - + - - + + - + - - + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          subroutine fi8813 (integer, dimension(*) iptr,
          integer INDEX, maxr,
          integer, dimension(maxd) LDATA, integer maxd,
          integer, dimension(2,maxd) LSTACK, mstack,
           MAXR, integer, dimension(maxr,maxd) kdata,
           MAXD, integer, dimension(*) ident,
          integer, dimension(*) kptrd,
          integer, dimension(*) kptrb,
          integer, dimension(20,*) itbld,
          character*40, dimension(*) aname1,
          character*24, dimension(*) aunit1,
          integer, dimension(*) kfxy1,
          integer, dimension(*) iscal1,
          integer, dimension(*) irfvl1,
          integer, dimension(*) iwide1,
          integer iunitb 
          )
          +
          + +

          Definition at line 3467 of file w3fi88.f.

          + +
          +
          + +

          ◆ fi8814()

          + +
          +
          + + + + + + - + - + + + + + + + + + + + + + @@ -1684,44 +1902,446 @@

          -

          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.

          -

          subroutine fi8814 (character*64 ascchr,
           IUNITB, npos,
           IUNITD newval,
          integer ierr,
          integer, dimension(*) iptr 
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          subroutine fi8815 (integer, dimension(*) iptr,
          integer, dimension(*) ident,
          integer jdesc,
          integer, dimension(maxr,maxd) kdata,
          integer, dimension(*) kfxy3,
          integer maxr,
          integer maxd,
          character*64, dimension(*) aname3,
          character*24, dimension(*) aunit3,
          integer, dimension(*) iscal3,
          integer, dimension(*) irfvl3,
          integer, dimension(*) iwide3,
          integer keyset,
           ibflag,
           ierr 
          )
          +
          + +

          Definition at line 4076 of file w3fi88.f.

          + +
          +
          + +

          ◆ fi8818()

          + +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          subroutine fi8818 (integer, dimension(*) iptr,
          integer, dimension(*) kfxy1,
          character*40, dimension(*) aname1,
          character*24, dimension(*) aunit1,
          integer, dimension(*) iscal1,
          integer, dimension(3,*) irfvl1,
          integer, dimension(*) iwide1,
          integer, dimension(*) kfxy2,
          character*64, dimension(*) aname2,
          character*24, dimension(*) aunit2,
          integer, dimension(*) iscal2,
          integer, dimension(*) irfvl2,
          integer, dimension(*) iwide2,
          integer, dimension(*) kptrb 
          )
          +
          + +

          Definition at line 4286 of file w3fi88.f.

          + +
          +
          + +

          ◆ fi8819()

          + +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          subroutine fi8819 (integer, dimension(*) iptr,
          integer, dimension(20,*) itbld,
          integer, dimension(20,*) itbld2,
          integer, dimension(*) kptrd 
          )
          +
          + +

          Definition at line 4423 of file w3fi88.f.

          + +
          +
          + +

          ◆ fi8820()

          + +
          +
          + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
          subroutine fi8820 (integer, dimension(20,*) itbld,
           iunitd,
          integer, dimension(*) iptr,
          integer, dimension(20,*) itbld2,
          integer, dimension(*) kptrd 
          )
          +
          + +

          Definition at line 4486 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
          @@ -1849,19 +2469,19 @@

          [out]INDEXPointer to available subset KNR LDATA - LSTACK
          - Arrays containing data from table b new - base arrays containing data from table b
            + 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
            • @@ -1870,7 +2490,7 @@

          • 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
            • @@ -1879,7 +2499,7 @@

          • 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
            • @@ -1916,7 +2536,7 @@

            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
@@ -1946,7 +2566,7 @@ 
            
 
 
diff --git a/w3fi88_8f.js b/w3fi88_8f.js
index 9823edb1..edca6519 100644
--- a/w3fi88_8f.js
+++ b/w3fi88_8f.js
@@ -1,22 +1,15 @@
 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 ]
+    [ "fi8801", "w3fi88_8f.html#a2fed25546da8e6018a9a7ef4f84da0d4", null ],
+    [ "fi8802", "w3fi88_8f.html#af7dc9d23ed351c8f1e385475ca39c737", null ],
+    [ "fi8803", "w3fi88_8f.html#a32eb617143dc3a3b49a1bbfef5960ed5", null ],
+    [ "fi8804", "w3fi88_8f.html#a17cd06929f54d9886b5d2a4677fcf8e1", null ],
+    [ "fi8805", "w3fi88_8f.html#a7c494f653f8c6abcffaea6a5918163ab", null ],
+    [ "fi8806", "w3fi88_8f.html#a9a711b7afb78b8e4e813d29a6d00343e", null ],
+    [ "fi8807", "w3fi88_8f.html#a8962db3dac489d800d8fc9cc13a0641b", null ],
+    [ "fi8808", "w3fi88_8f.html#a157d9ffb48327791c26dc6ddac872eda", null ],
+    [ "fi8809", "w3fi88_8f.html#ada2a564df0576afd8796b682c9c50b73", null ],
+    [ "fi8810", "w3fi88_8f.html#ade4fae47f4dcc026b6ffb64e03f55651", null ],
+    [ "fi8811", "w3fi88_8f.html#a09e14e694efd5f48b403ec0dfff7f63c", null ],
+    [ "w3fi88", "w3fi88_8f.html#a597695a8a2eff93db31a2eb8d93ee8c9", null ]
 ];
\ No newline at end of file
diff --git a/w3fi88_8f_source.html b/w3fi88_8f_source.html
index 8f7db469..4d98eea5 100644
--- a/w3fi88_8f_source.html
+++ b/w3fi88_8f_source.html
@@ -1,9 +1,9 @@
 
-
+
 
 
-
-
+
+
 
 NCEPLIBS-w3emc: w3fi88.f Source File
 
@@ -23,10 +23,9 @@
 
            
 
- 
-  
+  
@@ -34,22 +33,28 @@
 
            
  
            
-   
            NCEPLIBS-w3emc
-    2.11.0
+ 
            
+   
            NCEPLIBS-w3emc 2.11.0
    
            
               		
  
            
 
            
 
-
+
 
 
 
 
+/* @license-end */
+
 
+
          @@ -76,4623 +81,4653 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fi88.f
          +
          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
          -
          gbyte
          subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
          This is the fortran version of gbyte.
          Definition: gbyte.f:27
          -
          gbytes
          subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
          Program history log:
          Definition: gbytes.f:26
          -
          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
          -
          w3fc05
          subroutine w3fc05(U, V, DIR, SPD)
          Given the true (Earth oriented) wind components compute the wind direction and speed.
          Definition: w3fc05.f:29
          -
          w3fi01
          subroutine w3fi01(LW)
          Determines the number of bytes in a full word for the particular machine (IBM or cray).
          Definition: w3fi01.f:19
          -
          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
          -
          fi8811
          subroutine fi8811(IPTR, IDENT, MSTACK, KDATA, KNR, LDATA, LSTACK, MAXD, MAXR)
          Expand data/descriptor replication.
          Definition: w3fi88.f:3249
          -
          fi8803
          subroutine fi8803(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, JDESC, MAXR, MAXD)
          Process compressed data.
          Definition: w3fi88.f:1414
          -
          fi8808
          subroutine fi8808(IPTR, IWORK, LF, LX, LY, JDESC)
          Program history log:
          Definition: w3fi88.f:2459
          -
          fi8809
          subroutine fi8809(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
          Reformat profiler w hgt increments.
          Definition: w3fi88.f:2517
          -
          fi8805
          subroutine fi8805(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
          Process a replication descriptor.
          Definition: w3fi88.f:1941
          -
          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
          -
          fi8807
          subroutine fi8807(IPTR, IWORK, ITBLD, ITBLD2, JDESC, KPTRD)
          Process queue descriptor.
          Definition: w3fi88.f:2372
          -
          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
          -
          fi8810
          subroutine fi8810(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
          Reformat profiler edition 2 data.
          Definition: w3fi88.f:2911
          -
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief BUFR message decoder
          +
          3C> @author Bill Cavanaugh @date 1988-08-31
          +
          4
          +
          5C> This set of routines will decode a bufr message and
          +
          6C> place information extracted from the bufr message into selected
          +
          7C> arrays for the user. the array kdata can now be sized by the user
          +
          8C> by indicating the maximum number of subsets and the maximum
          +
          9C> number of descriptors that are expected in the course of decoding
          +
          10C> selected input data. this allows for realistic sizing of kdata
          +
          11C> and the mstack arrays. this version also allows for the inclusion
          +
          12C> of the unit numbers for tables b and d into the
          +
          13C> argument list. this routine does not include ifod processing.
          +
          14C>
          +
          15C> Program history log:
          +
          16C> - Bill Cavanaugh 1988-08-31
          +
          17C> - Bill Cavanaugh 1990-12-07 Now Utilizing gbyte routines to gather
          +
          18C> and separate bit fields. this should improve
          +
          19C> (decrease) the time it takes to decode any
          +
          20C> bufr message. have entered coding that will
          +
          21C> permit processing bufr editions 1 and 2.
          +
          22C> improved and corrected the conversion into
          +
          23C> ifod format of decoded bufr messages.
          +
          24C> - Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle
          +
          25C> serial profiler data.
          +
          26C> - Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru
          +
          27C> descriptor 2 05 yyy.
          +
          28C> - Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data
          +
          29C> corrected. improved handling of nested
          +
          30C> queue descriptors is added.
          +
          31C> - Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8
          +
          32C> to better contain very large numbers more
          +
          33C> accurately. the preious size real*4 could not
          +
          34C> contain sufficient significant digits.
          +
          35C> coding has been introduced to process new
          +
          36C> table c descriptor 2 06 yyy which permits in
          +
          37C> line processing of a local descriptor even if
          +
          38C> the descriptor is not contained in the users
          +
          39C> table b.
          +
          40C> a second routine to process ifod messages
          +
          41C> (ifod0) has been removed in favor of the
          +
          42C> improved processing of the one
          +
          43C> remaining (ifod1).
          +
          44C> new coding has been introduced to permit
          +
          45C> processing of bufr messages based on bufr
          +
          46C> edition up to and including edition 2.
          +
          47C> please note increased size requirements
          +
          48C> for arrays ident(20) and iptr(40).
          +
          49C> - Bill Cavanaugh 1991-07-26 Add Array mtime to calling sequence to
          +
          50C> permit inclusion of receipt/transfer times
          +
          51C> to ifod messages.
          +
          52C> - Bill Cavanaugh 1991-09-25 All processing of decoded bufr data into
          +
          53C> ifod (a local use reformat of bufr data)
          +
          54C> has been isolated from this set of routines.
          +
          55C> for those interested in the ifod form,
          +
          56C> see w3fl05 in the w3lib routines.
          +
          57C> processing of bufr messages containing
          +
          58C> delayed replication has been altered so that
          +
          59C> single subsets (reports) and and a matching
          +
          60C> descriptor list for that particular subset
          +
          61C> will be passed to the user will be passed to
          +
          62C> the user one at a time to assure that each
          +
          63C> subset can be fully defined with a minimum
          +
          64C> of reprocessing.
          +
          65C> processing of associated fields has been
          +
          66C> tested with messages containing non-compressed
          +
          67C> data.
          +
          68C> in order to facilitate user processing
          +
          69C> a matching list of scale factors are included
          +
          70C> with the expanded descriptor list (mstack).
          +
          71C> - Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy
          +
          72C> has corrected to agree with fm94 standards.
          +
          73C> - Bill Cavanaugh 1991-12-19 Calls to fi8803 and fi8804 have been
          +
          74C> corrected to agree called program argument
          +
          75C> list. some additional entries have been
          +
          76C> included for communicating with data access
          +
          77C> routines. additional error exit provided for
          +
          78C> the case where table b is damaged.
          +
          79C> - Bill Cavanaugh 1992-01-24 Routines fi8801, fi8803 and fi8804
          +
          80C> have been modified to handle associated fields
          +
          81C> all descriptors are set to echo to mstack(1,n)
          +
          82C> - Bill Cavanaugh 1992-05-21 Further expansion of information collected
          +
          83C> from within upper air soundings has produced
          +
          84C> the necessity to expand some of the processing
          +
          85C> and output arrays. (see remarks below)
          +
          86C> corrected descriptor denoting height of
          +
          87C> each wind level for profiler conversions.
          +
          88C> - Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment
          +
          89C> of arrays to contain table b values needed to
          +
          90C> assist in the decoding process.
          +
          91C> arrays containing data from table b
          +
          92C> - KFXY1 Descriptor
          +
          93C> - ANAME1 Descriptor name
          +
          94C> - AUNIT1 Units for descriptor
          +
          95C> - ISCAL1 Scale for value of descriptor
          +
          96C> - IRFVL1 Reference value for descriptor
          +
          97C> - IWIDE1 Bit width for value of descriptor
          +
          98C> - Bill Cavanaugh 1992-09-09 First encounter with operator descriptor
          +
          99C> 2 05 yyy showed error in decoding. that error
          +
          100C> is corrected with this implementation. further
          +
          101C> testing of upper air data has encountered
          +
          102C> the condition of large (many level) soundings
          +
          103C> arrays in the decoder have been expanded (again)
          +
          104C> to allow for this condition.
          +
          105C> - Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data
          +
          106C> (fi8809) to show descriptors, scale value and
          +
          107C> data in proper order. corrected an error that
          +
          108C> prevented user from assigning the second dimension
          +
          109C> of kdata(500,*).
          +
          110C> - Bill Cavanaugh 1992-10-20 Removed error that prevented full
          +
          111C> implementation of previous corrections and
          +
          112C> made corrections to table b to bring it up to
          +
          113C> date. changes include proper reformat of profiler
          +
          114C> data and user capability for assigning second
          +
          115C> dimension of kdata array.
          +
          116C> - Bill Cavanaugh 1992-12-09 Thanks to dennis keyser for the suggestions
          +
          117C> and coding, this implementation will allow the
          +
          118C> inclusion of unit numbers for tables b & d, and
          +
          119C> in addition allows for realistic sizing of kdata
          +
          120C> and mstack arrays by the user. as of this
          +
          121C> implementation, the upper size limit for a bufr
          +
          122C> message allows for a message size greater than
          +
          123C> 15000 bytes.
          +
          124C> - Bill Cavanaugh 1993-01-26 Routine fi8810 has been added to permit
          +
          125C> reformatting of profiler data in edition 2.
          +
          126C> - Bill Cavanaugh 1993-05-13 Routine fi8811 has been added to permit
          +
          127C> processing of run-line encoding. this provides for
          +
          128C> the handling of data for graphics products.
          +
          129C> please note the addition of two arguments in the
          +
          130C> calling sequence.
          +
          131C> - Bill Cavanaugh 1993-12-01 Routine fi8803 to correct handling of
          +
          132C> associated fields and arrays associated with
          +
          133C> table b entries enlarged to handle larger table b
          +
          134C> - Bill Cavanaugh 1994-05-25 Routines have been modified to construct a
          +
          135C> modified table b i.e., it is tailored to contain o
          +
          136C> those descriptors that will be used to decode
          +
          137C> data in current and subsequent bufr messages.
          +
          138C> table b and table d descriptors will be isolated
          +
          139C> and merged with the main tables for use with
          +
          140C> following bufr messages.
          +
          141C> the descriptors indicating the replication of
          +
          142C> descriptors and data are activated with this
          +
          143C> implementation.
          +
          144C> - Bill Cavanaugh 1994-08-30 Added statements that will allow use of
          +
          145C> these routines directly on the cray with no
          +
          146C> modification. handling od table d entries has been
          +
          147C> modified to prevent loss of ancillary entries.
          +
          148C> coding has been added to allow processing on
          +
          149C> either an 8 byte word or 4 byte word machine.
          +
          150C>
          +
          151C> For those users of the bufr decoder that are
          +
          152C> processing sets of bufr messages that include
          +
          153C> type 11 messages, coding has been added to allow
          +
          154C> the recovery of the added or modified table b
          +
          155C> entries by writing them to a disk file available
          +
          156C> to the user. this is accomplished with no change
          +
          157C> to the calling sequence. table b entries will be
          +
          158C> designated as follows:
          +
          159C> IUNITB - Is the unit number for the master table b.
          +
          160C> IUNITB+1 - Will be the unit number for the table b entries that are to be used
          +
          161C> in the decoding of subsequent messages. this device will be formatted the same
          +
          162C> the disk file on iunitb.
          +
          163C>
          +
          164C> - Dennis Keyser 1995-06-07 Corrected an error which required input
          +
          165C> argument "maxd" to be nearly twice as large as
          +
          166C> needed for decoding wind profiler reports (limit
          +
          167C> upper bound for "iwork" array was set to "maxd",
          +
          168C> now it is set to 15000). also, a correction was
          +
          169C> made in the wind profiler processing to prevent
          +
          170C> unnecessary looping when all requested
          +
          171C> descriptors are missing. also corrected an
          +
          172C> error which resulted in returned scale in
          +
          173C> "mstack(2, ..)" always being set to zero for
          +
          174C> compressed data.
          +
          175C> - Bill Cavanaugh 1996-02-15 Modified identification of ascii/ebcdic
          +
          176C> machine. modified handling of table b to permit
          +
          177C> faster processing of multiple messages with
          +
          178C> changing data types and/or subtypes.
          +
          179C> - Bill Cavanaugh 1996-04-02 Deactivated extraneous write statement.
          +
          180C> enlarged arrays for table b entries to contain
          +
          181C> up to 1300 entries in preparation for new
          +
          182C> additions to table b.
          +
          183C> - Dennis Keyser 2001-02-01 The table b file will now be read whenever the
          +
          184C> input argument "iunitb" (table b unit number)
          +
          185C> changes from its value in the previous call to
          +
          186C> this routine (normally it is only read the
          +
          187C> first time this routine is called)
          +
          188C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
          +
          189C>
          +
          190C> @param[in] MSGA Array containing supposed bufr message
          +
          191C> size is determined by user, can be greater
          +
          192C> than 15000 bytes.
          +
          193C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          194C> contained in a bufr message
          +
          195C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          196C> may be processed; upper air data and some satellite
          +
          197C> data require a value for maxd of 1700, but for most
          +
          198C> other data a value for maxd of 500 will suffice
          +
          199C> @param[in] IUNITB Unit number of data set holding table b, this is the
          +
          200C> number of a pair of data sets
          +
          201C> -IUNITB+Unit number for a dataset to contain table b entries
          +
          202C> from master table b and table b entries extracted
          +
          203C> from type 11 bufr messages that were used to decode
          +
          204C> current bufr messages.
          +
          205C> @param[in] IUNITD Unit number of data set holding tab
          +
          206C> @param[out] ISTACK Original array of descriptors extracted from
          +
          207C> source bufr message.
          +
          208C> @param[out] MSTACK (A,B)-LEVEL B Descriptor number (limited to value of
          +
          209C> input argument maxd)
          +
          210C> - Level A:
          +
          211C> - = 1 Descriptor
          +
          212C> - = 2 10**N scaling to return to original value
          +
          213C> @param[out] IPTR Utility array (should have at last 42 entries)
          +
          214C> - IPTR(1)- Error return
          +
          215C> - IPTR(2)- Byte count section 1
          +
          216C> - IPTR(3)- Pointer to start of section 1
          +
          217C> - IPTR(4)- Byte count section 2
          +
          218C> - IPTR(5)- Pointer to start of section 2
          +
          219C> - IPTR(6)- Byte count section 3
          +
          220C> - IPTR(7)- Pointer to start of section 3
          +
          221C> - IPTR(8)- Byte count section 4
          +
          222C> - IPTR(9)- Pointer to start of section 4
          +
          223C> - IPTR(10)- Start of requested subset, reserved for dar
          +
          224C> - IPTR(11)- Current descriptor ptr in iwork
          +
          225C> - IPTR(12)- Last descriptor pos in iwork
          +
          226C> - IPTR(13)- Last descriptor pos in istack
          +
          227C> - IPTR(14)- Number of master table b entries
          +
          228C> - IPTR(15)- Requested subset pointer, reserved for dar
          +
          229C> - IPTR(16)- Indicator for existance of section 2
          +
          230C> - IPTR(17)- Number of reports processed
          +
          231C> - IPTR(18)- Ascii/text event
          +
          232C> - IPTR(19)- Pointer to start of bufr message
          +
          233C> - IPTR(20)- Number of entries from table d
          +
          234C> - IPTR(21)- Nr table b entries
          +
          235C> - IPTR(22)- Nr table b entries from current message
          +
          236C> - IPTR(23)- Code/flag table switch
          +
          237C> - IPTR(24)- Aditional words added by text info
          +
          238C> - IPTR(25)- Current bit number
          +
          239C> - IPTR(26)- Data width change - add to table b width
          +
          240C> - IPTR(27)- Data scale change - modifies table b scale
          +
          241C> - IPTR(28)- Data reference value change - ?????????
          +
          242C> - IPTR(29)- Add data associated field
          +
          243C> - IPTR(30)- Signify characters
          +
          244C> - IPTR(31)- Number of expanded descriptors in mstack
          +
          245C> - IPTR(32)- Current descriptor segment f
          +
          246C> - IPTR(33)- Current descriptor segment x
          +
          247C> - IPTR(34)- Current descriptor segment y
          +
          248C> - IPTR(35)- Data/descriptor replication in progress
          +
          249C> - 0 = No
          +
          250C> - 1 = Yes
          +
          251C> - IPTR(36)- Next descriptor may be undecipherable
          +
          252C> - IPTR(37)- Machine text type flag
          +
          253C> - 0 = EBCIDIC
          +
          254C> - 1 = ASCII
          +
          255C> - IPTR(38)- Data/descriptor replication flag
          +
          256C> - 0 - Does not exist in current message
          +
          257C> - 1 - Exists in current message
          +
          258C> - IPTR(39)- Delayed replication flag
          +
          259C> - 0 - No delayed replication
          +
          260C> - 1 - Message contains delayed replication
          +
          261C> - IPTR(40)- Number of characters in text for curr descriptor
          +
          262C> - IPTR(41)- Number of ancillary table b entries
          +
          263C> - IPTR(42)- Number of ancillary table d entries
          +
          264C> - IPTR(43)- Number of added table b entries encountered while
          +
          265C> processing a bufr message. these entries only
          +
          266C> exist durng processing of current bufr message
          +
          267C> IPTR(44)- Bits per word
          +
          268C> IPTR(45)- Bytes per word
          +
          269C> @param[out] IDENT Array contains message information extracted from BUFR message:
          +
          270C> - IDENT(1) - Edition number (byte 4, section 1)
          +
          271C> - IDENT(2) - Originating center (bytes 5-6, section 1)
          +
          272C> - IDENT(3) - Update sequence (byte 7, section 1)
          +
          273C> - IDENT(4) - Optional section (byte 8, section 1)
          +
          274C> - IDENT(5) - Bufr message type (byte 9, section 1)
          +
          275C> - 0 = Surface data (land)
          +
          276C> - 1 = Surface data (ship)
          +
          277C> - 2 = Vertical soundings (other than satellite)
          +
          278C> - 3 = Vertical soundings (satellite)
          +
          279C> - 4 = Single lvl upper-air data(other than satellite)
          +
          280C> - 5 = Single level upper-air data (satellite)
          +
          281C> - 6 = Radar data
          +
          282C> - 7 = Synoptic features
          +
          283C> - 8 = Physical/chemical constituents
          +
          284C> - 9 = Dispersal and transport
          +
          285C> - 10 = Radiological data
          +
          286C> - 11 = Bufr tables (complete, replacement or update)
          +
          287C> - 12 = Surface data (satellite)
          +
          288C> - 21 = Radiances (satellite measured)
          +
          289C> - 31 = Oceanographic data
          +
          290C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
          +
          291C> | TYPE | SBTYP |
          +
          292C> | :--- | :---- |
          +
          293C> | 2 | 7 = PROFILER |
          +
          294C> - IDENT(7) - (bytes 11-12, section 1)
          +
          295C> - IDENT(8) - Year of century (byte 13, section 1)
          +
          296C> - IDENT(9) - Month of year (byte 14, section 1)
          +
          297C> - IDENT(10) - Day of month (byte 15, section 1)
          +
          298C> - IDENT(11) - Hour of day (byte 16, section 1)
          +
          299C> - IDENT(12) - Minute of hour (byte 17, section 1)
          +
          300C> - IDENT(13) - Rsvd by adp centers(byte 18, section 1)
          +
          301C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
          +
          302C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
          +
          303C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
          +
          304C> - IDENT(17) - Master table number(byte 4, section 1, ed 2 or gtr)
          +
          305C> @param[out] KDATA Array containing decoded reports from bufr message.
          +
          306C> KDATA(Report number,parameter number)
          +
          307C> (Report number limited to value of input argument
          +
          308C> maxr and parameter number limited to value of input
          +
          309C> argument maxd)
          +
          310C> @param[out] INDEX Pointer to available subset
          +
          311C> @param KNR
          +
          312C> @param LDATA
          +
          313C> @param LSTACK
          +
          314C>
          +
          315C> ===========================================================
          +
          316C> Arrays containing data from table b
          +
          317C> new - base arrays containing data from table b
          +
          318C> - KFXY1 - Decimal descriptor value of f x y values
          +
          319C> - ANAME1 - Descriptor name
          +
          320C> - AUNIT1 - Units for descriptor
          +
          321C> - ISCAL1 - Scale for value of descriptor
          +
          322C> - IRFVL1 - Reference value for descriptor
          +
          323C> - IWIDE1 - Bit width for value of descriptor
          +
          324C> ===========================================================
          +
          325C> New - ancillary arrays containing data from table b
          +
          326C> containing table b entries extracted
          +
          327C> from type 11 bufr messages
          +
          328C> - KFXY2 - Decimal descriptor value of f x y values
          +
          329C> - ANAME2 - Descriptor name
          +
          330C> - AUNIT2 - Units for descriptor
          +
          331C> - ISCAL2 - Scale for value of descriptor
          +
          332C> - IRFVL2 - Reference value for descriptor
          +
          333C> - IWIDE2 - Bit width for value of descriptor
          +
          334C> ===========================================================
          +
          335C> New - added arrays containing data from table b
          +
          336C> containing table b entries extracted
          +
          337C> from non-type 11 bufr messages
          +
          338C> these exist for the life of current bufr message
          +
          339C> - KFXY3 - Decimal descriptor value of f x y values
          +
          340C> - ANAME3 - Descriptor name
          +
          341C> - AUNIT3 - Units for descriptor
          +
          342C> - ISCAL3 - Scale for value of descriptor
          +
          343C> - IRFVL3 - Reference value for descriptor
          +
          344C> - IWIDE3 - Bit width for value of descriptor
          +
          345C> ===========================================================
          +
          346C>
          +
          347C> Error returns:
          +
          348C> IPTR(1)
          +
          349C> - = 1 'BUFR' Not found in first 125 characters
          +
          350C> - = 2 '7777' Not found in location determined by
          +
          351C> by using counts found in each section. one or
          +
          352C> more sections have an erroneous byte count or
          +
          353C> characters '7777' are not in test message.
          +
          354C> - = 3 Message contains a descriptor with f=0 that does
          +
          355C> not exist in table b.
          +
          356C> - = 4 Message contains a descriptor with f=3 that does
          +
          357C> not exist in table d.
          +
          358C> - = 5 Message contains a descriptor with f=2 with the
          +
          359C> value of x outside the range 1-6.
          +
          360C> - = 6 Descriptor element indicated to have a flag value
          +
          361C> does not have an entry in the flag table.
          +
          362C> (to be activated)
          +
          363C> - = 7 Descriptor indicated to have a code value does
          +
          364C> not have an entry in the code table.
          +
          365C> (to be activated)
          +
          366C> - = 8 Error reading table d
          +
          367C> - = 9 Error reading table b
          +
          368C> - = 10 Error reading code/flag table
          +
          369C> - = 11 Descriptor 2 04 004 not followed by 0 31 021
          +
          370C> - = 12 Data descriptor operator qualifier does not follow
          +
          371C> delayed replication descriptor.
          +
          372C> - = 13 Bit width on ascii characters not a multiple of 8
          +
          373C> - = 14 Subsets = 0, no content bulletin
          +
          374C> - = 20 Exceeded count for delayed replication pass
          +
          375C> - = 21 Exceeded count for non-delayed replication pass
          +
          376C> - = 22 Exceeded combined bit width, bit width > 32
          +
          377C> - = 23 No element descriptors following 2 03 yyy
          +
          378C> - = 27 Non zero lowest on text data
          +
          379C> - = 28 Nbinc not nr of characters
          +
          380C> - = 29 Table b appears to be damaged
          +
          381C> - = 30 Table d entry with more than 18 in sequence
          +
          382C> being entered from type 11 message
          +
          383C> - = 99 No more subsets (reports) available in current
          +
          384C> bufr mesage
          +
          385C> - = 400 Number of subsets exceeds the value of input
          +
          386C> argument maxr; must increase maxr to value of
          +
          387C> ident(14) in calling program
          +
          388C> - = 401 Number of parameters (and associated fields)
          +
          389C> exceeds limits of this program.
          +
          390C> - = 500 Value for nbinc has been found that exceeds
          +
          391C> standard width plus any bit width change.
          +
          392C> check all bit widths up to point of error.
          +
          393C> - = 501 Corrected width for descriptor is 0 or less
          +
          394C> - = 888 Non-numeric character in conversion request
          +
          395C> - = 890 Class 0 element descriptor w/width of 0
          +
          396C>
          +
          397C> On the initial call to w3fi88 with a bufr message the argument
          +
          398C> index must be set to zero (index = 0). on the return from w3fi88
          +
          399C> 'index' will be set to the next available subset/report. when
          +
          400C> there are no more subsets available a 99 err return will occur.
          +
          401C>
          +
          402C> If the original bufr message does not contain delayed replication
          +
          403C> the bufr message will be completely decoded and 'index' will point
          +
          404C> to the first decoded subset. the users will then have the option
          +
          405C> of indexing through the subsets on their own or by recalling this
          +
          406C> routine (without resetting 'index') to have the routine do the
          +
          407C> indexing.
          +
          408C>
          +
          409C> If the original bufr message does contain delayed replication
          +
          410C> one subset/report will be decoded at a time and passed back to
          +
          411C> the user. this is not an option.
          +
          412C>
          +
          413C> =============================================
          +
          414C> To use this routine
          +
          415C> =============================================
          +
          416C> the arrays to contain the output information are defined
          +
          417C> as follows:
          +
          418C>
          +
          419C> KDATA(A,B) is the a data entry (integer value)
          +
          420C> where a is the maximum number of reports/subsets
          +
          421C> that may be contained in the bufr message (this
          +
          422C> is now set to "maxr" which is passed as an input
          +
          423C> argument to w3fi88), and where b is the maximum
          +
          424C> number of descriptor combinations that may
          +
          425C> be processed (this is now set to "maxd" which
          +
          426C> is also passed as an input argument to w3fi88;
          +
          427C> upper air data and some satellite data require
          +
          428C> a value for maxd of 1700, but for most other
          +
          429C> data a value for maxd of 500 will suffice)
          +
          430C> MSTACK(1,B) contains the descriptor that matches the
          +
          431C> data entry (max. value for b is now "maxd"
          +
          432C> which is passed as an input argument to w3fi88)
          +
          433C> MSTACK(2,B) is the scale (power of 10) to be applied to
          +
          434C> the data (max. value for b is now "maxd"
          +
          435C> which is passed as an input argument to w3fi88)
          +
          436C>
          +
          +
          437 SUBROUTINE w3fi88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
          +
          438 * LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
          +
          439C
          +
          440C
          +
          441C
          +
          442C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH
          +
          443C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR
          +
          444C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL
          +
          445C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE
          +
          446C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED.
          +
          447C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE
          +
          448C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF
          +
          449C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE
          +
          450C MESSAGE.
          +
          451C
          +
          452 INTEGER LDATA(MAXD)
          +
          453 INTEGER LSTACK(2,MAXD)
          +
          454C
          +
          455 INTEGER MSGA(*)
          +
          456 INTEGER IPTR(*),KPTRB(16384),KPTRD(16384)
          +
          457 INTEGER KDATA(MAXR,MAXD)
          +
          458 INTEGER MSTACK(2,MAXD)
          +
          459C
          +
          460 INTEGER IVALS(1000)
          +
          461 INTEGER KNR(MAXR)
          +
          462 INTEGER IDENT(*)
          +
          463 INTEGER ISTACK(*),IOLD11
          +
          464cdak KEYSER fix 02/02/2001 VVVVV
          +
          465 INTEGER IOLDTB
          +
          466cdak KEYSER fix 02/02/2001 AAAAA
          +
          467 INTEGER IWORK(15000)
          +
          468 INTEGER INDEX
          +
          469C
          +
          470 INTEGER IIII
          +
          471 CHARACTER*1 BLANK
          +
          472 CHARACTER*4 DIRID(2)
          +
          473C
          +
          474 LOGICAL SEC2
          +
          475C ..................................................
          +
          476C
          +
          477C NEW BASE TABLE B
          +
          478C MAY BE A COMBINATION OF MASTER TABLE B
          +
          479C AND ANCILLARY TABLE B
          +
          480C
          +
          481 INTEGER KFXY1(1300),ISCAL1(1300)
          +
          482 INTEGER IRFVL1(3,1300),IWIDE1(1300)
          +
          483 CHARACTER*40 ANAME1(1300)
          +
          484 CHARACTER*24 AUNIT1(1300)
          +
          485C ..................................................
          +
          486C
          +
          487C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
          +
          488C
          +
          489 INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200)
          +
          490 CHARACTER*64 ANAME2(200)
          +
          491 CHARACTER*24 AUNIT2(200)
          +
          492C ..................................................
          +
          493C
          +
          494C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
          +
          495C
          +
          496C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
          +
          497C CHARACTER*64 ANAME3(200)
          +
          498C CHARACTER*24 AUNIT3(200)
          +
          499C ..................................................
          +
          500C
          +
          501C NEW BASE TABLE D
          +
          502C
          +
          503 INTEGER ITBLD(20,400)
          +
          504C ..................................................
          +
          505C
          +
          506C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
          +
          507C
          +
          508 INTEGER ITBLD2(20,50)
          +
          509C ..................................................
          +
          510C
          +
          511 SAVE
          +
          512
          +
          513cdak KEYSER fix 02/02/2001 VVVVV
          +
          514 DATA iold11/0/
          +
          515 DATA ioldtb/-99/
          +
          516cdak KEYSER fix 02/02/2001 AAAAA
          +
          517C
          +
          518 CALL w3fi01(lw)
          +
          519 iptr(45) = lw
          +
          520 iptr(44) = lw * 8
          +
          521C
          +
          522 blank = ' '
          +
          523 IF (mova2i(blank).EQ.32) THEN
          +
          524 iptr(37) = 1
          +
          525C PRINT *,'ASCII MACHINE'
          +
          526 ELSE
          +
          527 iptr(37) = 0
          +
          528C PRINT *,'EBCDIC MACHINE'
          +
          529 END IF
          +
          530C
          +
          531C PRINT *,' W3FI88 DECODER'
          +
          532C INITIALIZE ERROR RETURN
          +
          533 iptr(1) = 0
          +
          534 IF (index.GT.0) THEN
          +
          535C HAVE RE-ENTRY
          +
          536 index = index + 1
          +
          537C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
          +
          538 IF (index.GT.ident(14)) THEN
          +
          539C 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)
          +
          555C
          +
          556 END IF
          +
          557 END IF
          +
          558 RETURN
          +
          559 ELSE
          +
          560 index = 1
          +
          561C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
          +
          562 END IF
          +
          563 iptr(39) = 0
          +
          564C 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
          +
          573C 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
          +
          584C TEST FOR EDITION NUMBER
          +
          585C ======================
          +
          586 CALL gbyte (msga,ident(1),inofst+24,8)
          +
          587C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
          +
          588C
          +
          589 IF (ident(1).GE.2) THEN
          +
          590C 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)
          +
          595C IF (ILAST.EQ.926365495) THEN
          +
          596C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
          +
          597C END IF
          +
          598 inofst = inofst + 32
          +
          599C GET SECTION 1 COUNT
          +
          600 iptr(3) = inofst
          +
          601 CALL gbyte (msga,ivals,inofst,24)
          +
          602C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
          +
          603 inofst = inofst + 24
          +
          604 iptr( 2) = ivals(1)
          +
          605C GET MASTER TABLE
          +
          606 CALL gbyte (msga,ivals,inofst,8)
          +
          607 inofst = inofst + 8
          +
          608 ident(17) = ivals(1)
          +
          609C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
          +
          610 ELSE
          +
          611 iptr(3) = inofst
          +
          612C GET SECTION 1 COUNT
          +
          613 CALL gbyte (msga,ivals,inofst,24)
          +
          614C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
          +
          615 inofst = inofst + 32
          +
          616 iptr( 2) = ivals(1)
          +
          617 END IF
          +
          618C ======================
          +
          619C ORIGINATING CENTER
          +
          620 CALL gbyte (msga,ivals,inofst,16)
          +
          621 inofst = inofst + 16
          +
          622 ident(2) = ivals(1)
          +
          623C UPDATE SEQUENCE
          +
          624 CALL gbyte (msga,ivals,inofst,8)
          +
          625 inofst = inofst + 8
          +
          626 ident(3) = ivals(1)
          +
          627C 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
          +
          633C PRINT *,' NO OPTIONAL SECTION 2'
          +
          634 sec2 = .false.
          +
          635 END IF
          +
          636 inofst = inofst + 8
          +
          637C MESSAGE TYPE
          +
          638 CALL gbyte (msga,ivals,inofst,8)
          +
          639 ident(5) = ivals(1)
          +
          640 inofst = inofst + 8
          +
          641C MESSAGE SUBTYPE
          +
          642 CALL gbyte (msga,ivals,inofst,8)
          +
          643 ident(6) = ivals(1)
          +
          644 inofst = inofst + 8
          +
          645cdak KEYSER fix 02/02/2001 VVVVV
          +
          646 IF (iunitb.NE.ioldtb) THEN
          +
          647C 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
          +
          653cdak KEYSER fix 02/02/2001 AAAAA
          +
          654C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B
          +
          655 IF (iold11.EQ.11) THEN
          +
          656 iold11 = ident(5)
          +
          657 ioldsb = ident(6)
          +
          658C 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
          +
          667C IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B
          +
          668 IF (ioldsb.NE.ident(6)) THEN
          +
          669 ioldsb = ident(6)
          +
          670 iptr(21) = 0
          +
          671C ELSE IF
          +
          672 END IF
          +
          673 END IF
          +
          674 END IF
          +
          675C IF BUFR EDITION 0 OR 1 THEN
          +
          676C NEXT 2 BYTES ARE BUFR TABLE VERSION
          +
          677C ELSE
          +
          678C BYTE 11 IS VER NR OF MASTER TABLE
          +
          679C 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
          +
          685C BYTE 11 IS VER NR OF MASTER TABLE
          +
          686 CALL gbyte (msga,ivals,inofst,8)
          +
          687 ident(18) = ivals(1)
          +
          688 inofst = inofst + 8
          +
          689C 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
          +
          695C YEAR OF CENTURY
          +
          696 CALL gbyte (msga,ivals,inofst,8)
          +
          697 ident(8) = ivals(1)
          +
          698 inofst = inofst + 8
          +
          699C MONTH
          +
          700 CALL gbyte (msga,ivals,inofst,8)
          +
          701 ident(9) = ivals(1)
          +
          702 inofst = inofst + 8
          +
          703C DAY
          +
          704C PRINT *,'DAY AT ',INOFST
          +
          705 CALL gbyte (msga,ivals,inofst,8)
          +
          706 ident(10) = ivals(1)
          +
          707 inofst = inofst + 8
          +
          708C HOUR
          +
          709 CALL gbyte (msga,ivals,inofst,8)
          +
          710 ident(11) = ivals(1)
          +
          711 inofst = inofst + 8
          +
          712C MINUTE
          +
          713 CALL gbyte (msga,ivals,inofst,8)
          +
          714 ident(12) = ivals(1)
          +
          715C RESET POINTER (INOFST) TO START OF
          +
          716C NEXT SECTION
          +
          717C (SECTION 2 OR SECTION 3)
          +
          718 inofst = iptr(3) + iptr(2) * 8
          +
          719 iptr(4) = 0
          +
          720 iptr(5) = inofst
          +
          721 IF (sec2) THEN
          +
          722C SECTION 2 COUNT
          +
          723 CALL gbyte (msga,iptr(4),inofst,24)
          +
          724 inofst = inofst + 32
          +
          725C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
          +
          726 kentry = (iptr(4) - 4) / 14
          +
          727C 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
          +
          742C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
          +
          743 2000 CONTINUE
          +
          744 END IF
          +
          745C RESET POINTER (INOFST) TO START OF
          +
          746C SECTION 3
          +
          747 inofst = iptr(5) + iptr(4) * 8
          +
          748 END IF
          +
          749C BIT OFFSET TO START OF SECTION 3
          +
          750 iptr( 7) = inofst
          +
          751C SECTION 3 COUNT
          +
          752 CALL gbyte (msga,iptr(6),inofst,24)
          +
          753C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
          +
          754 inofst = inofst + 24
          +
          755C SKIP RESERVED BYTE
          +
          756 inofst = inofst + 8
          +
          757C NUMBER OF DATA SUBSETS
          +
          758 CALL gbyte (msga,ident(14),inofst,16)
          +
          759C
          +
          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'
          +
          765C
          +
          766 iptr(1) = 400
          +
          767 RETURN
          +
          768 END IF
          +
          769 inofst = inofst + 16
          +
          770C OBSERVED DATA FLAG
          +
          771 CALL gbyte (msga,ivals,inofst,1)
          +
          772 ident(15) = ivals(1)
          +
          773 inofst = inofst + 1
          +
          774C COMPRESSED DATA FLAG
          +
          775 CALL gbyte (msga,ivals,inofst,1)
          +
          776 ident(16) = ivals(1)
          +
          777 inofst = inofst + 7
          +
          778C CALCULATE NUMBER OF DESCRIPTORS
          +
          779 nrdesc = (iptr( 6) - 8) / 2
          +
          780 iptr(12) = nrdesc
          +
          781 iptr(13) = nrdesc
          +
          782C EXTRACT DESCRIPTORS
          +
          783 CALL gbytes (msga,istack,inofst,16,0,nrdesc)
          +
          784C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
          +
          785 DO 10 l = 1, nrdesc
          +
          786 iwork(l) = istack(l)
          +
          787C PRINT *,L,ISTACK(L)
          +
          788 10 CONTINUE
          +
          789 iptr(13) = nrdesc
          +
          790C ===============================================================
          +
          791C
          +
          792C CONSTRUCT A TABLE B TO MATCH THE
          +
          793C LIST OF DESCRIPTORS FOR THIS MESSAGE
          +
          794C
          +
          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
          +
          802C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE'
          +
          803 IF (iptr(41).NE.0) THEN
          +
          804C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B'
          +
          805C CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
          +
          806C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
          +
          807 END IF
          +
          808 END IF
          +
          809 IF (iptr(1).NE.0) RETURN
          +
          810C ================================================================
          +
          811C RESET POINTER TO START OF SECTION 4
          +
          812 inofst = iptr(7) + iptr(6) * 8
          +
          813C BIT OFFSET TO START OF SECTION 4
          +
          814 iptr( 9) = inofst
          +
          815C SECTION 4 COUNT
          +
          816 CALL gbyte (msga,ivals,inofst,24)
          +
          817C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
          +
          818 iptr( 8) = ivals(1)
          +
          819 inofst = inofst + 32
          +
          820C SET FOR STARTING BIT OF DATA
          +
          821 iptr(25) = inofst
          +
          822C FIND OUT IF '7777' TERMINATOR IS THERE
          +
          823 inofst = iptr(9) + iptr(8) * 8
          +
          824 CALL gbyte (msga,ivals,inofst,32)
          +
          825C 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
          +
          833C
          +
          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)
          +
          840C
          +
          841C PRINT *,'HAVE RETURNED FROM FI8801'
          +
          842 IF (iptr(1).NE.0) THEN
          +
          843 RETURN
          +
          844 END IF
          +
          845C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
          +
          846 IF (ident(5).EQ.2) THEN
          +
          847 IF (ident(6).EQ.7) THEN
          +
          848C PRINT *,'REFORMAT PROFILER DATA'
          +
          849C
          +
          850C DO 7151 I = 1, 40
          +
          851C IF (I.LE.20) THEN
          +
          852C PRINT *,'IPTR(',I,')=',IPTR(I),
          +
          853C * ' IDENT(',I,')= ',IDENT(I)
          +
          854C ELSE
          +
          855C PRINT *,'IPTR(',I,')=',IPTR(I)
          +
          856C END IF
          +
          857C7151 CONTINUE
          +
          858C DO 152 I = 1, IPTR(31)
          +
          859C PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5)
          +
          860C 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
          +
          866C DO 151 I = 1, 40
          +
          867C IF (I.LE.20) THEN
          +
          868C PRINT *,'IPTR(',I,')=',IPTR(I),
          +
          869C * ' IDENT(',I,')= ',IDENT(I)
          +
          870C ELSE
          +
          871C PRINT *,'IPTR(',I,')=',IPTR(I)
          +
          872C END IF
          +
          873C 151 CONTINUE
          +
          874 IF (iptr(1).NE.0) THEN
          +
          875 RETURN
          +
          876 END IF
          +
          877C
          +
          878C DO 154 I = 1, IPTR(31)
          +
          879C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
          +
          880C 154 CONTINUE
          +
          881 END IF
          +
          882 END IF
          +
          883C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON,
          +
          884C MUST COMPLETE EXPANSION OF DATA AND
          +
          885C DESCRIPTORS.
          +
          886 IF (iptr(38).EQ.1) THEN
          +
          887 CALL fi8811(iptr,ident,mstack,kdata,knr,
          +
          888 * ldata,lstack,maxd,maxr)
          +
          889 END IF
          +
          890C
          +
          891C IF HAVE A LIST OF TABLE ENTRIES FROM
          +
          892C A BUFR MESSAGE TYPE 11
          +
          893C PRINT OUT THE ENTRIES
          +
          894C
          +
          895 IF (ident(5).EQ.11) THEN
          +
          896C DO 100 I = 1, IPTR(31)+IPTR(24)
          +
          897C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4)
          +
          898C 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
          +
          904C> @brief Data extraction
          +
          905C> @author Bill Cavanaugh @date 1988-09-01
          +
          906
          +
          907C> Control the extraction of data from section 4 based on data descriptors.
          +
          908C>
          +
          909C> Program history log:
          +
          910C> - Bill Cavanaugh 1988-09-01\
          +
          911C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
          +
          912C> DATA.
          +
          913C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
          +
          914C> DELAYED REPLICATION.
          +
          915C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
          +
          916C> - Dennis Keyser 1995-06-07 Corrected an error which required input
          +
          917C> argument "maxd" to be nearly twice as large
          +
          918C> as needed for decoding wind profiler reports
          +
          919C> (limit upper bound for "iwork" array was set
          +
          920C> to "maxd", now it is set to 15000)
          +
          921C>
          +
          922C> @param[in] IPTR See w3fi88() routine docblock
          +
          923C> @param[in] IDENT See w3fi88() routine docblock
          +
          924C> @param[in] MSGA Array containing bufr message
          +
          925C> @param[inout] ISTACK Original array of descriptors extracted from
          +
          926C> source bufr message.
          +
          927C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
          +
          928C> factor
          +
          929C> @param[inout] KFXY1+KFXY2+KFXY3 Image of current descriptor
          +
          930C> @param[in] INDEX
          +
          931C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          932C> contained in a bufr message
          +
          933C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          934C> may be processed; upper air data and some satellite
          +
          935C> data require a value for maxd of 1700, but for most
          +
          936C> other data a value for maxd of 500 will suffice
          +
          937C> @param[in] IUNITB Unit number of data set holding table b
          +
          938C> @param[in] IUNITD Unit number of data set holding table d
          +
          939C> @param[out] IWORK Working descriptor list
          +
          940C> @param[out] KDATA Array containing decoded reports from bufr message.
          +
          941C> KDATA(Report number,parameter number)
          +
          942C> (report number limited to value of input argument
          +
          943C> maxr and parameter number limited to value of input
          +
          944C> argument maxd)
          +
          945C>
          +
          946C> arrays containing data from table b
          +
          947C> @param[out] AUNIT1+AUNIT2+AUNIT3 Units for descriptor
          +
          948C> @param[out] ANAME1+ANAME2+ANAME3 Descriptor name
          +
          949C> @param[out] ISCAL1+ISCAL2+ISCAL3 Scale for value of descriptor
          +
          950C> @param[out] IRFVL1+IRFVL2+IRFVL3 Reference value for descriptor
          +
          951C> @param[out] IWIDE1+IWIDE2+IWIDE3 Bit width for value of descriptor
          +
          952C> @param ITBLD+ITBLD2
          +
          953C> @param KPTRB
          +
          954C> @param KPTRD
          +
          955C> @param KNR
          +
          956C> @param IVALS
          +
          957C> @param IRF1SW
          +
          958C> @param INEWVL
          +
          959C>
          +
          960C> Error return:
          +
          961C> - IPTR(1)
          +
          962C> - = 8 Error reading table b
          +
          963C> - = 9 Error reading table d
          +
          964C> - = 11 Error opening table b
          +
          965C>
          +
          966C> @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)
          +
          973C
          +
          974
          +
          975C ..................................................
          +
          976C
          +
          977C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
          +
          978C
          +
          979 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
          +
          980 CHARACTER*64 ANAME2(*)
          +
          981 CHARACTER*24 AUNIT2(*)
          +
          982C ..................................................
          +
          983C
          +
          984C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
          +
          985C
          +
          986 INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
          +
          987 CHARACTER*64 ANAME3(200)
          +
          988 CHARACTER*24 AUNIT3(200)
          +
          989C ..................................................
          +
          990C
          +
          991C NEW BASE TABLE B
          +
          992C MAY BE A COMBINATION OF MASTER TABLE B
          +
          993C AND ANCILLARY TABLE B
          +
          994C
          +
          995 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
          +
          996 CHARACTER*40 ANAME1(*)
          +
          997 CHARACTER*24 AUNIT1(*)
          +
          998C ..................................................
          +
          999C
          +
          1000C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
          +
          1001C
          +
          1002 INTEGER ITBLD2(20,*)
          +
          1003C ..................................................
          +
          1004C
          +
          1005C NEW BASE TABLE D
          +
          1006C
          +
          1007 INTEGER ITBLD(20,*)
          +
          1008C ..................................................
          +
          1009C
          +
          1010C
          +
          1011 INTEGER MAXD, MAXR
          +
          1012C
          +
          1013 INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
          +
          1014C
          +
          1015 INTEGER KNR(MAXR)
          +
          1016 INTEGER LX,LY,LL,J
          +
          1017C INTEGER IHOLD(33)
          +
          1018 INTEGER IPTR(*),KPTRB(*),KPTRD(*)
          +
          1019 INTEGER IDENT(*)
          +
          1020 INTEGER ISTACK(*),IWORK(*)
          +
          1021C
          +
          1022 INTEGER MSTACK(2,MAXD)
          +
          1023C
          +
          1024 INTEGER JDESC
          +
          1025 INTEGER INDEX
          +
          1026C
          +
          1027 SAVE
          +
          1028C
          +
          1029C PRINT *,' DECOLL FI8801'
          +
          1030 IF (index.GT.1) THEN
          +
          1031 GO TO 1000
          +
          1032 END IF
          +
          1033C --------- 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
          +
          1041C INITIALIZE OUTPUT AREA
          +
          1042C SET POINTER TO BEGINNING OF DATA
          +
          1043C SET BIT
          +
          1044 iptr(17) = 1
          +
          1045 1000 CONTINUE
          +
          1046C IPTR(12) = IPTR(13)
          +
          1047 ll = 0
          +
          1048 iptr(11) = 1
          +
          1049 IF (iptr(10).EQ.0) THEN
          +
          1050C RE-ENTRY POINT FOR MULTIPLE
          +
          1051C 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
          +
          1059C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
          +
          1060 iptr(24) = 0
          +
          1061 iptr(31) = 0
          +
          1062C 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
          +
          1072C PROCESS THRU THE FOLLOWING
          +
          1073C 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
          +
          1079C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
          +
          1080 IF (iptr(11).GT.iptr(12)) THEN
          +
          1081C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
          +
          1082 IF (ident(16).NE.0) THEN
          +
          1083C PRINT *,' PROCESSING COMPRESSED REPORTS'
          +
          1084C REFORMAT DATA FROM DESCRIPTOR
          +
          1085C FORM TO USER FORM
          +
          1086 RETURN
          +
          1087 ELSE
          +
          1088C WRITE (6,1)
          +
          1089C 1 FORMAT (1H1)
          +
          1090C 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
          +
          1099C RESET POINTERS
          +
          1100 ll = 0
          +
          1101 iptr(1) = 0
          +
          1102 iptr(11) = 1
          +
          1103 iptr(12) = iptr(13)
          +
          1104C IS THIS LAST REPORT ?
          +
          1105C PRINT *,'READY',IPTR(39),INDEX
          +
          1106 IF (iptr(39).GT.0) THEN
          +
          1107 IF (index.GT.0) THEN
          +
          1108C 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
          +
          1116C GET NEXT DESCRIPTOR
          +
          1117 CALL fi8808 (iptr,iwork,lf,lx,ly,jdesc)
          +
          1118C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
          +
          1119C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
          +
          1120C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
          +
          1121C * ' FOR LOC',IPTR(17),IPTR(25)
          +
          1122CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
          +
          1123C NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE
          +
          1124C LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD"
          +
          1125C MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS
          +
          1126C IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST
          +
          1127CDAK IF (IPTR(11).GT.MAXD) THEN
          +
          1128 IF (iptr(11).GT.15000) THEN
          +
          1129CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
          +
          1130 iptr(1) = 401
          +
          1131 RETURN
          +
          1132 END IF
          +
          1133C
          +
          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
          +
          1142C REPLICATION PROCESSING
          +
          1143 IF (lf.EQ.1) THEN
          +
          1144C ---------- 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
          +
          1150C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM),
          +
          1151C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
          +
          1152 CALL fi8805(iptr,ident,msga,iwork,lx,ly,
          +
          1153 * kdata,ll,knr,mstack,maxr,maxd)
          +
          1154C * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
          +
          1155 IF (iptr(1).NE.0) THEN
          +
          1156 RETURN
          +
          1157 ELSE
          +
          1158 GO TO 12
          +
          1159 END IF
          +
          1160C
          +
          1161C 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
          +
          1169C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM),
          +
          1170C * 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
          +
          1179C DESCRIPTOR SEQUENCE STRINGS
          +
          1180 ELSE IF (lf.EQ.3) THEN
          +
          1181C PRINT *,'F3 SEQUENCE DESCRIPTOR'
          +
          1182C 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
          +
          1188C ELSE
          +
          1189C IF (IPTR(42).NE.0) THEN
          +
          1190C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D'
          +
          1191C CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
          +
          1192C 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
          +
          1199C
          +
          1200C ELEMENT DESCRIPTOR PROCESSING
          +
          1201C
          +
          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)
          +
          1207C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
          +
          1208 iptr(36) = 0
          +
          1209 IF (iptr(1).GT.0) THEN
          +
          1210 RETURN
          +
          1211 ELSE
          +
          1212C
          +
          1213C IF ENCOUNTER CLASS 0 DESCRIPTOR
          +
          1214C NOT CONTAINED WITHIN A BUFR
          +
          1215C MESSAGE OF TYPE 11, THEN COLLECT
          +
          1216C ALL TABLE B ENTRIES FOR USE ON
          +
          1217C CURRENT BUFR MESSAGE
          +
          1218C
          +
          1219 IF (jdesc.LE.20.AND.jdesc.GE.10) THEN
          +
          1220 IF (ident(5).NE.11) THEN
          +
          1221C 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
          +
          1233C 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
          +
          1255C END IF
          +
          1256C END DO WHILE
          +
          1257 200 CONTINUE
          +
          1258C IF (IDENT(16).NE.0) THEN
          +
          1259C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
          +
          1260C ELSE
          +
          1261C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
          +
          1262C END IF
          +
          1263 RETURN
          +
          +
          1264 END
          +
          1265C> @brief Process element descriptor.
          +
          1266C> @author Bill Cavanaugh @date 1988-09-01
          +
          1267
          +
          1268C> Process an element descriptor (f = 0) and store data
          +
          1269C> in output array.
          +
          1270C>
          +
          1271C> Program history log:
          +
          1272C> 88-09-01
          +
          1273C> 91-04-04 Changed to pass width of text fields in bytes
          +
          1274C>
          +
          1275C> @param[in] IPTR See w3fi88 routine docblock
          +
          1276C> @param[in] IDENT See w3fi88 routine docblock
          +
          1277C> @param[in] MSGA Array containing bufr message
          +
          1278C> @param[inout] KDATA Array containing decoded reports from bufr message.
          +
          1279C> KDATA(Report number,parameter number)
          +
          1280C> (report number limited to value of input argument
          +
          1281C> maxr and parameter number limited to value of input
          +
          1282C> argument maxd)
          +
          1283C> @param[inout] KFXY1 Image of current descriptor
          +
          1284C> @param[in] MSTACK
          +
          1285C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
          +
          1286C> a bufr message
          +
          1287C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          1288C> may be processed; upper air data and some satellite
          +
          1289C> data require a value for maxd of 1700, but for most
          +
          1290C> other data a value for maxd of 500 will suffice
          +
          1291C> arrays containing data from table b
          +
          1292C> @param[out] AUNIT1 Units for descriptor
          +
          1293C> @param[out] ISCAL1 Scale for value of descriptor
          +
          1294C> @param[out] IRFVL1 Reference value for descriptor
          +
          1295C> @param[out] IWIDE1 Bit width for value of descriptor
          +
          1296C> @param LL
          +
          1297C> @param JDESC
          +
          1298C> @param IVALS
          +
          1299C> @param J
          +
          1300C> @param KPTRB
          +
          1301C>
          +
          1302C> Error return:
          +
          1303C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
          +
          1304C> in table b.
          +
          1305C>
          +
          1306C> @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
          +
          1310C 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(*)
          +
          1320C ..................................................
          +
          1321C
          +
          1322C NEW BASE TABLE B
          +
          1323C MAY BE A COMBINATION OF MASTER TABLE B
          +
          1324C AND ANCILLARY TABLE B
          +
          1325C
          +
          1326 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
          +
          1327C CHARACTER*40 ANAME1(*)
          +
          1328 CHARACTER*24 AUNIT1(*)
          +
          1329C ..................................................
          +
          1330 SAVE
          +
          1331C
          +
          1332 DATA ASKEY /'CCITT IA5 '/
          +
          1333C
          +
          1334C PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC)
          +
          1335C FIND TABLE B ENTRY
          +
          1336 j = kptrb(jdesc)
          +
          1337C HAVE A MATCH
          +
          1338C SET FLAG IF TEXT EVENT
          +
          1339C 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
          +
          1346C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC
          +
          1347 IF (ident(16).NE.0) THEN
          +
          1348C COMPRESSED
          +
          1349 CALL fi8803(iptr,ident,msga,kdata,ivals,mstack,
          +
          1350 * iwide1,irfvl1,iscal1,j,jdesc,maxr,maxd)
          +
          1351C IF (IPTR(1).NE.0) THEN
          +
          1352C RETURN
          +
          1353C END IF
          +
          1354 ELSE
          +
          1355C NOT COMPRESSED
          +
          1356C PRINT *,' FROM FI8802',J
          +
          1357 CALL fi8804(iptr,msga,kdata,ivals,mstack,
          +
          1358 * iwide1,irfvl1,iscal1,j,ll,jdesc,maxr,maxd)
          +
          1359C IF (IPTR(1).NE.0) THEN
          +
          1360C RETURN
          +
          1361C END IF
          +
          1362 END IF
          +
          1363 RETURN
          +
          +
          1364 END
          +
          1365C> @brief Process compressed data
          +
          1366C> @author Bill Cavanaugh @date 1988-09-01
          +
          1367
          +
          1368C> Process compressed data and place individual elements
          +
          1369C> into output array.
          +
          1370C>
          +
          1371C> Program history log:
          +
          1372C> - Bill Cavanaugh 1988-09-01
          +
          1373C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
          +
          1374C> modified to hanle width of fields in bytes.
          +
          1375C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
          +
          1376C> and uncompressed form gave different results.
          +
          1377C> this has been corrected.
          +
          1378C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
          +
          1379C> provide exact reproduction of all characters.
          +
          1380C> - Bill Cavanaugh 1994-04-11 Corrected processing of data when all values
          +
          1381C> the same (nbinc = 0). corrected test of lowest
          +
          1382C> value against proper bit mask.
          +
          1383C> - Dennis Keyser 1995-06-07 Corrected an error which resulted in
          +
          1384C> returned scale in "mstack(2, ..)" always
          +
          1385C> being set to zero for compressed data. also,
          +
          1386C> scale changes were not being recognized.
          +
          1387C>
          +
          1388C> @param[in] IPTR See w3fi88 routine docblock
          +
          1389C> @param[in] IDENT See w3fi88 routine docblock
          +
          1390C> @param[in] MSGA Array containing bufr message,mstack,
          +
          1391C> @param[in] IVALS Array of single parameter values
          +
          1392C> @param[inout] J
          +
          1393C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          1394C> contained in a bufr message
          +
          1395C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          1396C> may be processed; upper air data and some satellite
          +
          1397C> data require a value for maxd of 1700, but for most
          +
          1398C> other data a value for maxd of 500 will suffice
          +
          1399C> @param[out] KDATA Array containing decoded reports from bufr message.
          +
          1400C> KDATA(Report number,parameter number)
          +
          1401C> (report number limited to value of input argument
          +
          1402C> maxr and parameter number limited to value of input
          +
          1403C> argument maxd)
          +
          1404C> arrays containing data from table b
          +
          1405C> @param[out] ISCAL1 Scale for value of descriptor
          +
          1406C> @param[out] IRFVL1 Reference value for descriptor
          +
          1407C> @param[out] IWIDE1 Bit width for value of descriptor
          +
          1408C> @param MSTACK
          +
          1409C> @param JDESC
          +
          1410C>
          +
          1411C> @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
          +
          1415C
          +
          1416C ..................................................
          +
          1417C
          +
          1418C NEW BASE TABLE B
          +
          1419C MAY BE A COMBINATION OF MASTER TABLE B
          +
          1420C AND ANCILLARY TABLE B
          +
          1421C
          +
          1422C INTEGER KFXY1(*)
          +
          1423 INTEGER ISCAL1(*)
          +
          1424 INTEGER IRFVL1(3,*)
          +
          1425 INTEGER IWIDE1(*)
          +
          1426C CHARACTER*40 ANAME1(*)
          +
          1427C CHARACTER*24 AUNIT1(*)
          +
          1428C ..................................................
          +
          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)
          +
          1436C
          +
          1437 LOGICAL TEXT
          +
          1438C
          +
          1439 INTEGER MSK(32)
          +
          1440C
          +
          1441 SAVE
          +
          1442C
          +
          1443 DATA msk /1, 3, 7, 15, 31, 63, 127,
          +
          1444C 1 2 3 4 5 6 7
          +
          1445 * 255, 511, 1023, 2047, 4095,
          +
          1446C 8 9 10 11 12
          +
          1447 * 8191, 16383, 32767, 65535,
          +
          1448C 13 14 15 16
          +
          1449 * 131071, 262143, 524287,
          +
          1450C 17 18 19
          +
          1451 * 1048575, 2097151, 4194303,
          +
          1452C 20 21 22
          +
          1453 * 8388607, 16777215, 33554431,
          +
          1454C 23 24 25
          +
          1455 * 67108863, 134217727, 268435455,
          +
          1456C 26 27 28
          +
          1457 * 536870911, 1073741823, 2147483647,-1 /
          +
          1458C 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
          +
          1465C
          +
          1466C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J),
          +
          1467C * ' 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
          +
          1473C PRINT *,'DESCRIPTOR',KPRM,JDESC
          +
          1474 IF (.NOT.text) THEN
          +
          1475 IF (iptr(29).GT.0.AND.jdesc.NE.7957) THEN
          +
          1476C PRINT *,'ASSOCIATED FIELD AT',IPTR(25)
          +
          1477C WORKING WITH ASSOCIATED FIELDS HERE
          +
          1478 iptr(31) = iptr(31) + 1
          +
          1479 kprm = iptr(31) + iptr(24)
          +
          1480C GET LOWEST
          +
          1481 CALL gbyte (msga,lowest,iptr(25),iptr(29))
          +
          1482 iptr(25) = iptr(25) + iptr(29)
          +
          1483C GET NBINC
          +
          1484 CALL gbyte (msga,nbinc,iptr(25),6)
          +
          1485 iptr(25) = iptr(25) + 6
          +
          1486C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC
          +
          1487 IF (nbinc.GT.32) THEN
          +
          1488 iptr(1) = 22
          +
          1489 RETURN
          +
          1490 END IF
          +
          1491C 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
          +
          1518C SET PARAMETER
          +
          1519C ISOLATE COMBINED BIT WIDTH
          +
          1520 jwide = iwide1(j) + iptr(26)
          +
          1521C
          +
          1522 IF (jwide.GT.32) THEN
          +
          1523C TOO MANY BITS IN COMBINED
          +
          1524C BIT WIDTH
          +
          1525 print *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH'
          +
          1526 iptr(1) = 22
          +
          1527 RETURN
          +
          1528 END IF
          +
          1529C SINGLE VALUE FOR LOWEST
          +
          1530 nrvals = 1
          +
          1531C LOWEST
          +
          1532C PRINT *,'PARAM',KPRM
          +
          1533 CALL gbyte (msga,lowest,iptr(25),jwide)
          +
          1534C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
          +
          1535 iptr(25) = iptr(25) + jwide
          +
          1536C ISOLATE COMPRESSED BIT WIDTH
          +
          1537 CALL gbyte (msga,nbinc,iptr(25),6)
          +
          1538C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
          +
          1539 IF (nbinc.GT.32) THEN
          +
          1540C 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
          +
          1547C PRINT *,'FOR DESCRIPTOR',JDESC
          +
          1548C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=',
          +
          1549C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
          +
          1550C DO 110 I = 1, KPRM
          +
          1551C WRITE (6,111)I,(KDATA(J,I),J=1,6)
          +
          1552C 110 CONTINUE
          +
          1553C 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
          +
          1560C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
          +
          1561C IF TEXT EVENT, PROCESS TEXT
          +
          1562C GET COMPRESSED VALUES
          +
          1563C 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
          +
          1570C RECALCULATE TO ORIGINAL VALUES
          +
          1571 DO 100 i = 1, nrvals
          +
          1572C 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
          +
          1584C 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
          +
          1602C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
          +
          1603 mstack(1,kprm) = jdesc
          +
          1604C WRITE (6,80) (KDATA(I,KPRM),I=1,10)
          +
          1605 80 FORMAT(2x,10(f10.2,1x))
          +
          1606CVVVVVCHANGE#3 FIX BY KEYSER -- 12/06/1994
          +
          1607C NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..)
          +
          1608C WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES)
          +
          1609 mstack(2,kprm) = iscal1(j) + iptr(27)
          +
          1610CAAAAACHANGE#3 FIX BY KEYSER -- 12/06/1994
          +
          1611 ELSE IF (text) THEN
          +
          1612C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
          +
          1613C GET LOWEST
          +
          1614C 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
          +
          1624C PRINT *,'TEXT - LOWEST = 0'
          +
          1625C 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
          +
          1633C PRINT *,'TEXT NBINC =',NBINC
          +
          1634C 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
          +
          1644C 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
          +
          1650C 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
          +
          1656C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
          +
          1657C SET FOR NEXT PART
          +
          1658 kprm = kprm + 1
          +
          1659 iptr(24) = iptr(24) + 1
          +
          1660C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
          +
          1661C1701 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
          +
          1672C 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
          +
          1679C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
          +
          1680C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
          +
          1681 nbits = 0
          +
          1682 END IF
          +
          1683C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
          +
          1684C1800 FORMAT (2X,I4,2X,3A4)
          +
          1685 1900 CONTINUE
          +
          1686 END IF
          +
          1687 RETURN
          +
          +
          1688 END
          +
          1689C> @brief Process serial data
          +
          1690C> @author Bill Cavanaugh @date 1988-09-01
          +
          1691
          +
          1692C> Process data that is not compressed
          +
          1693C>
          +
          1694C> Program history log:
          +
          1695C> - Bill cavanaugh 1988-09-01
          +
          1696C> - Bill cavanaugh 1991-01-18 Modified to properly handle non-compressed
          +
          1697C> data.
          +
          1698C> - Bill cavanaugh 1991-04-04 Text handling portion of this routine
          +
          1699C> modified to handle field width in bytes.
          +
          1700C> - Bill cavanaugh 1991-04-17 ests showed that the same data in compressed
          +
          1701C> and uncompressed form gave different results.
          +
          1702C> this has been corrected.
          +
          1703C>
          +
          1704C> @param[in] IPTR See w3fi88() routine docblock
          +
          1705C> @param[in] MSGA Array containing bufr message
          +
          1706C> @param[inout] IVALS Array of single parameter values
          +
          1707C> @param[inout] J
          +
          1708C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          1709C> contained in a bufr message
          +
          1710C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          1711C> may be processed; upper air data and some satellite
          +
          1712C> data require a value for maxd of 1700, but for most
          +
          1713C> other data a value for maxd of 500 will suffice
          +
          1714C> @param[out] KDATA Array containing decoded reports from bufr message.
          +
          1715C> KDATA(Report number,parameter number)
          +
          1716C> (report number limited to value of input argument
          +
          1717C> maxr and parameter number limited to value of input
          +
          1718C> argument maxd)
          +
          1719C> Arrays containing data from table b
          +
          1720C> @param[out] ISCAL1 Scale for value of descriptor
          +
          1721C> @param[out] IRFVL1 Reference value for descriptor
          +
          1722C> @param[out] IWIDE1 Bit width for value of descriptorE
          +
          1723C> @param MSTACK
          +
          1724C> @param LL
          +
          1725C> @param JDESC
          +
          1726C>
          +
          1727C> Error return:
          +
          1728C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
          +
          1729C>
          +
          1730C> @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
          +
          1734C ..................................................
          +
          1735C
          +
          1736C NEW BASE TABLE B
          +
          1737C MAY BE A COMBINATION OF MASTER TABLE B
          +
          1738C AND ANCILLARY TABLE B
          +
          1739C
          +
          1740C INTEGER KFXY1(*)
          +
          1741 INTEGER ISCAL1(*)
          +
          1742 INTEGER IRFVL1(3,*)
          +
          1743 INTEGER IWIDE1(*)
          +
          1744C CHARACTER*40 ANAME1(*)
          +
          1745C CHARACTER*24 AUNIT1(*)
          +
          1746C ..................................................
          +
          1747C
          +
          1748 INTEGER MSGA(*),MAXD,MAXR
          +
          1749 INTEGER IPTR(*)
          +
          1750 INTEGER JDESC
          +
          1751 INTEGER IVALS(*)
          +
          1752C INTEGER LSTBLK(3)
          +
          1753 INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
          +
          1754 INTEGER J,LL
          +
          1755C LOGICAL LKEY
          +
          1756C
          +
          1757C
          +
          1758 INTEGER ITEST(32)
          +
          1759C
          +
          1760 SAVE
          +
          1761C
          +
          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/
          +
          1769C
          +
          1770 mwdbit = iptr(44)
          +
          1771 IF (iptr(45).NE.4) THEN
          +
          1772 i = 2147483647
          +
          1773 itest(32) = i + i + 1
          +
          1774 END IF
          +
          1775C
          +
          1776C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
          +
          1777C -------- NOCMP --------
          +
          1778C IF NOT TEXT EVENT, PROCESS
          +
          1779 IF (iptr(18).EQ.0) THEN
          +
          1780C PRINT *,' NOT TEXT'
          +
          1781 IF ((iptr(26)+iwide1(j)).LT.1) THEN
          +
          1782C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
          +
          1783 iptr(1) = 501
          +
          1784 RETURN
          +
          1785 END IF
          +
          1786C ISOLATE BIT WIDTH
          +
          1787 jwide = iwide1(j) + iptr(26)
          +
          1788C 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)
          +
          1798C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM),
          +
          1799C * 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
          +
          1805C IF (IPTR(27).NE.0) THEN
          +
          1806C MSTACK(2,KPRM) = IPTR(27)
          +
          1807C ELSE
          +
          1808 mstack(2,kprm) = iscal1(j) + iptr(27)
          +
          1809C END IF
          +
          1810C GET VALUES
          +
          1811C CALL TO GET DATA OF GIVEN BIT WIDTH
          +
          1812 CALL gbyte (msga,ivals,iptr(25),jwide)
          +
          1813C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
          +
          1814 iptr(25) = iptr(25) + jwide
          +
          1815C 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
          +
          1832C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM),
          +
          1833C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
          +
          1834C IF(JDESC.EQ.2049) THEN
          +
          1835C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
          +
          1836C END IF
          +
          1837C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM),
          +
          1838C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
          +
          1839 ELSE
          +
          1840C PRINT *,' TEXT'
          +
          1841C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
          +
          1842 jwide = iptr(40) * 8
          +
          1843C PRINT *,' WIDTH =',JWIDE,IPTR(40)
          +
          1844 nrchrs = iptr(40)
          +
          1845 nrbits = jwide
          +
          1846C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS
          +
          1847 iptr(31) = iptr(31) + 1
          +
          1848 kany = 0
          +
          1849 1800 CONTINUE
          +
          1850 kany = kany + 1
          +
          1851C PRINT *,' NR BITS THIS PASS',NRBITS
          +
          1852 IF (nrbits.GT.mwdbit) THEN
          +
          1853 CALL gbyte (msga,idata,iptr(25),mwdbit)
          +
          1854C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS
          +
          1855 1801 FORMAT (1x,i2,4x,z8,2(4x,i4))
          +
          1856C CONVERTS ASCII TO EBCIDIC
          +
          1857C 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
          +
          1865C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
          +
          1866C * 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
          +
          1874C CONVERTS ASCII TO EBCIDIC
          +
          1875C 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
          +
          1889C PRINT 1723,IDATA
          +
          1890C1723 FORMAT (12X,Z8)
          +
          1891 1722 CONTINUE
          +
          1892 END IF
          +
          1893 kdata(iptr(17),kprm) = idata
          +
          1894C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
          +
          1895 mstack(1,kprm) = jdesc
          +
          1896 mstack(2,kprm) = 0
          +
          1897C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM),
          +
          1898C * KDATA(IPTR(17),KPRM)
          +
          1899 END IF
          +
          1900 END IF
          +
          1901 RETURN
          +
          +
          1902 END
          +
          1903C> @brief Process a replication descriptor
          +
          1904C> @author Bill Cavanaugh @date 1988-09-01
          +
          1905
          +
          1906C> Process a replication descriptor, must extract number
          +
          1907C> of replications of n descriptors from the data stream.
          +
          1908C>
          +
          1909C> Program history log:
          +
          1910C> - Bill Cavanaugh 1988-09-01
          +
          1911C>
          +
          1912C> @param[in] IWORK Working descriptor list
          +
          1913C> @param[in] IPTR See w3fi88 routine docblock
          +
          1914C> @param[in] IDENT See w3fi88 routine docblock
          +
          1915C> @param[inout] LX X portion of current descriptor
          +
          1916C> @param[inout] LY Y portion of current descriptor
          +
          1917C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          1918C> contained in a bufr message
          +
          1919C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          1920C> may be processed; upper air data and some satellite
          +
          1921C> data require a value for maxd of 1700, but for most
          +
          1922C> other data a value for maxd of 500 will suffice
          +
          1923C> @param[out] KDATA Array containing decoded reports from bufr message.
          +
          1924C> KDATA(Report number,parameter number)
          +
          1925C> (report number limited to value of input argument
          +
          1926C> maxr and parameter number limited to value of input
          +
          1927C> argument maxd)
          +
          1928C> @param MSGA
          +
          1929C> @param LL
          +
          1930C> @param KNR
          +
          1931C> @param MSTACK
          +
          1932C>
          +
          1933C> Error return:
          +
          1934C> - IPTR(1)
          +
          1935C> - = 12 Data descriptor qualifier does not follow delayed replication descriptor
          +
          1936C> - = 20 Exceeded count for delayed replication pass
          +
          1937C>
          +
          1938C> @author Bill Cavanaugh @date 1988-09-01
          +
          +
          1939 SUBROUTINE fi8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
          +
          1940 * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
          +
          1941
          +
          1942C
          +
          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)
          +
          1953CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
          +
          1954C NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER
          +
          1955C DEFINED AS 15000 WORDS
          +
          1956 INTEGER IWORK(*)
          +
          1957CDAK INTEGER IWORK(MAXD)
          +
          1958CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
          +
          1959 INTEGER IDENT(*)
          +
          1960C
          +
          1961 SAVE
          +
          1962C
          +
          1963C PRINT *,' REPLICATION FI8805'
          +
          1964C DO 7100 I = 1, IPTR(13)
          +
          1965C PRINT *,I,IWORK(I)
          +
          1966C7100 CONTINUE
          +
          1967C NUMBER OF DESCRIPTORS
          +
          1968 nrset = lx
          +
          1969C NUMBER OF REPLICATIONS
          +
          1970 nrreps = ly
          +
          1971 icurr = iptr(11) - 1
          +
          1972 ipick = iptr(11) - 1
          +
          1973C
          +
          1974 IF (nrreps.EQ.0) THEN
          +
          1975 iptr(39) = 1
          +
          1976C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
          +
          1977C IPTR(31) = IPTR(31) + 1
          +
          1978C KPRM = IPTR(31) + IPTR(24)
          +
          1979C MSTACK(1,KPRM) = JDESC
          +
          1980C MSTACK(2,KPRM) = 0
          +
          1981C KDATA(IPTR(17),KPRM) = 0
          +
          1982C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM),
          +
          1983C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
          +
          1984C DELAYED REPLICATION - MUST GET NUMBER OF
          +
          1985C REPLICATIONS FROM DATA.
          +
          1986C GET NEXT DESCRIPTOR
          +
          1987 CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
          +
          1988C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
          +
          1989C MUST BE DATA DESCRIPTION
          +
          1990C 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
          +
          2001C THIS IF BLOCK IS SET TO HANDLE
          +
          2002C DATA/DESCRIPTOR REPLICATION
          +
          2003 IF (jdesc.EQ.7947.OR.jdesc.EQ.7948) THEN
          +
          2004C SET DATA/DESCRIPTOR REPLICATION FLAG = ON
          +
          2005 iptr(38) = 1
          +
          2006C 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
          +
          2017C SET SINGLE VALUE FOR SEQUENTIAL,
          +
          2018C MULTIPLE VALUES FOR COMPRESSED
          +
          2019 IF (ident(16).EQ.0) THEN
          +
          2020
          +
          2021C NON COMPRESSED
          +
          2022 CALL gbyte (msga,kvals,iptr(25),jwide)
          +
          2023C 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)
          +
          2031C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM),
          +
          2032C * 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
          +
          2048C PRINT *,'NOT DELAYED REPLICATION'
          +
          2049 END IF
          +
          2050C RESTRUCTURE WORKING STACK W/REPLICATIONS
          +
          2051 IF (nrreps.EQ.0) THEN
          +
          2052C PRINT *,'RESTRUCTURING - NO REPLICATION'
          +
          2053 iptr(11) = ipick + nrset + 2
          +
          2054 GO TO 9999
          +
          2055 END IF
          +
          2056C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
          +
          2057C 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
          +
          2061C PRINT *,'REPLICATION ',I,ITEMP(I)
          +
          2062 1000 CONTINUE
          +
          2063C MOVE TRAILING DESCRIPTORS TO HOLD AREA
          +
          2064 lax = iptr(12) - iptr(11) + 1
          +
          2065C 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
          +
          2069C PRINT *,' ',I,KTEMP(I)
          +
          2070 2000 CONTINUE
          +
          2071C REPLICATIONS INTO ISTACK
          +
          2072C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
          +
          2073C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
          +
          2074 DO 4000 i = 1, nrreps
          +
          2075 DO 3000 j = 1, nrset
          +
          2076 iwork(icurr) = itemp(j)
          +
          2077C PRINT *,'FI8805 A',ICURR,IWORK(ICURR)
          +
          2078 icurr = icurr + 1
          +
          2079 3000 CONTINUE
          +
          2080 4000 CONTINUE
          +
          2081C PRINT *,' TO LOC',ICURR-1
          +
          2082C RESTORE TRAILING DESCRIPTORS
          +
          2083C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
          +
          2084 DO 5000 i = 1, lax
          +
          2085 iwork(icurr) = ktemp(i)
          +
          2086C 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
          +
          2092C DO 5500 I = 1, IPTR(12)
          +
          2093C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11)
          +
          2094C5500 CONTINUE
          +
          2095 RETURN
          +
          +
          2096 END
          +
          2097C> @brief Process operator descriptors
          +
          2098C> @author Bill Cavanaugh @date 1988-09-01
          +
          2099
          +
          2100C> Extract and save indicated change values for use
          +
          2101C> until changes are rescinded, or extract text strings indicated
          +
          2102C> through 2 05 yyy.
          +
          2103C>
          +
          2104C> Program history log:
          +
          2105C> - Bill Cavanaugh 1988-09-01
          +
          2106C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
          +
          2107C> - Bill Cavanaugh 1991-05-10 Coding has been added to process properly
          +
          2108C> table c descriptor 2 06 yyy.
          +
          2109C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
          +
          2110C> table c descriptor 2 03 yyy, the change
          +
          2111C> to new reference value for selected
          +
          2112C> descriptors.
          +
          2113C>
          +
          2114C> @param[in] IPTR See w3fi88 routine docblock
          +
          2115C> @param[in] LX X portion of current descriptor
          +
          2116C> @param[in] LY Y portion of current descriptor
          +
          2117C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          2118C> contained in a bufr message
          +
          2119C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          2120C> may be processed; upper air data and some satellite
          +
          2121C> data require a value for maxd of 1700, but for most
          +
          2122C> other data a value for maxd of 500 will suffice
          +
          2123C> @param[out] KDATA Array containing decoded reports from bufr message.
          +
          2124C> KDATA(Report number,parameter number)
          +
          2125C> (report number limited to value of input argument
          +
          2126C> maxr and parameter number limited to value of input
          +
          2127C> argument maxd)
          +
          2128C> Arrays containing data from table b
          +
          2129C> @param[out] ISCAL1 Scale for value of descriptor
          +
          2130C> @param[out] IRFVL1 Reference value for descriptor
          +
          2131C> @param[out] IWIDE1 Bit width for value of descriptor
          +
          2132C> @param IDENT
          +
          2133C> @param MSGA
          +
          2134C> @param IVALS
          +
          2135C> @param MSTACK
          +
          2136C> @param J
          +
          2137C> @param LL
          +
          2138C> @param KFXY1
          +
          2139C> @param IWORK
          +
          2140C> @param JDESC
          +
          2141C> @param KPTRB
          +
          2142C>
          +
          2143C> Error return:
          +
          2144C> IPTR(1) = 5 - Erroneous x value in data descriptor operator
          +
          2145C>
          +
          2146C> @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
          +
          2150C ..................................................
          +
          2151C
          +
          2152C NEW BASE TABLE B
          +
          2153C MAY BE A COMBINATION OF MASTER TABLE B
          +
          2154C AND ANCILLARY TABLE B
          +
          2155C
          +
          2156 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
          +
          2157C CHARACTER*40 ANAME1(*)
          +
          2158C CHARACTER*24 AUNIT1(*)
          +
          2159C ..................................................
          +
          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
          +
          2167C
          +
          2168 SAVE
          +
          2169C
          +
          2170C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
          +
          2171 IF (lx.EQ.1) THEN
          +
          2172C CHANGE BIT WIDTH
          +
          2173 IF (ly.EQ.0) THEN
          +
          2174C PRINT *,' RETURN TO NORMAL WIDTH'
          +
          2175 iptr(26) = 0
          +
          2176 ELSE
          +
          2177C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
          +
          2178 iptr(26) = ly - 128
          +
          2179 END IF
          +
          2180 ELSE IF (lx.EQ.2) THEN
          +
          2181C CHANGE SCALE
          +
          2182 IF (ly.EQ.0) THEN
          +
          2183C RESET TO STANDARD SCALE
          +
          2184 iptr(27) = 0
          +
          2185 ELSE
          +
          2186C SET NEW SCALE
          +
          2187 iptr(27) = ly - 128
          +
          2188 END IF
          +
          2189 ELSE IF (lx.EQ.3) THEN
          +
          2190C CHANGE REFERENCE VALUE
          +
          2191C FOR EACH OF THOSE DESCRIPTORS BETWEEN
          +
          2192C 2 03 YYY WHERE Y LT 255 AND
          +
          2193C 2 03 255, EXTRACT THE NEW REFERENCE
          +
          2194C VALUE (BIT WIDTH YYY) AND PLACE
          +
          2195C IN TERTIARY TABLE B REF VAL POSITION,
          +
          2196C SET FLAG IN SECONDARY REFVAL POSITION
          +
          2197C THOSE DESCRIPTORS DO NOT HAVE DATA
          +
          2198C ASSOCIATED WITH THEM, BUT ONLY
          +
          2199C IDENTIFY THE TABLE B ENTRIES THAT
          +
          2200C ARE GETTING NEW REFERENCE VALUES.
          +
          2201 kyyy = ly
          +
          2202 IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
          +
          2203C START CYCLING THRU DESCRIPTORS UNTIL
          +
          2204C TERMINATE NEW REF VALS IS FOUND
          +
          2205 300 CONTINUE
          +
          2206 CALL fi8808 (iptr,iwork,lf,lx,ly,jdesc)
          +
          2207 IF (jdesc.EQ.33791) THEN
          +
          2208C IF 2 03 255 THEN RETURN
          +
          2209 RETURN
          +
          2210 END IF
          +
          2211C FIND MATCHING TABLE B ENTRY
          +
          2212 lj = kptrb(jdesc)
          +
          2213 IF (lj.LT.1) THEN
          +
          2214C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
          +
          2215 print *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
          +
          2216 iptr(1) = 23
          +
          2217 RETURN
          +
          2218 END IF
          +
          2219C TURN ON SWITCH
          +
          2220 irfvl1(2,lj) = 1
          +
          2221C 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
          +
          2225C MUST TURN OFF ALL NEW
          +
          2226C REFERENCE VALUES
          +
          2227 DO 400 i = 1, iptr(21)
          +
          2228 irfvl1(2,i) = 0
          +
          2229 400 CONTINUE
          +
          2230 END IF
          +
          2231C LX = 3
          +
          2232C MUST BE CONCLUDED WITH Y=255
          +
          2233 ELSE IF (lx.EQ.4) THEN
          +
          2234C ASSOCIATED VALUES
          +
          2235 IF (ly.EQ.0) THEN
          +
          2236 iptr(29) = 0
          +
          2237C 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
          +
          2244C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
          +
          2245 END IF
          +
          2246 ELSE IF (lx.EQ.5) THEN
          +
          2247 mwdbit = iptr(44)
          +
          2248C PROCESS TEXT DATA
          +
          2249 iptr(40) = ly
          +
          2250 iptr(18) = 1
          +
          2251 j = kptrb(jdesc)
          +
          2252 IF (ident(16).EQ.0) THEN
          +
          2253C 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
          +
          2257C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY
          +
          2258C PRINT *,'TEXT - LOWEST = 0'
          +
          2259 iptr(25) = iptr(25) + iptr(40) * 8
          +
          2260C GET NBINC
          +
          2261C CALL GBYTE (MSGA,NBINC,IPTR(25),6)
          +
          2262 iptr(25) = iptr(25) + 6
          +
          2263 nbinc = iptr(40)
          +
          2264C PRINT *,'TEXT NBINC =',NBINC,IPTR(40)
          +
          2265C 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
          +
          2273C 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
          +
          2278C CONVERTS ASCII TO EBCIDIC
          +
          2279C 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
          +
          2286C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
          +
          2287C SET FOR NEXT PART
          +
          2288 kprm = kprm + 1
          +
          2289C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
          +
          2290C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,
          +
          2291C * 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
          +
          2297C CONVERTS ASCII TO EBCIDIC
          +
          2298C 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
          +
          2305C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
          +
          2306C SET FOR NEXT PART
          +
          2307 kprm = kprm + 1
          +
          2308C 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
          +
          2318C CONVERTS ASCII TO EBCIDIC
          +
          2319C 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
          +
          2326C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
          +
          2327C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
          +
          2328 END IF
          +
          2329C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
          +
          2330C1800 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
          +
          2337C ---------------------------
          +
          2338 ELSE IF (lx.EQ.6) THEN
          +
          2339C SKIP NEXT DESCRIPTOR
          +
          2340C SET TO PASS OVER DESCRIPTOR AND DATA
          +
          2341C IF DESCRIPTOR NOT IN TABLE B
          +
          2342 iptr(36) = ly
          +
          2343C 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
          +
          2353C> @brief Process queue descriptor.
          +
          2354C> @author Bill Cavanaugh @date 1988-09-01
          +
          2355
          +
          2356C> Substitute descriptor queue for queue descriptor.
          +
          2357C>
          +
          2358C> Program history log:
          +
          2359C> - Bill Cavanaugh 1988-09-01
          +
          2360C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors
          +
          2361C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors
          +
          2362C> based on tests with live data.
          +
          2363C>
          +
          2364C> @param[in] IWORK Working descriptor list
          +
          2365C> @param[in] IPTR See w3fi88 routine docblock
          +
          2366C> @param[in] ITBLD+ITBLD2 Array containing descriptor queues
          +
          2367C> @param[in] JDESC Queue descriptor to be expanded
          +
          2368C> @param KPTRD
          +
          2369C>
          +
          2370C> @author Bill Cavanaugh @date 1988-09-01
          +
          +
          2371 SUBROUTINE fi8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
          +
          2372
          +
          2373C ..................................................
          +
          2374C
          +
          2375C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
          +
          2376C
          +
          2377 INTEGER ITBLD2(20,*)
          +
          2378C ..................................................
          +
          2379C
          +
          2380C NEW BASE TABLE D
          +
          2381C
          +
          2382 INTEGER ITBLD(20,*)
          +
          2383C ..................................................
          +
          2384C
          +
          2385 INTEGER IPTR(*),JDESC,KPTRD(*)
          +
          2386 INTEGER IWORK(*),IHOLD(15000)
          +
          2387C
          +
          2388 SAVE
          +
          2389C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12)
          +
          2390C SET FOR BINARY SEARCH IN TABLE D
          +
          2391 jlo = 1
          +
          2392 jhi = iptr(20)
          +
          2393C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12)
          +
          2394C
          +
          2395 jmid = kptrd(mod(jdesc,16384))
          +
          2396 IF (jmid.LT.0) THEN
          +
          2397 iptr(1) = 4
          +
          2398 RETURN
          +
          2399 END IF
          +
          2400C HAVE TABLE D MATCH
          +
          2401C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20)
          +
          2402C 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)
          +
          2409C 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
          +
          2417C NOTHING MORE TO APPEND
          +
          2418C PRINT *,'NOTHING MORE TO APPEND'
          +
          2419 ELSE
          +
          2420C APPEND TRAILING IWORK TO IHOLD
          +
          2421C 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
          +
          2427C RESET IHOLD TO IWORK
          +
          2428C 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
          +
          2435C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12)
          +
          2436C DO 2000 I = 1, IPTR(12)
          +
          2437C PRINT *,'EXIT IWORK',I,IWORK(I)
          +
          2438C2000 CONTINUE
          +
          2439C RESET POINTERS
          +
          2440 iptr(11) = iptr(11) - 1
          +
          2441 RETURN
          +
          +
          2442 END
          +
          2443C> @brief
          +
          2444C> @author Bill Cavanaugh @date 1988-09-01
          +
          2445
          +
          2446C>
          +
          2447C> Program history log:
          +
          2448C> - Bill Cavanaugh 1988-09-01
          +
          2449C>
          +
          2450C> @param[inout] IPTR See w3fi88 routine docblock
          +
          2451C> @param[in] IWORK Working descriptor list
          +
          2452C> @param LF
          +
          2453C> @param LX
          +
          2454C> @param LY
          +
          2455C> @param JDESC
          +
          2456C>
          +
          2457C> @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
          +
          2462C
          +
          2463C 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
          +
          2471C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11)
          +
          2472 iptr(11) = iptr(11) + 1
          +
          2473 RETURN
          +
          +
          2474 END
          +
          2475C> @brief Reformat profiler w hgt increments
          +
          2476C> @author Bill Cavanaugh @date 1990-02-14
          +
          2477
          +
          2478C> Reformat decoded profiler data to show heights instead of
          +
          2479C> height increments.
          +
          2480C>
          +
          2481C> Program history log:
          +
          2482C> - Bill Cavanaugh 1990-02-14
          +
          2483C>
          +
          2484C> @param[in] IDENT Array contains message information extracted from BUFR message
          +
          2485C> - IDENT(1) - Edition number (byte 4, section 1)
          +
          2486C> - IDENT(2) - Originating center (bytes 5-6, section 1)
          +
          2487C> - IDENT(3) - Update sequence (byte 7, section 1)
          +
          2488C> - IDENT(4) - (byte 8, section 1)
          +
          2489C> - IDENT(5) - Bufr message type (byte 9, section 1)
          +
          2490C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
          +
          2491C> - IDENT(7) - (bytes 11-12, section 1)
          +
          2492C> - IDENT(8) - Year of century (byte 13, section 1)
          +
          2493C> - IDENT(9) - Month of year (byte 14, section 1)
          +
          2494C> - IDENT(10) - Day of month (byte 15, section 1)
          +
          2495C> - IDENT(11) - Hour of day (byte 16, section 1)
          +
          2496C> - IDENT(12) - Minute of hour (byte 17, section 1)
          +
          2497C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
          +
          2498C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
          +
          2499C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
          +
          2500C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
          +
          2501C> @param[in] MSTACK Working descriptor list and scaling factor
          +
          2502C> @param[in] KDATA Array containing decoded reports from bufr message.
          +
          2503C> KDATA(Report number,parameter number)
          +
          2504C> (report number limited to value of input argument
          +
          2505C> maxr and parameter number limited to value of input
          +
          2506C> argument maxd)
          +
          2507C> @param[in] IPTR See w3fi88
          +
          2508C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          2509C> contained in a bufr message
          +
          2510C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          2511C> may be processed; upper air data and some satellite
          +
          2512C> data require a value for maxd of 1700, but for most
          +
          2513C> other data a value for maxd of 500 will suffice
          +
          2514C>
          +
          2515C> @author Bill Cavanaugh @date 1990-02-14
          +
          +
          2516 SUBROUTINE fi8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
          +
          2517
          +
          2518C ----------------------------------------------------------------
          +
          2519C
          +
          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)
          +
          2526C
          +
          2527C ----------------------------------------------------------
          +
          2528 SAVE
          +
          2529C PRINT *,'FI8809'
          +
          2530C LOOP FOR NUMBER OF SUBSETS/REPORTS
          +
          2531 DO 3000 i = 1, ident(14)
          +
          2532C INIT FOR DATA INPUT ARRAY
          +
          2533 mk = 1
          +
          2534C INIT FOR DESC OUTPUT ARRAY
          +
          2535 jk = 0
          +
          2536C LOCATION
          +
          2537 isw = 0
          +
          2538 DO 200 j = 1, 3
          +
          2539C LATITUDE
          +
          2540 IF (mstack(1,mk).EQ.1282) THEN
          +
          2541 isw = isw + 1
          +
          2542 GO TO 100
          +
          2543C LONGITUDE
          +
          2544 ELSE IF (mstack(1,mk).EQ.1538) THEN
          +
          2545 isw = isw + 2
          +
          2546 GO TO 100
          +
          2547C 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
          +
          2556C SAVE DESCRIPTOR
          +
          2557 kprofl(jk) = mstack(1,mk)
          +
          2558C SAVE SCALE
          +
          2559 kprof2(jk) = mstack(2,mk)
          +
          2560C 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
          +
          2569C TIME
          +
          2570 isw = 0
          +
          2571 DO 400 j = 1, 7
          +
          2572C YEAR
          +
          2573 IF (mstack(1,mk).EQ.1025) THEN
          +
          2574 isw = isw + 1
          +
          2575 GO TO 300
          +
          2576C MONTH
          +
          2577 ELSE IF (mstack(1,mk).EQ.1026) THEN
          +
          2578 isw = isw + 2
          +
          2579 GO TO 300
          +
          2580C DAY
          +
          2581 ELSE IF (mstack(1,mk).EQ.1027) THEN
          +
          2582 isw = isw + 4
          +
          2583 GO TO 300
          +
          2584C HOUR
          +
          2585 ELSE IF (mstack(1,mk).EQ.1028) THEN
          +
          2586 isw = isw + 8
          +
          2587 GO TO 300
          +
          2588C MINUTE
          +
          2589 ELSE IF (mstack(1,mk).EQ.1029) THEN
          +
          2590 isw = isw + 16
          +
          2591 GO TO 300
          +
          2592C 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
          +
          2603C SAVE DESCRIPTOR
          +
          2604 kprofl(jk) = mstack(1,mk)
          +
          2605C SAVE SCALE
          +
          2606 kprof2(jk) = mstack(2,mk)
          +
          2607C 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
          +
          2616C SURFACE DATA
          +
          2617 krg = 0
          +
          2618 isw = 0
          +
          2619 DO 600 j = 1, 10
          +
          2620C WIND SPEED
          +
          2621 IF (mstack(1,mk).EQ.2818) THEN
          +
          2622 isw = isw + 1
          +
          2623 GO TO 500
          +
          2624C WIND DIRECTION
          +
          2625 ELSE IF (mstack(1,mk).EQ.2817) THEN
          +
          2626 isw = isw + 2
          +
          2627 GO TO 500
          +
          2628C PRESS REDUCED TO MSL
          +
          2629 ELSE IF (mstack(1,mk).EQ.2611) THEN
          +
          2630 isw = isw + 4
          +
          2631 GO TO 500
          +
          2632C TEMPERATURE
          +
          2633 ELSE IF (mstack(1,mk).EQ.3073) THEN
          +
          2634 isw = isw + 8
          +
          2635 GO TO 500
          +
          2636C RAINFALL RATE
          +
          2637 ELSE IF (mstack(1,mk).EQ.3342) THEN
          +
          2638 isw = isw + 16
          +
          2639 GO TO 500
          +
          2640C RELATIVE HUMIDITY
          +
          2641 ELSE IF (mstack(1,mk).EQ.3331) THEN
          +
          2642 isw = isw + 32
          +
          2643 GO TO 500
          +
          2644C 1ST RANGE GATE OFFSET
          +
          2645 ELSE IF (mstack(1,mk).EQ.1982.OR.
          +
          2646 * mstack(1,mk).EQ.1983) THEN
          +
          2647C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
          +
          2648C 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
          +
          2658C PRINT *,'INITIAL INCR =',INCRHT
          +
          2659 ELSE
          +
          2660 lhgt = 500 + ihgt - kdata(i,mk)
          +
          2661 isw = isw + 64
          +
          2662C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
          +
          2663 END IF
          +
          2664 END IF
          +
          2665C MODE #1
          +
          2666 ELSE IF (mstack(1,mk).EQ.8128) THEN
          +
          2667 isw = isw + 128
          +
          2668 GO TO 500
          +
          2669C 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
          +
          2676C SAVE DESCRIPTOR
          +
          2677 jk = jk + 1
          +
          2678 kprofl(jk) = mstack(1,mk)
          +
          2679C SAVE SCALE
          +
          2680 kprof2(jk) = mstack(2,mk)
          +
          2681C SAVE DATA
          +
          2682 kset2(jk) = kdata(i,mk)
          +
          2683C IF (I.EQ.1) THEN
          +
          2684C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
          +
          2685C 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
          +
          2693C 43 LEVELS
          +
          2694 DO 2000 l = 1, 43
          +
          2695 2020 CONTINUE
          +
          2696 isw = 0
          +
          2697C HEIGHT INCREMENT
          +
          2698 IF (mstack(1,mk).EQ.1982) THEN
          +
          2699C 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
          +
          2708C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
          +
          2709C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
          +
          2710 lhgt = lhgt + incrht
          +
          2711C PRINT *,'LEVEL ',L,LHGT
          +
          2712 IF (l.EQ.37) THEN
          +
          2713 lhgt = lhgt + incrht
          +
          2714 END IF
          +
          2715 jk = jk + 1
          +
          2716C SAVE DESCRIPTOR
          +
          2717 kprofl(jk) = 1798
          +
          2718C SAVE SCALE
          +
          2719 kprof2(jk) = 0
          +
          2720C SAVE DATA
          +
          2721 kset2(jk) = lhgt
          +
          2722C IF (I.EQ.10) THEN
          +
          2723C PRINT *,' '
          +
          2724C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
          +
          2725C 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
          +
          2731C 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
          +
          2741C 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
          +
          2750C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
          +
          2751C DESCRIPTORS AND DATA
          +
          2752 IF (iand(isw,1).NE.0) THEN
          +
          2753 IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
          +
          2754C SAVE DD DESCRIPTOR
          +
          2755 jk = jk + 1
          +
          2756 kprofl(jk) = 2817
          +
          2757C SAVE SCALE
          +
          2758 kprof2(jk) = 0
          +
          2759C SAVE DD DATA
          +
          2760 kset2(jk) = 32767
          +
          2761C SAVE FFF DESCRIPTOR
          +
          2762 jk = jk + 1
          +
          2763 kprofl(jk) = 2818
          +
          2764C SAVE SCALE
          +
          2765 kprof2(jk) = 1
          +
          2766C SAVE FFF DATA
          +
          2767 kset2(jk) = 32767
          +
          2768 ELSE
          +
          2769C GENERATE DDFFF
          +
          2770 CALL w3fc05 (vectu,vectv,dir,spd)
          +
          2771 ndir = dir
          +
          2772 spd = spd
          +
          2773 nspd = spd
          +
          2774C PRINT *,' ',NDIR,NSPD
          +
          2775C SAVE DD DESCRIPTOR
          +
          2776 jk = jk + 1
          +
          2777 kprofl(jk) = 2817
          +
          2778C SAVE SCALE
          +
          2779 kprof2(jk) = 0
          +
          2780C SAVE DD DATA
          +
          2781 kset2(jk) = dir
          +
          2782C IF (I.EQ.1) THEN
          +
          2783C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
          +
          2784C END IF
          +
          2785C SAVE FFF DESCRIPTOR
          +
          2786 jk = jk + 1
          +
          2787 kprofl(jk) = 2818
          +
          2788C SAVE SCALE
          +
          2789 kprof2(jk) = 1
          +
          2790C SAVE FFF DATA
          +
          2791 kset2(jk) = spd
          +
          2792C IF (I.EQ.1) THEN
          +
          2793C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
          +
          2794C END IF
          +
          2795 END IF
          +
          2796 END IF
          +
          2797 GO TO 800
          +
          2798C W VECTOR VALUE
          +
          2799 ELSE IF (mstack(1,mk).EQ.3010) THEN
          +
          2800 isw = isw + 4
          +
          2801 GO TO 700
          +
          2802C Q/C TEST RESULTS
          +
          2803 ELSE IF (mstack(1,mk).EQ.8130) THEN
          +
          2804 isw = isw + 8
          +
          2805 GO TO 700
          +
          2806C 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
          +
          2810C 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
          +
          2814C SPECTRAL PEAK POWER
          +
          2815 ELSE IF (mstack(1,mk).EQ.5568) THEN
          +
          2816 isw = isw + 64
          +
          2817 GO TO 700
          +
          2818C U,V VARIABILITY
          +
          2819 ELSE IF (mstack(1,mk).EQ.3011) THEN
          +
          2820 isw = isw + 128
          +
          2821 GO TO 700
          +
          2822C 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
          +
          2833C SAVE DESCRIPTOR
          +
          2834 kprofl(jk) = mstack(1,mk)
          +
          2835C SAVE SCALE
          +
          2836 kprof2(jk) = mstack(2,mk)
          +
          2837C SAVE DATA
          +
          2838 kset2(jk) = kdata(i,mk)
          +
          2839 mk = mk + 1
          +
          2840C IF (I.EQ.1) THEN
          +
          2841C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
          +
          2842C 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
          +
          2850C MOVE DATA BACK INTO KDATA ARRAY
          +
          2851 DO 4000 ll = 1, jk
          +
          2852 kdata(i,ll) = kset2(ll)
          +
          2853 4000 CONTINUE
          +
          2854 3000 CONTINUE
          +
          2855C PRINT *,'REBUILT ARRAY'
          +
          2856 DO 5000 ll = 1, jk
          +
          2857C DESCRIPTOR
          +
          2858 mstack(1,ll) = kprofl(ll)
          +
          2859C SCALE
          +
          2860 mstack(2,ll) = kprof2(ll)
          +
          2861C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
          +
          2862 5000 CONTINUE
          +
          2863C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
          +
          2864 iptr(31) = jk
          +
          2865 RETURN
          +
          +
          2866 END
          +
          2867C> @brief Reformat profiler edition 2 data
          +
          2868C> @author Bill Cavanaugh @date 1993-01-27
          +
          2869
          +
          2870C> Reformat profiler data in edition 2
          +
          2871C>
          +
          2872C> Program history log:
          +
          2873C> - Bill Cavanaugh 1993-01-27
          +
          2874C> - Dennis Keyser 1995-06-07 A correction was made to prevent
          +
          2875C> unnecessary looping when all requested
          +
          2876C> descriptors are missing.
          +
          2877C>
          +
          2878C> @param[in] IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM BUFR MESSAGE -
          +
          2879C> - IDENT(1) - Edition number (byte 4, section 1)
          +
          2880C> - IDENT(2) - Originating center (bytes 5-6, section 1)
          +
          2881C> - IDENT(3) - Update sequence (byte 7, section 1)
          +
          2882C> - IDENT(4) - (byte 8, section 1)
          +
          2883C> - IDENT(5) - Bufr message type (byte 9, section 1)
          +
          2884C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
          +
          2885C> - IDENT(7) - (bytes 11-12, section 1)
          +
          2886C> - IDENT(8) - Year of century (byte 13, section 1)
          +
          2887C> - IDENT(9) - Month of year (byte 14, section 1)
          +
          2888C> - IDENT(10) - Day of month (byte 15, section 1)
          +
          2889C> - IDENT(11) - Hour of day (byte 16, section 1)
          +
          2890C> - IDENT(12) - Minute of hour (byte 17, section 1)
          +
          2891C> - IDENT(13) - Rsvd by adp centers(byte 18, section 1)
          +
          2892C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
          +
          2893C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
          +
          2894C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
          +
          2895C> @param[in] MSTACK Working descriptor list and scaling factor
          +
          2896C> @param[in] KDATA Array containing decoded reports from bufr message.
          +
          2897C> KDATA(Report number,parameter number)
          +
          2898C> (report number limited to value of input argument
          +
          2899C> maxr and parameter number limited to value of input
          +
          2900C> argument maxd)
          +
          2901C> @param[in] IPTR See w3fi88
          +
          2902C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          2903C> contained in a bufr message
          +
          2904C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          2905C> may be processed; upper air data and some satellite
          +
          2906C> data require a value for maxd of 1700, but for most
          +
          2907C> other data a value for maxd of 500 will suffice
          +
          2908C>
          +
          2909C> @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)
          +
          2918C
          +
          2919 SAVE
          +
          2920C LOOP FOR NUMBER OF SUBSETS
          +
          2921 DO 3000 i = 1, ident(14)
          +
          2922 mk = 1
          +
          2923 jk = 0
          +
          2924 isw = 0
          +
          2925C PRINT *,'IDENTIFICATION'
          +
          2926 DO 200 j = 1, 5
          +
          2927 IF (mstack(1,mk).EQ.257) THEN
          +
          2928C BLOCK NUMBER
          +
          2929 isw = isw + 1
          +
          2930 ELSE IF (mstack(1,mk).EQ.258) THEN
          +
          2931C STATION NUMBER
          +
          2932 isw = isw + 2
          +
          2933 ELSE IF (mstack(1,mk).EQ.1282) THEN
          +
          2934C LATITUDE
          +
          2935 isw = isw + 4
          +
          2936 ELSE IF (mstack(1,mk).EQ.1538) THEN
          +
          2937C LONGITUDE
          +
          2938 isw = isw + 8
          +
          2939 ELSE IF (mstack(1,mk).EQ.1793) THEN
          +
          2940C 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)
          +
          2951C PRINT *,JK,KPROFL(JK),KSET2(JK)
          +
          2952 mk = mk + 1
          +
          2953 200 CONTINUE
          +
          2954C PRINT *,'LOCATION ',ISW
          +
          2955 IF (isw.NE.31) THEN
          +
          2956 print *,'LOCATION ERROR PROCESSING PROFILER'
          +
          2957 iptr(10) = 200
          +
          2958 RETURN
          +
          2959 END IF
          +
          2960C PROCESS TIME ELEMENTS
          +
          2961 isw = 0
          +
          2962 DO 400 j = 1, 7
          +
          2963 IF (mstack(1,mk).EQ.1025) THEN
          +
          2964C YEAR
          +
          2965 isw = isw + 1
          +
          2966 ELSE IF (mstack(1,mk).EQ.1026) THEN
          +
          2967C MONTH
          +
          2968 isw = isw + 2
          +
          2969 ELSE IF (mstack(1,mk).EQ.1027) THEN
          +
          2970C DAY
          +
          2971 isw = isw + 4
          +
          2972 ELSE IF (mstack(1,mk).EQ.1028) THEN
          +
          2973C HOUR
          +
          2974 isw = isw + 8
          +
          2975 ELSE IF (mstack(1,mk).EQ.1029) THEN
          +
          2976C MINUTE
          +
          2977 isw = isw + 16
          +
          2978 ELSE IF (mstack(1,mk).EQ.2069) THEN
          +
          2979C TIME SIGNIFICANCE
          +
          2980 isw = isw + 32
          +
          2981 ELSE IF (mstack(1,mk).EQ.1049) THEN
          +
          2982C 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)
          +
          2992C PRINT *,JK,KPROFL(JK),KSET2(JK)
          +
          2993 mk = mk + 1
          +
          2994 400 CONTINUE
          +
          2995C PRINT *,'TIME ',ISW
          +
          2996 IF (isw.NE.127) THEN
          +
          2997 print *,'TIME ERROR PROCESSING PROFILER'
          +
          2998 iptr(1) = 201
          +
          2999 RETURN
          +
          3000 END IF
          +
          3001C SURFACE DATA
          +
          3002 isw = 0
          +
          3003C PRINT *,'SURFACE'
          +
          3004 DO 600 k = 1, 8
          +
          3005C 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
          +
          3021C PRINT *,'INITIAL INCREMENT = ',INCRHT
          +
          3022 mk = mk + 1
          +
          3023C 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)
          +
          3032C 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
          +
          3045C MUST SAVE THIS HEIGHT VALUE
          +
          3046 lhgt = 500 + ihgt - kdata(i,mk)
          +
          3047C 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
          +
          3052C PROCESS LEVEL DATA
          +
          3053C PRINT *,'LEVEL DATA'
          +
          3054 DO 2000 l = 1, 43
          +
          3055 2020 CONTINUE
          +
          3056C PRINT *,'DESC',MK,MSTACK(1,MK),JK
          +
          3057 isw = 0
          +
          3058C HEIGHT INCREMENT
          +
          3059 IF (mstack(1,mk).EQ.1797) THEN
          +
          3060 incrht = kdata(i,mk)
          +
          3061C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
          +
          3062 mk = mk + 1
          +
          3063C IF (LHGT.LT.(9250+IHGT)) THEN
          +
          3064C LHGT = IHGT + 500 - INCRHT
          +
          3065C ELSE
          +
          3066C LHGT = IHGT + 9250 -INCRHT
          +
          3067C END IF
          +
          3068 END IF
          +
          3069C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
          +
          3070C AT THIS POINT
          +
          3071 lhgt = lhgt + incrht
          +
          3072C PRINT *,'LEVEL ',L,LHGT
          +
          3073C IF (L.EQ.37) THEN
          +
          3074C LHGT = LHGT + INCRHT
          +
          3075C END IF
          +
          3076 jk = jk + 1
          +
          3077C SAVE DESCRIPTOR
          +
          3078 kprofl(jk) = 1798
          +
          3079C SAVE SCALE
          +
          3080 kprof2(jk) = 0
          +
          3081C SAVE DATA
          +
          3082 kset2(jk) = lhgt
          +
          3083C PRINT *,KPROFL(JK),KSET2(JK),JK
          +
          3084 isw = 0
          +
          3085 icon = 1
          +
          3086 DO 800 j = 1, 10
          +
          3087750 CONTINUE
          +
          3088 IF (mstack(1,mk).EQ.1797) THEN
          +
          3089 GO TO 2020
          +
          3090 ELSE IF (mstack(1,mk).EQ.6432) THEN
          +
          3091C HI/LO MODE
          +
          3092 isw = isw + 1
          +
          3093 ELSE IF (mstack(1,mk).EQ.6434) THEN
          +
          3094C Q/C TEST
          +
          3095 isw = isw + 2
          +
          3096 ELSE IF (mstack(1,mk).EQ.2070) THEN
          +
          3097 IF (icon.EQ.1) THEN
          +
          3098C FIRST PASS - U,V CONSENSUS
          +
          3099 isw = isw + 4
          +
          3100 icon = icon + 1
          +
          3101 ELSE
          +
          3102C SECOND PASS - W CONSENSUS
          +
          3103 isw = isw + 64
          +
          3104 END IF
          +
          3105 ELSE IF (mstack(1,mk).EQ.2819) THEN
          +
          3106C 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
          +
          3116C 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
          +
          3125C SAVE DD DESCRIPTOR
          +
          3126 jk = jk + 1
          +
          3127 kprofl(jk) = 2817
          +
          3128 kprof2(jk) = 0
          +
          3129 kset2(jk) = 32767
          +
          3130C 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
          +
          3140C PRINT *,' ',NDIR,NSPD
          +
          3141C SAVE DD DESCRIPTOR
          +
          3142 jk = jk + 1
          +
          3143 kprofl(jk) = 2817
          +
          3144 kprof2(jk) = 0
          +
          3145 kset2(jk) = ndir
          +
          3146C IF (I.EQ.1) THEN
          +
          3147C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
          +
          3148C ENDIF
          +
          3149C SAVE FFF DESCRIPTOR
          +
          3150 jk = jk + 1
          +
          3151 kprofl(jk) = 2818
          +
          3152 kprof2(jk) = 1
          +
          3153 kset2(jk) = nspd
          +
          3154C IF (I.EQ.1) THEN
          +
          3155C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
          +
          3156C ENDIF
          +
          3157 END IF
          +
          3158 mk = mk + 1
          +
          3159 GO TO 800
          +
          3160 END IF
          +
          3161 ELSE IF (mstack(1,mk).EQ.2866) THEN
          +
          3162C SPEED STD DEVIATION
          +
          3163 isw = isw + 32
          +
          3164C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
          +
          3165 ELSE IF (mstack(1,mk).EQ.5568) THEN
          +
          3166C SIGNAL POWER
          +
          3167 isw = isw + 128
          +
          3168 ELSE IF (mstack(1,mk).EQ.2822) THEN
          +
          3169C W COMPONENT
          +
          3170 isw = isw + 256
          +
          3171 ELSE IF (mstack(1,mk).EQ.2867) THEN
          +
          3172C VERT STD DEVIATION
          +
          3173 isw = isw + 512
          +
          3174CVVVVVCHANGE#1 FIX BY KEYSER -- 12/06/1994
          +
          3175C NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR.
          +
          3176C ARE MISSING. WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY
          +
          3177C MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT
          +
          3178CDAK ELSE
          +
          3179 ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
          +
          3180CAAAAACHANGE#1 FIX BY KEYSER -- 12/06/1994
          +
          3181 mk = mk + 1
          +
          3182 GO TO 750
          +
          3183 END IF
          +
          3184 jk = jk + 1
          +
          3185C SAVE DESCRIPTOR
          +
          3186 kprofl(jk) = mstack(1,mk)
          +
          3187C SAVE SCALE
          +
          3188 kprof2(jk) = mstack(2,mk)
          +
          3189C SAVE DATA
          +
          3190 kset2(jk) = kdata(i,mk)
          +
          3191 mk = mk + 1
          +
          3192C 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
          +
          3200C MOVE DATA BACK INTO KDATA ARRAY
          +
          3201 DO 5000 ll = 1, jk
          +
          3202C DATA
          +
          3203 kdata(i,ll) = kset2(ll)
          +
          3204 5000 CONTINUE
          +
          3205 3000 CONTINUE
          +
          3206 DO 5005 ll = 1, jk
          +
          3207C DESCRIPTOR
          +
          3208 mstack(1,ll) = kprofl(ll)
          +
          3209C SCALE
          +
          3210 mstack(2,ll) = kprof2(ll)
          +
          3211C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
          +
          3212C 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
          +
          3217C> @brief Expand data/descriptor replication
          +
          3218C> @author Bill Cavanaugh @date 1993-05-12
          +
          3219
          +
          3220C> Expand data and descriptor strings
          +
          3221C>
          +
          3222C> Program history log:
          +
          3223C> - Bill Cavanaugh 1993-05-12
          +
          3224C>
          +
          3225C> @param[in] IPTR See w3fi88 routine docblock
          +
          3226C> @param[in] IDENT See w3fi88 routine docblock
          +
          3227C> @param[in] MAXR Maximum number of reports/subsets that may be
          +
          3228C> contained in a bufr message
          +
          3229C> @param[in] MAXD Maximum number of descriptor combinations that
          +
          3230C> may be processed; upper air data and some satellite
          +
          3231C> data require a value for maxd of 1700, but for most
          +
          3232C> other data a value for maxd of 500 will suffice
          +
          3233C> @param[inout] KDATA Array containing decoded reports from bufr message.
          +
          3234C> kdata(report number,parameter number)
          +
          3235C> (report number limited to value of input argument
          +
          3236C> maxr and parameter number limited to value of input
          +
          3237C> argument maxd)
          +
          3238C> @param[inout] MSTACK List of descriptors and scale values
          +
          3239C> @param KNR
          +
          3240C> @param LDATA
          +
          3241C> @param LSTACK
          +
          3242C>
          +
          3243C> Error return:
          +
          3244C> - IPTR(1)
          +
          3245C>
          +
          3246C> @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(*)
          +
          3255C
          +
          3256 SAVE
          +
          3257C
          +
          3258C PRINT *,' DATA/DESCRIPTOR REPLICATION '
          +
          3259 DO 1000 i = 1, knr(1)
          +
          3260C IF NOT REPLICATION DESCRIPTOR
          +
          3261 IF ((mstack(1,i)/16384).NE.1) THEN
          +
          3262 GO TO 1000
          +
          3263 END IF
          +
          3264C IF DELAYED REPLICATION DESCRIPTOR
          +
          3265 IF (mod(mstack(1,i),256).EQ.0) THEN
          +
          3266C SAVE KX VALUE (NR DESC'S TO REPLICATE)
          +
          3267 kx = mod((mstack(1,i)/256),64)
          +
          3268C IF NEXT DESC IS NOT 7947 OR 7948
          +
          3269C (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
          +
          3271C SKIP IT
          +
          3272 GO TO 1000
          +
          3273 END IF
          +
          3274C GET NR REPS FROM KDATA
          +
          3275 nrreps = kdata(1,i+1)
          +
          3276 last = i + 1 + kx
          +
          3277C 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
          +
          3285C 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
          +
          3298C 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
          +
          3305C 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)
          +
          3315C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          3316C . . . .
          +
          3317C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3
          +
          3318C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23
          +
          3319C
          +
          3320C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO
          +
          3321C THE DESCRIPTORS NEEDED FOR THIS MESSAGE
          +
          3322C
          +
          3323C PROGRAM HISTORY LOG:
          +
          3324C 93-05-12 CAVANAUGH
          +
          3325C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
          +
          3326C
          +
          3327C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
          +
          3328C * IRF1SW,NEWREF,ITBLD,ITBLD2,
          +
          3329C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
          +
          3330C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
          +
          3331C INPUT ARGUMENT LIST:
          +
          3332C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
          +
          3333C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
          +
          3334C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES
          +
          3335C IUNITB -
          +
          3336C IUNITD -
          +
          3337C ISTACK -
          +
          3338C NRDESC -
          +
          3339C KFXY2 -
          +
          3340C ANAME2 -
          +
          3341C AUNIT2 -
          +
          3342C ISCAL2 -
          +
          3343C IRFVL2 -
          +
          3344C IWIDE2 -
          +
          3345C IRF1SW -
          +
          3346C NEWREF -
          +
          3347C ITBLD2 -
          +
          3348C
          +
          3349C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
          +
          3350C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
          +
          3351C KDATA(REPORT NUMBER,PARAMETER NUMBER)
          +
          3352C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
          +
          3353C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
          +
          3354C ARGUMENT MAXD)
          +
          3355C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES
          +
          3356C KFXY1 -
          +
          3357C ANAME1 -
          +
          3358C AUNIT1 -
          +
          3359C ISCAL1 -
          +
          3360C IRFVL1 -
          +
          3361C IWIDE1 -
          +
          3362C ITBLD -
          +
          3363C
          +
          3364C SUBPROGRAMS CALLED:
          +
          3365C LIBRARY:
          +
          3366C W3LIB -
          +
          3367C
          +
          3368C REMARKS: ERROR RETURN:
          +
          3369C IPTR(1) =
          +
          3370C
          +
          3371C ATTRIBUTES:
          +
          3372C LANGUAGE: FORTRAN 77
          +
          3373C MACHINE: NAS
          +
          3374C
          +
          3375C$$$
          +
          3376C ..................................................
          +
          3377C
          +
          3378C NEW BASE TABLE B
          +
          3379C MAY BE A COMBINATION OF MASTER TABLE B
          +
          3380C AND ANCILLARY TABLE B
          +
          3381C
          +
          3382 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
          +
          3383 CHARACTER*40 ANAME1(*)
          +
          3384 CHARACTER*24 AUNIT1(*)
          +
          3385C ..................................................
          +
          3386C
          +
          3387C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
          +
          3388C
          +
          3389 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
          +
          3390 CHARACTER*64 ANAME2(*)
          +
          3391 CHARACTER*24 AUNIT2(*)
          +
          3392C ..................................................
          +
          3393C
          +
          3394C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
          +
          3395C
          +
          3396 INTEGER ITBLD2(20,*)
          +
          3397C ..................................................
          +
          3398C
          +
          3399C NEW BASE TABLE D
          +
          3400C
          +
          3401 INTEGER ITBLD(20,*)
          +
          3402C ..................................................
          +
          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
          +
          3408C
          +
          3409 SAVE
          +
          3410C
          +
          3411C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS
          +
          3412C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING
          +
          3413C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES.
          +
          3414C
          +
          3415C-----------------------------------------------------------
          +
          3416C PRINT *,'ENTER FI8812'
          +
          3417C
          +
          3418 DO 10 i = 1, 16384
          +
          3419 kptrb(i) = -1
          +
          3420 10 CONTINUE
          +
          3421C
          +
          3422C
          +
          3423C
          +
          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
          +
          3430C
          +
          3431C READ IN TABLE B
          +
          3432 print *,'FI8812 - READING TABLE B'
          +
          3433 rewind iunitb
          +
          3434 i = 1
          +
          3435 4000 CONTINUE
          +
          3436C
          +
          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
          +
          3444C PRINT *,MF,MX,MY,KFXY1(I)
          +
          3445 5000 CONTINUE
          +
          3446 kptrb(kfxy1(i)) = i
          +
          3447 iptr(14) = i
          +
          3448C PRINT *,I
          +
          3449C WRITE(6,21) MF,MX,MY,KFXY1(I),
          +
          3450C * (ANAME1(I)(K:K),K=1,40),
          +
          3451C * (AUNIT1(I)(K:K),K=1,24),
          +
          3452C * 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
          +
          3457C ======================================================
          +
          3458 9999 CONTINUE
          +
          3459C 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)
          +
          3464C 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)
          +
          3469C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          3470C . . . .
          +
          3471C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
          +
          3472C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
          +
          3473C
          +
          3474C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A
          +
          3475C DECODED BUFR MESSAGE.
          +
          3476C
          +
          3477C PROGRAM HISTORY LOG:
          +
          3478C 94-03-04 CAVANAUGH
          +
          3479C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
          +
          3480C
          +
          3481C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,
          +
          3482C * KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
          +
          3483C INPUT ARGUMENT LIST:
          +
          3484C IPTR
          +
          3485C MAXR
          +
          3486C MAXD
          +
          3487C MSTACK
          +
          3488C KDATA
          +
          3489C IDENT
          +
          3490C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
          +
          3491C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
          +
          3492C
          +
          3493C OUTPUT ARGUMENT LIST:
          +
          3494C IUNITB
          +
          3495C ITBLD1
          +
          3496C ANAME1
          +
          3497C AUNIT1
          +
          3498C KFXY1
          +
          3499C ISCAL1
          +
          3500C IRFVL1
          +
          3501C IWIDE1
          +
          3502C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
          +
          3503C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
          +
          3504C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
          +
          3505C
          +
          3506C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
          +
          3507C
          +
          3508C ATTRIBUTES:
          +
          3509C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
          +
          3510C MACHINE: NAS, CYBER, WHATEVER
          +
          3511C
          +
          3512C$$$
          +
          3513C ..................................................
          +
          3514C
          +
          3515C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
          +
          3516C
          +
          3517 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*)
          +
          3518 CHARACTER*40 ANAME1(*)
          +
          3519 CHARACTER*24 AUNIT1(*)
          +
          3520C ..................................................
          +
          3521C
          +
          3522C TABLE D
          +
          3523C
          +
          3524 INTEGER ITBLD(20,*)
          +
          3525C ..................................................
          +
          3526 CHARACTER*32 SPACES
          +
          3527 CHARACTER*8 ASCCHR
          +
          3528 CHARACTER*32 AAAA
          +
          3529C
          +
          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
          +
          3542C ==============================================================
          +
          3543C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21)
          +
          3544C BUILD SPACE CONSTANT
          +
          3545C INITIALIZE ENTRY COUNTS
          +
          3546 ixa = 0
          +
          3547C NUMBER IN TABLE B
          +
          3548 ixb = iptr(21)
          +
          3549C
          +
          3550C
          +
          3551C SET FOR COMPRESSED OR NON COMPRESSED
          +
          3552C PROCESSING
          +
          3553C
          +
          3554C 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
          +
          3560C PRINT *,'FI8813 - 3, JK=',JK
          +
          3561C
          +
          3562C
          +
          3563C START PROCESSING ENTRIES
          +
          3564C PRINT *,'START PROCESSING ENTRIES'
          +
          3565C
          +
          3566C DO 995 I = 1, IPTR(31)
          +
          3567C IF (IPTR(45).EQ.4) THEN
          +
          3568C PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
          +
          3569C9958 FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4)
          +
          3570C ELSE
          +
          3571C PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
          +
          3572C9959 FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8)
          +
          3573C END IF
          +
          3574C 995 CONTINUE
          +
          3575C PRINT *,' '
          +
          3576 i = 0
          +
          3577 iextra = 0
          +
          3578 1000 CONTINUE
          +
          3579C
          +
          3580C SET POINTER TO CORRECT DATA POSITION
          +
          3581C I IS THE NUMBER OF DESCRIPTORS
          +
          3582C IEXTRA IS THE NUMBER OF WORDS ADDED
          +
          3583C FOR TEXT DATA
          +
          3584C
          +
          3585 i = i + 1
          +
          3586 IF (i.GT.iptr(31)) THEN
          +
          3587C RETURN IF COMPLETED SEARCH
          +
          3588 GO TO 9000
          +
          3589 END IF
          +
          3590 klk = i + iextra
          +
          3591C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK)
          +
          3592C
          +
          3593C IF TABLE A ENTRY OR EDITION NUMBER
          +
          3594C OR IF DESCRIPTOR IS NOT IN CLASS 0
          +
          3595C SKIP OVER
          +
          3596C
          +
          3597 IF (mstack(1,klk).EQ.1) THEN
          +
          3598C PRINT *,'A ENTRY'
          +
          3599 GO TO 1000
          +
          3600 ELSE IF (mstack(1,klk).EQ.2) THEN
          +
          3601C 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
          +
          3605C 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)
          +
          3610C 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
          +
          3619C PRINT *,MSTACK(1,KLK),' NOT CLASS 0'
          +
          3620 GO TO 1000
          +
          3621 END IF
          +
          3622C
          +
          3623C MUST FIND F X Y KEY FOR TABLE B
          +
          3624C OR TABLE D ENTRY
          +
          3625C
          +
          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)
          +
          3635C 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
          +
          3652C PRINT *,'FIND KEY'
          +
          3653C
          +
          3654C MUST INCLUDE PROCESSING FOR COMPRESSED DATA
          +
          3655C
          +
          3656C BUILD DESCRIPTOR SEGMENT
          +
          3657C
          +
          3658 IF (mstack(1,klk).EQ.10) THEN
          +
          3659 CALL fi8814 (kdata(iz,klk),1,mf,ierr,iptr)
          +
          3660C 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)
          +
          3664C 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)
          +
          3668C PRINT *,'Y =',MY,KDATA(IZ,KLK)
          +
          3669 keyset = ior(keyset,1)
          +
          3670 END IF
          +
          3671C PRINT *,' KEYSET =',KEYSET
          +
          3672 i = i + 1
          +
          3673 GO TO 10
          +
          3674 END IF
          +
          3675 IF (keyset.EQ.7) THEN
          +
          3676C PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY
          +
          3677C
          +
          3678C TEST NEXT DESCRIPTOR FOR TABLE B
          +
          3679C OR TABLE D ENTRY, PROCESS ACCORDINGLY
          +
          3680C
          +
          3681 klk = i + iextra
          +
          3682C 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
          +
          3686C 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
          +
          3690C 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
          +
          3695C I = I + 1
          +
          3696C IF (I.GT.IPTR(31)) THEN
          +
          3697C GO TO 9000
          +
          3698C END IF
          +
          3699C GO TO 10
          +
          3700 END IF
          +
          3701 GO TO 1000
          +
          3702C ==================================================================
          +
          3703 200 CONTINUE
          +
          3704 ibflag = 1
          +
          3705 20 CONTINUE
          +
          3706 klk = i + iextra
          +
          3707C 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'
          +
          3710C ===============================================================
          +
          3711 ELSE IF (mstack(1,klk).EQ.13) THEN
          +
          3712C PRINT *,'13 NAME',KLK
          +
          3713C
          +
          3714C ELEMENT NAME PART 1 - 32 BYTES
          +
          3715C 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
          +
          3722C 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)
          +
          3729C ===============================================================
          +
          3730 ELSE IF (mstack(1,klk).EQ.14) THEN
          +
          3731C PRINT *,'14 NAME2',KLK
          +
          3732C
          +
          3733C ELEMENT NAME PART 2 - 32 BYTES
          +
          3734C
          +
          3735C 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
          +
          3742C 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)
          +
          3749C ===============================================================
          +
          3750 ELSE IF (mstack(1,klk).EQ.15) THEN
          +
          3751C PRINT *,'15 UNITS',KLK
          +
          3752C
          +
          3753C UNITS NAME - 24 BYTES
          +
          3754C
          +
          3755C 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
          +
          3762C 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)
          +
          3769C ===============================================================
          +
          3770 ELSE IF (mstack(1,klk).EQ.16) THEN
          +
          3771C PRINT *,'16 SCALE SIGN'
          +
          3772C
          +
          3773C SCALE SIGN - 1 BYTE
          +
          3774C 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
          +
          3782C ===============================================================
          +
          3783 ELSE IF (mstack(1,klk).EQ.17) THEN
          +
          3784C PRINT *,'17 SCALE',KLK
          +
          3785C
          +
          3786C SCALE - 3 BYTES
          +
          3787C
          +
          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)
          +
          3797C ===============================================================
          +
          3798 ELSE IF (mstack(1,klk).EQ.18) THEN
          +
          3799C PRINT *,'18 REFERENCE SCALE',KLK
          +
          3800C
          +
          3801C REFERENCE SIGN - 1 BYTE
          +
          3802C 0 = POS, 1 = NEG
          +
          3803C
          +
          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
          +
          3811C ===============================================================
          +
          3812 ELSE IF (mstack(1,klk).EQ.19) THEN
          +
          3813C PRINT *,'19 REFERENCE VALUE',KLK
          +
          3814C
          +
          3815C REFERENCE VALUE - 10 BYTES/ 3 WDS
          +
          3816C
          +
          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)
          +
          3834C DO 261 IZ = 1, JK
          +
          3835C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ)
          +
          3836C 261 CONTINUE
          +
          3837 ibflag = ior(ibflag,4)
          +
          3838C ===============================================================
          +
          3839 ELSE
          +
          3840C PRINT *,'20 WIDTH',KLK
          +
          3841C
          +
          3842C ELEMENT DATA WIDTH - 3 BYTES
          +
          3843C
          +
          3844C DO 27 LL = 1, 24, IPTR(45)
          +
          3845 klk = i + iextra
          +
          3846C 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
          +
          3855C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ)
          +
          3856 GO TO 9000
          +
          3857 END IF
          +
          3858C 270 CONTINUE
          +
          3859C 27 CONTINUE
          +
          3860 ibflag = ior(ibflag,2)
          +
          3861 END IF
          +
          3862C NO, IT ISN'T
          +
          3863C
          +
          3864C IF THERE ARE ENOUGH OF THE ELEMENTS
          +
          3865C NECESSARY TO ACCEPT A TABLE B ENTRY
          +
          3866C
          +
          3867C PRINT *,' IBFLAG =',IBFLAG
          +
          3868 IF (ibflag.EQ.127) THEN
          +
          3869C PRINT *,'COMPLETE TABLE B ENTRY'
          +
          3870C HAVE A COMPLETE TABLE B ENTRY
          +
          3871 ixb = ixb + 1
          +
          3872C PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB)
          +
          3873C PRINT *,' ',AUNIT1(IXB),ISCAL1(IXB),
          +
          3874C * IRFVL1(IXB),IWIDE1(IXB)
          +
          3875 iptr(21) = ixb
          +
          3876 GO TO 1000
          +
          3877 END IF
          +
          3878 i = i + 1
          +
          3879C
          +
          3880C CHECK NEXT DESCRIPTOR
          +
          3881C
          +
          3882 IF (i.GT.iptr(31)) THEN
          +
          3883C RETURN IF COMPLETED SEARCH
          +
          3884 GO TO 9000
          +
          3885 END IF
          +
          3886 GO TO 20
          +
          3887C ==================================================================
          +
          3888 300 CONTINUE
          +
          3889 iseq = 0
          +
          3890 ijk = iptr(20) + 1
          +
          3891C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK
          +
          3892 30 CONTINUE
          +
          3893 klk = i + iextra
          +
          3894C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK)
          +
          3895 IF (mstack(1,klk).EQ.30) THEN
          +
          3896C FROM TEXT FIELD (6 BYTES/2 WDS)
          +
          3897C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE
          +
          3898C
          +
          3899C 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
          +
          3909C PRINT 349,KDATA(1,KQK)
          +
          3910 349 FORMAT (6x,z24)
          +
          3911C CONVERT TO INTEGER
          +
          3912 CALL fi8814(aaaa,6,ihold,ierr,iptr)
          +
          3913C 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
          +
          3919C CONSTRUCT SEQUENCE DESCRIPTOR
          +
          3920 iff = ihold / 100000
          +
          3921 ixx = mod((ihold/1300),100)
          +
          3922 iyy = mod(ihold,1300)
          +
          3923C INSERT IN PROPER SEQUENCE
          +
          3924 itbld(iseq+2,ijk) = 16384 * iff + 256 * ixx + iyy
          +
          3925C PRINT *,' SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK),
          +
          3926C * IFF,IXX,IYY
          +
          3927 iseq = iseq + 1
          +
          3928 IF (iseq.GT.18) THEN
          +
          3929 iptr(1) = 30
          +
          3930 RETURN
          +
          3931 END IF
          +
          3932C SET TO LOOK AT NEXT DESCRIPTOR
          +
          3933 i = i + 1
          +
          3934C IF (IPTR(45).LT.6) THEN
          +
          3935C IEXTRA = IEXTRA + 1
          +
          3936C END IF
          +
          3937 GO TO 30
          +
          3938 ELSE
          +
          3939C NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR
          +
          3940 IF (iseq.GE.1) THEN
          +
          3941C HAVE COMPLETE TABLE D ENTRY
          +
          3942 iptr(20) = iptr(20) + 1
          +
          3943C 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
          +
          3950C GO TEST NEXT DESCRIPTOR
          +
          3951 GO TO 1000
          +
          3952C ==================================================================
          +
          3953 9000 CONTINUE
          +
          3954C PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B'
          +
          3955C PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D'
          +
          3956C DO 9050 L = 1, 16384
          +
          3957C IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L)
          +
          3958C9050 CONTINUE
          +
          3959C IF (I.GE.IPTR(31)) THEN
          +
          3960C
          +
          3961C FILE FOR MODIFIED TABLE B OUTPUT
          +
          3962 numnut = iunitb + 1
          +
          3963 rewind numnut
          +
          3964C
          +
          3965C 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)
          +
          3970C WRITE (6,2001)JF,JX,JY,ANAME1(KB),
          +
          3971C * 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)
          +
          3978C
          +
          3979 endfile numnut
          +
          3980C
          +
          3981 IF (iptr(20).NE.0) THEN
          +
          3982C PRINT OUT TABLE
          +
          3983C PRINT *,' HERE IS THE UPGRADED TABLE D'
          +
          3984C DO 3000 KB = 1, IPTR(20)
          +
          3985C PRINT 3001,KB,(ITBLD(K,KB),K=1,15)
          +
          3986C3000 CONTINUE
          +
          3987C3001 FORMAT (16(1X,I5))
          +
          3988 END IF
          +
          3989C EXIT ROUTINE, ALL DONE WITH PASS
          +
          3990C END IF
          +
          3991 RETURN
          +
          3992 END
          +
          3993 SUBROUTINE fi8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
          +
          3994C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          3995C . . . .
          +
          3996C SUBPROGRAM: FI8814 CONVERT TEXT TO INTEGER
          +
          3997C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
          +
          3998C
          +
          3999C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE
          +
          4000C
          +
          4001C PROGRAM HISTORY LOG:
          +
          4002C 94-03-04 CAVANAUGH
          +
          4003C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
          +
          4004C
          +
          4005C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
          +
          4006C INPUT ARGUMENT LIST:
          +
          4007C ASCCHR -
          +
          4008C NPOS -
          +
          4009C NEWVAL -
          +
          4010C IERR -
          +
          4011C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
          +
          4012C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
          +
          4013C
          +
          4014C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
          +
          4015C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
          +
          4016C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
          +
          4017C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
          +
          4018C
          +
          4019C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
          +
          4020C DDNAME1 - GENERIC NAME & CONTENT
          +
          4021C
          +
          4022C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
          +
          4023C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
          +
          4024C FT06F001 - INCLUDE IF ANY PRINTOUT
          +
          4025C
          +
          4026C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
          +
          4027C
          +
          4028C ATTRIBUTES:
          +
          4029C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
          +
          4030C MACHINE: NAS, CYBER, WHATEVER
          +
          4031C
          +
          4032C$$$
          +
          4033 INTEGER IERR, IHOLD, IPTR(*)
          +
          4034 CHARACTER*8 AHOLD
          +
          4035 CHARACTER*64 ASCCHR
          +
          4036 EQUIVALENCE (IHOLD,AHOLD)
          +
          4037
          +
          4038 SAVE
          +
          4039C ----------------------------------------------------------
          +
          4040 IERR = 0
          +
          4041 newval = 0
          +
          4042 iflag = 0
          +
          4043C
          +
          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
          +
          4052C 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
          +
          4064C 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)
          +
          4080C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          4081C . . . .
          +
          4082C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
          +
          4083C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
          +
          4084C
          +
          4085C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE
          +
          4086C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE.
          +
          4087C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE
          +
          4088C
          +
          4089C PROGRAM HISTORY LOG:
          +
          4090C 94-03-04 CAVANAUGH
          +
          4091C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
          +
          4092C
          +
          4093C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
          +
          4094C * ANAME3,AUNIT3,
          +
          4095C * ISCAL3,IRFVL3,IWIDE3,
          +
          4096C * KEYSET,IBFLAG,IERR)
          +
          4097C INPUT ARGUMENT LIST:
          +
          4098C IPTR -
          +
          4099C MAXR -
          +
          4100C MAXD -
          +
          4101C MSTACK -
          +
          4102C KDATA -
          +
          4103C IDENT -
          +
          4104C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
          +
          4105C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
          +
          4106C
          +
          4107C OUTPUT ARGUMENT LIST:
          +
          4108C ANAME3 -
          +
          4109C AUNIT3 -
          +
          4110C KFXY3 -
          +
          4111C ISCAL3 -
          +
          4112C IRFVL3 -
          +
          4113C IWIDE3 -
          +
          4114C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
          +
          4115C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
          +
          4116C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
          +
          4117C
          +
          4118C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
          +
          4119C
          +
          4120C ATTRIBUTES:
          +
          4121C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
          +
          4122C MACHINE: NAS, CYBER
          +
          4123C
          +
          4124C$$$
          +
          4125 CHARACTER*64 ANAME3(*),SPACES
          +
          4126 CHARACTER*24 AUNIT3(*)
          +
          4127C
          +
          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
          +
          4138C ==============================================================
          +
          4139C PRINT *,'FI8815'
          +
          4140 IEXTRA = 0
          +
          4141C BUILD SPACE CONSTANT
          +
          4142 do 1 i = 1, 64
          +
          4143 spaces(i:i) = ' '
          +
          4144 1 CONTINUE
          +
          4145C INITIALIZE ENTRY COUNTS
          +
          4146 ixa = 0
          +
          4147 ixb = 0
          +
          4148 ixd = 0
          +
          4149C
          +
          4150C SET FOR COMPRESSED OR NON COMPRESSED
          +
          4151C PROCESSING
          +
          4152C
          +
          4153 IF (ident(16).EQ.0) THEN
          +
          4154 jk = 1
          +
          4155 ELSE
          +
          4156 jk = ident(14)
          +
          4157 END IF
          +
          4158C
          +
          4159C CLEAR NECESSARY ENTRIES
          +
          4160C
          +
          4161 DO 2 iy = 1, jk
          +
          4162C
          +
          4163C CLEAR NEXT TABLE B ENTRY
          +
          4164C
          +
          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
          +
          4174C
          +
          4175C START PROCESSING ENTRIES
          +
          4176C
          +
          4177 i = 0
          +
          4178 1000 CONTINUE
          +
          4179C
          +
          4180C SET POINTER TO CORRECT DATA POSITION
          +
          4181C
          +
          4182 k = i + iextra
          +
          4183C
          +
          4184C MUST FIND F X Y KEY FOR TABLE B
          +
          4185C OR TABLE D ENTRY
          +
          4186C
          +
          4187 IF (jdesc.GE.10.AND.jdesc.LE.12) THEN
          +
          4188 10 CONTINUE
          +
          4189C
          +
          4190C BUILD DESCRIPTOR SEGMENT
          +
          4191C
          +
          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
          +
          4208C ==================================================================
          +
          4209 ELSE IF (jdesc.GE.13.AND.jdesc.LE.20) THEN
          +
          4210 DO 250 iz = 1, jk
          +
          4211 IF (jdesc.EQ.13) THEN
          +
          4212C
          +
          4213C ELEMENT NAME PART 1 - 32 BYTES/8 WDS
          +
          4214C
          +
          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
          +
          4218C
          +
          4219C ELEMENT NAME PART 2 - 32 BYTES/8 WDS
          +
          4220C
          +
          4221 CALL gbytes(aname3(ixb+iz)(33:33),kdata(k,iz),0,32,0,8)
          +
          4222 ELSE IF (jdesc.EQ.15) THEN
          +
          4223C
          +
          4224C UNITS NAME - 24 BYTES/6 WDS
          +
          4225C
          +
          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
          +
          4229C
          +
          4230C UNITS SCALE SIGN - 1 BYTE/ 1 WD
          +
          4231C 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
          +
          4238C
          +
          4239C UNITS SCALE - 3 BYTES/ 1 WD
          +
          4240C
          +
          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
          +
          4249C
          +
          4250C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD
          +
          4251C 0 = POS, 1 = NEG
          +
          4252C
          +
          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
          +
          4259C
          +
          4260C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS
          +
          4261C
          +
          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
          +
          4270C
          +
          4271C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD
          +
          4272C
          +
          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
          +
          4283C ==================================================================
          +
          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)
          +
          4290C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          4291C . . . .
          +
          4292C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES
          +
          4293C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
          +
          4294C
          +
          4295C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE
          +
          4296C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS
          +
          4297C
          +
          4298C PROGRAM HISTORY LOG:
          +
          4299C YY-MM-DD CAVANAUGH
          +
          4300C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
          +
          4301C
          +
          4302C USAGE: CALL FI8818(IPTR,
          +
          4303C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
          +
          4304C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
          +
          4305C INPUT ARGUMENT LIST:
          +
          4306C IPTR -
          +
          4307C KFXY1 -
          +
          4308C ANAME1 -
          +
          4309C AUNIT1 -
          +
          4310C ISCAL1 -
          +
          4311C IRFVL1 -
          +
          4312C IWIDE1 -
          +
          4313C KFXY2 -
          +
          4314C ANAME2 -
          +
          4315C AUNIT2 -
          +
          4316C ISCAL2 -
          +
          4317C IRFVL2 -
          +
          4318C IWIDE2 -
          +
          4319C
          +
          4320C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
          +
          4321C IPTR -
          +
          4322C KFXY1 -
          +
          4323C ANAME1 -
          +
          4324C AUNIT1 -
          +
          4325C ISCAL1 -
          +
          4326C IRFVL1 -
          +
          4327C IWIDE1 -
          +
          4328C
          +
          4329C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
          +
          4330C
          +
          4331C ATTRIBUTES:
          +
          4332C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
          +
          4333C MACHINE: NAS, CYBER, WHATEVER
          +
          4334C
          +
          4335C$$$
          +
          4336C ..................................................
          +
          4337C
          +
          4338C NEW BASE TABLE B
          +
          4339C MAY BE A COMBINATION OF MASTER TABLE B
          +
          4340C AND ANCILLARY TABLE B
          +
          4341C
          +
          4342 INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
          +
          4343 CHARACTER*40 ANAME1(*)
          +
          4344 CHARACTER*24 AUNIT1(*)
          +
          4345C ..................................................
          +
          4346C
          +
          4347C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
          +
          4348C
          +
          4349 INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
          +
          4350 CHARACTER*64 ANAME2(*)
          +
          4351 CHARACTER*24 AUNIT2(*)
          +
          4352C ..................................................
          +
          4353 INTEGER IPTR(*),KPTRB(*)
          +
          4354
          +
          4355 SAVE
          +
          4356C
          +
          4357C SET UP POINTERS
          +
          4358C PRINT *,'FI8818-A',IPTR(21),IPTR(41)
          +
          4359 KAB = 1
          +
          4360 kb = 1
          +
          4361 1000 CONTINUE
          +
          4362C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21)
          +
          4363 IF (kb.GT.iptr(21)) THEN
          +
          4364C NO MORE MASTER ENTRIES
          +
          4365C PRINT *,'NO MORE MASTER ENTRIES'
          +
          4366 IF (kab.GT.iptr(41)) THEN
          +
          4367 GO TO 5000
          +
          4368 END IF
          +
          4369C APPEND ANCILLARY ENTRY
          +
          4370 GO TO 2000
          +
          4371 ELSE IF (kb.LE.iptr(21)) THEN
          +
          4372C HAVE MORE MASTER ENTRIES
          +
          4373 IF (kab.GT.iptr(41)) THEN
          +
          4374C NO MORE ANCILLARY ENTRIES
          +
          4375 GO TO 5000
          +
          4376 END IF
          +
          4377 IF (kfxy2(kab).EQ.kfxy1(kb)) THEN
          +
          4378C REPLACE MASTER ENTRY
          +
          4379 GO TO 3000
          +
          4380 ELSE IF (kfxy2(kab).LT.kfxy1(kb)) THEN
          +
          4381C INSERT ANCILLARY ENTRY
          +
          4382 GO TO 2000
          +
          4383 ELSE IF (kfxy2(kab).GT.kfxy1(kb)) THEN
          +
          4384C 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)
          +
          4392C 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)
          +
          4399C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED'
          +
          4400 kab = kab + 1
          +
          4401 GO TO 1000
          +
          4402 3000 CONTINUE
          +
          4403C 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)
          +
          4410C 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
          +
          4416C PROCESSING COMPLETE
          +
          4417C PRINT *,'FI8818-B',IPTR(21),IPTR(41)
          +
          4418C DO 6000 I = 1, IPTR(21)
          +
          4419C PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I)
          +
          4420C6000 CONTINUE
          +
          4421 RETURN
          +
          4422 END
          +
          4423 SUBROUTINE fi8819(IPTR,ITBLD,ITBLD2,KPTRD)
          +
          4424C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          4425C . . . .
          +
          4426C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D
          +
          4427C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
          +
          4428C
          +
          4429C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD
          +
          4430C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL.
          +
          4431C
          +
          4432C PROGRAM HISTORY LOG:
          +
          4433C YY-MM-DD CAVANAUGH
          +
          4434C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
          +
          4435C
          +
          4436C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
          +
          4437C INPUT ARGUMENT LIST:
          +
          4438C IPTR -
          +
          4439C ITBLD -
          +
          4440C ITBLD2 -
          +
          4441C
          +
          4442C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
          +
          4443C IPTR -
          +
          4444C ITBLD -
          +
          4445C
          +
          4446C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
          +
          4447C
          +
          4448C ATTRIBUTES:
          +
          4449C LANGUAGE: FORTRAN 77
          +
          4450C MACHINE: NAS, CYBER
          +
          4451C
          +
          4452C$$$
          +
          4453C ..................................................
          +
          4454C
          +
          4455C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
          +
          4456C
          +
          4457 INTEGER ITBLD2(20,*)
          +
          4458C ..................................................
          +
          4459C
          +
          4460C NEW BASE TABLE D
          +
          4461C
          +
          4462 INTEGER ITBLD(20,*)
          +
          4463C ..................................................
          +
          4464 INTEGER IPTR(*),KPTRD(*)
          +
          4465
          +
          4466 SAVE
          +
          4467C PRINT *,'FI8819-A',IPTR(20),IPTR(42)
          +
          4468C 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
          +
          4477C =======================================================
          +
          4478 iptr(42) = 0
          +
          4479C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42)
          +
          4480C DO 6000 I = 1, IPTR(20)
          +
          4481C WRITE (6,6001)I,(ITBLD(J,I),J=1,20)
          +
          4482C6001 FORMAT(15(1X,I5))
          +
          4483C6000 CONTINUE
          +
          4484 RETURN
          +
          4485 END
          +
          4486 SUBROUTINE fi8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
          +
          4487C$$$ SUBPROGRAM DOCUMENTATION BLOCK
          +
          4488C . . . .
          +
          4489C SUBPROGRAM: FI8820 READ IN BUFR TABLE D
          +
          4490C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06
          +
          4491C
          +
          4492C ABSTRACT: READ IN BUFR TABLE D
          +
          4493C
          +
          4494C PROGRAM HISTORY LOG:
          +
          4495C 93-05-06 CAVANAUGH
          +
          4496C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
          +
          4497C
          +
          4498C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
          +
          4499C INPUT ARGUMENT LIST:
          +
          4500C IUNITD - UNIT NUMBER FOR TABLE D INPUT
          +
          4501C IPTR - ARRAY OF WORKING VALUES
          +
          4502C
          +
          4503C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
          +
          4504C ITBLD - ARRAY TO CONTAIN TABLE D
          +
          4505C
          +
          4506C REMARKS:
          +
          4507C
          +
          4508C ATTRIBUTES:
          +
          4509C LANGUAGE: FORTRAN 77
          +
          4510C MACHINE: NAS
          +
          4511C
          +
          4512C$$$
          +
          4513C ..................................................
          +
          4514C
          +
          4515C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
          +
          4516C
          +
          4517 INTEGER ITBLD2(20,*)
          +
          4518C ..................................................
          +
          4519C
          +
          4520C NEW BASE TABLE D
          +
          4521C
          +
          4522 INTEGER ITBLD(20,*)
          +
          4523C ..................................................
          +
          4524C
          +
          4525 INTEGER IHOLD(33),IPTR(*),KPTRD(*)
          +
          4526 LOGICAL MORE
          +
          4527
          +
          4528 SAVE
          +
          4529C
          +
          4530 MORE = .true.
          +
          4531 i = 0
          +
          4532C
          +
          4533C READ IN TABLE D, BUT JUST ONCE
          +
          4534C 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
          +
          4543C 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)
          +
          4546C BUILD KEY FROM MASTER D ENTRY
          +
          4547C 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
          +
          4566C WRITE (6,51)I,(ITBLD(L,I),L=1,15)
          +
          4567 51 FORMAT (7h tabled,16(1x,i5))
          +
          4568 GO TO 100
          +
          4569 ELSE
          +
          4570C 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
          +
          4578C
          +
          4579 9999 CONTINUE
          +
          4580C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D'
          +
          4581 RETURN
          +
          4582 END
          +
          gbyte
          subroutine gbyte(ipackd, iunpkd, noff, nbits)
          This is the fortran version of gbyte.
          Definition gbyte.f:27
          +
          gbytes
          subroutine gbytes(ipackd, iunpkd, noff, nbits, iskip, iter)
          Program history log:
          Definition gbytes.f:26
          +
          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
          +
          w3fc05
          subroutine w3fc05(u, v, dir, spd)
          Given the true (Earth oriented) wind components compute the wind direction and speed.
          Definition w3fc05.f:29
          +
          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
          +
          fi8808
          subroutine fi8808(iptr, iwork, lf, lx, ly, jdesc)
          Program history log:
          Definition w3fi88.f:2459
          +
          fi8804
          subroutine fi8804(iptr, msga, kdata, ivals, mstack, iwide1, irfvl1, iscal1, j, ll, jdesc, maxr, maxd)
          Process serial data.
          Definition w3fi88.f:1733
          +
          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
          +
          fi8803
          subroutine fi8803(iptr, ident, msga, kdata, ivals, mstack, iwide1, irfvl1, iscal1, j, jdesc, maxr, maxd)
          Process compressed data.
          Definition w3fi88.f:1414
          +
          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
          +
          fi8805
          subroutine fi8805(iptr, ident, msga, iwork, lx, ly, kdata, ll, knr, mstack, maxr, maxd)
          Process a replication descriptor.
          Definition w3fi88.f:1941
          +
          fi8807
          subroutine fi8807(iptr, iwork, itbld, itbld2, jdesc, kptrd)
          Process queue descriptor.
          Definition w3fi88.f:2372
          +
          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
          +
          fi8809
          subroutine fi8809(ident, mstack, kdata, iptr, maxr, maxd)
          Reformat profiler w hgt increments.
          Definition w3fi88.f:2517
          +
          fi8810
          subroutine fi8810(ident, mstack, kdata, iptr, maxr, maxd)
          Reformat profiler edition 2 data.
          Definition w3fi88.f:2911
          +
          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
          diff --git a/w3fi92_8f.html b/w3fi92_8f.html index 9a50d466..d648b736 100644 --- a/w3fi92_8f.html +++ b/w3fi92_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi92.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fi92.f File Reference
          +
          w3fi92.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          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.
           

          Detailed Description

          Build 80-char on 295 grib queue descriptor.

          @@ -107,8 +113,8 @@

          Definition in file w3fi92.f.

          Function/Subroutine Documentation

          - -

          ◆ w3fi92()

          + +

          ◆ w3fi92()

          @@ -117,31 +123,31 @@

          subroutine w3fi92 ( character*80  - LOC, + loc, character*6  - TTAAII, + ttaaii, integer, dimension(7)  - KARY, + kary, character*4  - KWBX, + kwbx, integer  - IERR  + ierr  @@ -153,12 +159,12 @@

          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().
          +
          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.
            • +
          • 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.
          @@ -201,7 +207,7 @@

          diff --git a/w3fi92_8f.js b/w3fi92_8f.js index a6e47b41..721a4689 100644 --- a/w3fi92_8f.js +++ b/w3fi92_8f.js @@ -1,4 +1,4 @@ var w3fi92_8f = [ - [ "w3fi92", "w3fi92_8f.html#a2e8b8ef3dcf66d40422987430e28545a", null ] + [ "w3fi92", "w3fi92_8f.html#a22888b37a35c7f9abe63dc5cfd743422", null ] ]; \ No newline at end of file diff --git a/w3fi92_8f_source.html b/w3fi92_8f_source.html index c9df7f69..c78d60b4 100644 --- a/w3fi92_8f_source.html +++ b/w3fi92_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fi92.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +
          @@ -76,228 +81,236 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fi92.f
          +
          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
          -
          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
          -
          w3ai39
          subroutine w3ai39(NFLD, N)
          translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
          Definition: w3ai39.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
          -
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Build 80-char on 295 grib queue descriptor.
          +
          3C> @author Bill Cavanaugh @date 1991-06-21
          +
          4
          +
          5C> Build 80 character queue descriptor using information
          +
          6C> supplied by user, placing the completed queue descriptor in the
          +
          7C> location specified by the user. (based on office note 295).
          +
          8C>
          +
          9C> @note This is a modified version of w3fi62() which adds the 'KWBX'
          +
          10C> parameter. This value will now be added to bytes 35-38 for all grib
          +
          11C> products. Queue desciptors for non-grib products will continue to be
          +
          12C> generated by w3fi62().
          +
          13C>
          +
          14C> Program history log:
          +
          15C> - Bill Cavanaugh 1991-06-21
          +
          16C> - Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that
          +
          17C> exceed 20000 bytes
          +
          18C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII
          +
          19C> character set computers
          +
          20C> - J. Smith 1995-10-16 Modified version of w3fi62() to add 'KWBX' to bytes
          +
          21C> 35-38 of queue descriptor.
          +
          22C> - Ralph Jones 1996-01-29 Preset ierr to zero.
          +
          23C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
          +
          24C>
          +
          25C> @param[in] TTAAII First 6 characters of wmo header
          +
          26C> @param[inout] KARY Integer array containing user information
          +
          27C> - 1 = Day of month
          +
          28C> - 2 = Hour of day
          +
          29C> - 3 = Hour * 100 + minute
          +
          30C> - 4 = Catalog number
          +
          31C> - 5 = Number of 80 byte increments
          +
          32C> - 6 = Number of bytes in last increment
          +
          33C> - 7 = Total size of message WMO header + body of message in bytes (not
          +
          34C> including queue descriptor)
          +
          35C> @param[in] KWBX 4 characters, representing the fcst model that the bulletin
          +
          36C> was derived from.
          +
          37C> @param[out] LOC Location to receive queue descriptor.
          +
          38C> @param[out] IERR Error return.
          +
          39C>
          +
          40C>
          +
          41C> @note If total size is entered (kary(7)) then kary(5) and kary(6) will be calculated.
          +
          42C> If kary(5) and kary(6) are provided then kary(7) will be ignored.
          +
          43C>
          +
          44C> @note Equivalence array loc to integer array so it starts on a word
          +
          45C> boundary for sbyte subroutine.
          +
          46C>
          +
          47C> Error returns:
          +
          48C> - IERR = 1 Total byte count and/or 80 byte increment count is missing. One
          +
          49C> or the other is required to complete the queue descriptor.
          +
          50C> - IERR = 2 Total size too small
          +
          51C>
          +
          52C> @author Bill Cavanaugh @date 1991-06-21
          +
          +
          53 SUBROUTINE w3fi92 (LOC,TTAAII,KARY,KWBX,IERR)
          +
          54C
          +
          55 INTEGER IHOLD(2)
          +
          56 INTEGER KARY(7),IERR
          +
          57C
          +
          58 LOGICAL IBM370
          +
          59C
          +
          60 CHARACTER*6 TTAAII,AHOLD
          +
          61 CHARACTER*80 LOC
          +
          62 CHARACTER*1 BLANK
          +
          63 CHARACTER*4 KWBX
          +
          64C
          +
          65 equivalence(ahold,ihold)
          +
          66C
          +
          67 SAVE
          +
          68C
          +
          69C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
          +
          70C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
          +
          71C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
          +
          72C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
          +
          73C SETS TO FIND IBM370 TYPE COMPUTER.
          +
          74C
          +
          75 DATA blank /' '/
          +
          76C ----------------------------------------------------------------
          +
          77C
          +
          78C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
          +
          79C
          +
          80 CALL w3fi01(lw)
          +
          81C
          +
          82C TEST FOR EBCDIC CHARACTER SET
          +
          83C
          +
          84 ibm370 = .false.
          +
          85 IF (mova2i(blank).EQ.64) THEN
          +
          86 ibm370 = .true.
          +
          87 END IF
          +
          88C
          +
          89 inofst = 0
          +
          90C 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
          +
          99C BYTES 17-20 INTEGER ZEROES
          +
          100 CALL sbyte (loc,0,inofst,32)
          +
          101 inofst = inofst + 32
          +
          102C IF TOTAL COUNT IS INCLUDED
          +
          103C THEN WILL DETERMINE THE NUMBER OF
          +
          104C 80 BYTE INCREMENTS AND WILL DETERMINE
          +
          105C 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
          +
          109C 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
          +
          126C BYTE 21-22 NR OF 80 BYTE INCREMENTS
          +
          127 CALL sbyte (loc,kary(5),inofst,16)
          +
          128 inofst = inofst + 16
          +
          129C BYTE 23 NR OF BYTES IN LAST INCREMENT
          +
          130 CALL sbyte (loc,kary(6),inofst,8)
          +
          131 inofst = inofst + 8
          +
          132C 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
          +
          137C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII
          +
          138 loc(29:34) = ttaaii(1:6)
          +
          139C
          +
          140C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
          +
          141C
          +
          142 IF (.NOT.ibm370) CALL w3ai39(loc(29:29),6)
          +
          143C
          +
          144 inofst = inofst + 48
          +
          145C BYTES 35-38 KWBX
          +
          146C
          +
          147 loc(35:38) = kwbx(1:4)
          +
          148C
          +
          149C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
          +
          150C
          +
          151 IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
          +
          152 inofst = inofst + 32
          +
          153C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
          +
          154C 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
          +
          167C 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
          +
          175C
          +
          176C ON CRAY 64 BIT COMPUTER
          +
          177C
          +
          178 ELSE
          +
          179 CALL sbyte (loc,ihold,inofst,40)
          +
          180 inofst = inofst + 40
          +
          181 END IF
          +
          182C
          +
          183C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
          +
          184C
          +
          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
          +
          192C 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
          +
          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
          +
          w3ai39
          subroutine w3ai39(nfld, n)
          translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
          Definition w3ai39.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
          +
          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
          diff --git a/w3fm07_8f.html b/w3fm07_8f.html index d0cade7a..e96e3482 100644 --- a/w3fm07_8f.html +++ b/w3fm07_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fm07.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fm07.f File Reference
          +
          w3fm07.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3fm07 (fin, fout, cwork, gamma, ncol, nrow)
           Smooths data on a rectangular grid using a nine-point smoothing operator.
           

          Detailed Description

          Nine-point smoother for rectangular grids.

          @@ -107,8 +113,8 @@

          Definition in file w3fm07.f.

          Function/Subroutine Documentation

          - -

          ◆ w3fm07()

          + +

          ◆ w3fm07()

          @@ -117,37 +123,37 @@

          subroutine w3fm07 ( real, dimension(ncol,nrow)  - FIN, + fin, real, dimension(ncol,nrow)  - FOUT, + fout, complex, dimension(ncol,*)  - CWORK, + cwork, complex  - GAMMA, + gamma,   - NCOL, + ncol,   - NROW  + nrow  @@ -183,7 +189,7 @@

          diff --git a/w3fm07_8f.js b/w3fm07_8f.js index 32533957..98cfb950 100644 --- a/w3fm07_8f.js +++ b/w3fm07_8f.js @@ -1,4 +1,4 @@ var w3fm07_8f = [ - [ "w3fm07", "w3fm07_8f.html#a3fb4f69f29d16715851691eae8cd482b", null ] + [ "w3fm07", "w3fm07_8f.html#a03b3b4ebb95c829f88ab858b6709cfd7", null ] ]; \ No newline at end of file diff --git a/w3fm07_8f_source.html b/w3fm07_8f_source.html index 2ac6e07c..c503c0d8 100644 --- a/w3fm07_8f_source.html +++ b/w3fm07_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fm07.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +
          @@ -76,130 +81,138 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fm07.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Nine-point smoother for rectangular grids.
          +
          3C> @author P. Chase @date 1975-04-01
          +
          4
          +
          5C> Smooths data on a rectangular grid using a nine-point
          +
          6C> smoothing operator.
          +
          7C>
          +
          8C> Program history log:
          +
          9C> P. Chase 1975-04-01
          +
          10C> Ralph Jones 1984-07-01 Change to ibm vs fortran
          +
          11C> Ralph Jones 1991-04-24 Change to cray cft77 fortran
          +
          12C>
          +
          13C> @param[in] FIN - Real size(ncol*nrow) array of data to be smoothed
          +
          14C> @param[in] CWORK - Real size(2*ncol*(nrow+2)) work array
          +
          15C> @param[in] GAMMA - Complex smoothing parameter. The imaginary part must
          +
          16C> be positive.
          +
          17C> @param[in] NCOL - Integer number of columns in the grid
          +
          18C> @param[in] NROW - Integer number of rows in the grid
          +
          19C> @param[out] FOUT - Real size(ncol*nrow) array of smoothed data. May
          +
          20C> be the same array as 'fin' or overlap it in any fashion.
          +
          21C>
          +
          22C> @author P. Chase @date 1975-04-01
          +
          +
          23 SUBROUTINE w3fm07(FIN,FOUT,CWORK,GAMMA,NCOL,NROW)
          +
          24C
          +
          25 REAL FIN(NCOL,NROW)
          +
          26 REAL FOUT(NCOL,NROW)
          +
          27C
          +
          28 COMPLEX CWORK(NCOL,*),GAMMA,GAMMX,GAMA,GAMB,GAMC
          +
          29C
          +
          30 gammx = gamma
          +
          31 xswtch = aimag(gammx)
          +
          32 ncolm = ncol-1
          +
          33 nrowm = nrow-1
          +
          34C
          +
          35C INITIALIZE WORK ARRAY. WORK ARRAY STARTS UP TWO ROWS SO IT CAN SMOOTH
          +
          36C DOWNWARD WITHOUT OVERLAP OF SMOOTHED AND UNSMOOTHED DATA
          +
          37C
          +
          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
          +
          49C
          +
          50C SET SMOOTHING OPERATORS
          +
          51C
          +
          52 30 gama = 0.50 * gammx * (1.0 - gammx)
          +
          53 gamb = 0.25 * gammx * gammx
          +
          54 gamc = 0.50 * gammx
          +
          55C
          +
          56C SMOOTH WORK ARRAY, PUTTING SMOOTHED POINTS DOWN TWO ROWS
          +
          57C
          +
          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
          +
          80C
          +
          81C IF IMAGINARY PART OF SMOOTHING PARAMETER IS NOT POSITIVE, DONE
          +
          82C
          +
          83 IF (xswtch .LE. 0.) GO TO 90
          +
          84C
          +
          85C OTHERWISE MOVE WORK ARRAY BACK UP TWO ROWS
          +
          86C
          +
          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
          +
          92C
          +
          93C SET SMOOTHING PARAMETER FOR CONJUGATE PASS AND GO DO IT
          +
          94C
          +
          95 gammx = conjg(gammx)
          +
          96 xswtch = aimag(gammx)
          +
          97 GO TO 30
          +
          98C
          +
          99C DONE. OUTPUT SMOOTH ARRAY
          +
          100C
          +
          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/w3fm08_8f.html b/w3fm08_8f.html index 0e475c29..677c7f76 100644 --- a/w3fm08_8f.html +++ b/w3fm08_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fm08.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fm08.f File Reference
          +
          w3fm08.f File Reference
          @@ -94,11 +100,11 @@

          Go to the source code of this file.

          - - - - + + +

          +

          Functions/Subroutines

          subroutine w3fm08 (A, Z, LI, LJ)
           Nine point smoother/desmoother. More...
           
          subroutine w3fm08 (a, z, li, lj)
           Nine point smoother/desmoother.
           

          Detailed Description

          Nine point smoother/desmoother.

          @@ -107,8 +113,8 @@

          Definition in file w3fm08.f.

          Function/Subroutine Documentation

          - -

          ◆ w3fm08()

          + +

          ◆ w3fm08()

          @@ -117,25 +123,25 @@

          subroutine w3fm08 ( real, dimension(li,lj)  - A, + a, real, dimension(li,lj)  - Z, + z,   - LI, + li,   - LJ  + lj  @@ -178,7 +184,7 @@

          diff --git a/w3fm08_8f.js b/w3fm08_8f.js index dcc80fb5..b19d8fd4 100644 --- a/w3fm08_8f.js +++ b/w3fm08_8f.js @@ -1,4 +1,4 @@ var w3fm08_8f = [ - [ "w3fm08", "w3fm08_8f.html#ad2e28d805a383d0025c930544cb36155", null ] + [ "w3fm08", "w3fm08_8f.html#ad5d5a454e8cdb3623fbdb0df3f44cbcc", null ] ]; \ No newline at end of file diff --git a/w3fm08_8f_source.html b/w3fm08_8f_source.html index adeb321d..bdbdfa94 100644 --- a/w3fm08_8f_source.html +++ b/w3fm08_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fm08.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +
          @@ -76,77 +81,85 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fm08.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Nine point smoother/desmoother.
          +
          3C> @author J. Howcroft @date 1971-02-01
          +
          4
          +
          5C> Nine point smoother/desmoother. Smoother pass uses an
          +
          6C> equivalent linear smoother with stencil (.25 .5 .25) and the
          +
          7C> desmoother uses stencil (-.25 1.5 -.25). Two grid interval waves
          +
          8C> are annihilated, four grid interval waves have a .75 response.
          +
          9C>
          +
          10C> Program history log:
          +
          11C> - J. Howcroft 1971-02-01
          +
          12C> - Ralph Jones 1984-07-01 Change to ibm vs fortran.
          +
          13C> - Ralph Jones 1994-07-27 Change to cray cft77 fortran.
          +
          14C>
          +
          15C> @param[inout] A
          +
          16C> - [in] Real size (li,lj) array to hold field to be smoothed.
          +
          17C> - [out] Array holding smoothed field.
          +
          18C> @param[in] Z - Real size (li,lj) work area.
          +
          19C> @param[in] LI - Integer number of columns.
          +
          20C> @param[in] LJ - Integer number of rows.
          +
          21C>
          +
          22C> @author J. Howcroft @date 1971-02-01
          +
          +
          23 SUBROUTINE w3fm08 (A,Z,LI,LJ)
          +
          24C
          +
          25 REAL A(LI,LJ)
          +
          26 REAL Z(LI,LJ)
          +
          27C
          +
          28 SAVE
          +
          29C
          +
          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/w3fp04_8f.html b/w3fp04_8f.html index beb23dae..1e6b9796 100644 --- a/w3fp04_8f.html +++ b/w3fp04_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp04.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fp04.f File Reference
          +
          w3fp04.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          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.
           

          Detailed Description

          Print array of data points at lat/lon points.

          @@ -107,8 +113,8 @@

          Definition in file w3fp04.f.

          Function/Subroutine Documentation

          - -

          ◆ w3fp04()

          + +

          ◆ w3fp04()

          @@ -117,73 +123,73 @@

          subroutine w3fp04 ( integer, dimension(idim)  - IFLD, + ifld, real, dimension(idim)  - ALAT, + alat, real, dimension(idim)  - ALON, + alon, integer, dimension(10)  - TITLE, + title,   - IDIM, + idim,   - CMIL, + cmil,   - CMIR, + cmir,   - CMJB, + cmjb,   - CMJT, + cmjt,   - INUM, + inum,   - XFAC, + xfac,   - IERR  + ierr  @@ -249,7 +255,7 @@

          diff --git a/w3fp04_8f.js b/w3fp04_8f.js index d94a6119..2877eeeb 100644 --- a/w3fp04_8f.js +++ b/w3fp04_8f.js @@ -1,4 +1,4 @@ var w3fp04_8f = [ - [ "w3fp04", "w3fp04_8f.html#af033f564bf5f078cbfc4700e62291470", null ] + [ "w3fp04", "w3fp04_8f.html#abc0c89b29a4a74847841e5a1aa35e49a", null ] ]; \ No newline at end of file diff --git a/w3fp04_8f_source.html b/w3fp04_8f_source.html index cb80e47a..52717571 100644 --- a/w3fp04_8f_source.html +++ b/w3fp04_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp04.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +
          @@ -76,481 +81,490 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fp04.f
          +
          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
          -
          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
          -
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Print array of data points at lat/lon points.
          +
          3C> @author J. Horodeck @date 1980-01-15
          +
          4
          +
          5C> Given an array of meteorological data and corresponding
          +
          6C> latitude/longitude position for each data point, these data
          +
          7C> values are printed at their approximate latitude/longitude
          +
          8C> positions on a polar stereographic projection.
          +
          9C>
          +
          10C> PROGRAM HISTORY LOG:
          +
          11C> - J. Horodeck 1980-01-15
          +
          12C> - Ralph Jones 1985-07-31 Change to cdc fortran 200
          +
          13C> - Ralph Jones 1990-08-15 Change to cray cft77 fortran
          +
          14C>
          +
          15C> @param[in] IFLD Real or integer fullword array of data points.
          +
          16C> @param[in] ALAT Real array of latitude positions (>0 for nh,
          +
          17C> <0 for sh) for the data to be plotted.
          +
          18C> @param[in] ALON Real array of longitudes (west of greenwich)
          +
          19C> @param[in] TITLE Integer size 10 alphanumeric array of
          +
          20C> characters for title to be written on printout.
          +
          21C> @param[in] IDIM Integer number of data values to plot (size of
          +
          22C> arrays ifld, alat and alon).
          +
          23C> @param[in] CMIL Real left side of grid - minimum coarse mesh
          +
          24C> i coordinate (minimum value of 1.0).
          +
          25C> @param[in] CMIR Real right side of grid - maximum coarse mesh
          +
          26C> i coordinate (maximum value of 65.0).
          +
          27C> @param[in] CMJB Real bottom of grid - minimum coarse mesh
          +
          28C> j coordinate (minimum value of 1.0).
          +
          29C> @param[in] CMJT Real top of grid - maximum coarse mesh j
          +
          30C> coordinate (maximum value of 65.0).
          +
          31C> @param[in] INUM Integer three digit number for the following:
          +
          32C> - Hundreds digit = type of data
          +
          33C> - 1 = Fixed point
          +
          34C> - 2 = Floating point
          +
          35C> - 3 = Alphanumeric
          +
          36C> - Tens digit = hemispheric reference
          +
          37C> - 0 = Northern hemisphere
          +
          38C> - 1 = Southern hemisphere
          +
          39C> - Units digit = number of characters to plot
          +
          40C> - Minimum = 1 character
          +
          41C> - Maximum = 4 characters
          +
          42C> @param[in] XFAC Real map scale factor (desired map scale = xfac
          +
          43C> * 1:30,000,000 (standard nmc 65x65 grid scale))
          +
          44C> @param[out] IERR Integer return code.
          +
          45C>
          +
          46C> @note Because this code could produce considerable output
          +
          47C> the subset of the nmc 65x65 grid which can be printed is a
          +
          48C> function of the map scale factor, e.g. for xfac=5 the maximum
          +
          49C> range of i and j is 27.0, for xfac=2 the range is 64.0.
          +
          50C>
          +
          51C> @author J. Horodeck @date 1980-01-15
          +
          +
          52 SUBROUTINE w3fp04(IFLD,ALAT,ALON,TITLE,IDIM,CMIL,CMIR,
          +
          53 & CMJB,CMJT,INUM,XFAC,IERR)
          +
          54C
          +
          55 REAL ALAT(IDIM), ALON(IDIM)
          +
          56C
          +
          57 INTEGER IFLD(IDIM), TITLE(10)
          +
          58 INTEGER LINE(24), IL(17), IR(17), IJU(20), IJL(20)
          +
          59C
          +
          60 LOGICAL A
          +
          61C
          +
          62C
          +
          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
          +
          71C
          +
          72 equivalence(mean(1),imean), (DATA(1),lfld)
          +
          73 equivalence(rfield,ifield)
          +
          74 equivalence(ifmtt,ifmt)
          +
          75C
          +
          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'/
          +
          84C
          +
          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......')
          +
          110C
          +
          111C TEST I,J VALUES FOR RANGE AND ORDER
          +
          112C
          +
          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
          +
          139C
          +
          140C CALCULATE VARIOUS LIMITS
          +
          141C
          +
          142 lnum = mod(inum,10)
          +
          143 nref = (mod(inum,100))/10
          +
          144C
          +
          145C TEST FOR INCORRECT ARGUMENTS PASSED
          +
          146C
          +
          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
          +
          161C
          +
          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
          +
          167C
          +
          168C WILL THIS PLOT BE TOO LARGE?
          +
          169C
          +
          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
          +
          175C
          +
          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
          +
          192C
          +
          193C PLOT DATA ONE PANEL AT A TIME IN SECTIONS
          +
          194C
          +
          195 DO 150 nx=1,ipage
          +
          196 a = .false.
          +
          197C
          +
          198C SET LIMITS OF I TO BE PRINTED
          +
          199C
          +
          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
          +
          206C
          +
          207C FILL ARRAY WITH VALUES OF I TO BE PRINTED AT TOP OF PAGE
          +
          208C
          +
          209 DO 10 i = imin,imax
          +
          210 m = m + 1
          +
          211 line(m) = i
          +
          212 10 CONTINUE
          +
          213C
          +
          214C CALCULATE WIDTH OF PANEL IN INTEGERS AND
          +
          215C CHARACTERS FROM WHICH DETERMINE FORMAT
          +
          216C FIELD COUNT AND CONVERT BINARY TO ASCII
          +
          217C
          +
          218C PRINT TOP LINE OF I
          +
          219C
          +
          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)
          +
          248C
          +
          249C PREPARE TO PRINT SECTIONS OF EACH PANEL
          +
          250C
          +
          251 DO 140 jnx=1,jpage
          +
          252C
          +
          253C SET LIMITS OF J TO BE PRINTED
          +
          254C
          +
          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
          +
          263C
          +
          264C FILL CHARACTER ARRAY WITH BLANKS AND PUT X MARKERS IN CORNERS
          +
          265C IF FIRST PANEL BLANK ENTIRE AREA,
          +
          266C OTHERWISE TRANSFER FIRST INUM I BYTES TO LARGE ARRAY
          +
          267C AND BLANK REMAINING ARRAY
          +
          268C
          +
          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
          +
          292C
          +
          293C LOOP TO PUT DATA IN CHARACTER ARRAY
          +
          294C
          +
          295 DO 110 i=1,idim
          +
          296C
          +
          297C TEST FOR BAD GEOGRAPHY
          +
          298C
          +
          299 IF ((abs(alat(i)).GT.90.).OR.(alon(i).LT.0.0).OR.(alon
          +
          300 a (i).GT.360.0)) GO TO 90
          +
          301C
          +
          302C CHANGE LAT,LON TO I,J
          +
          303C
          +
          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
          +
          312C
          +
          313C POSITION I,J COORDINATES IN CHARACTER ARRAY AND TEST
          +
          314C IF VALUES RETURNED ARE WITHIN LIMITS OF MAP AND WITHIN SECTIONS
          +
          315C
          +
          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
          +
          327C
          +
          328C WRITE N+POLE IF IN THIS SECTION
          +
          329C
          +
          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
          +
          341C
          +
          342C CONVERT CHARACTER ARRAY COORDINATES FROM
          +
          343C TOTAL MAP VALUES TO SECTION VALUES
          +
          344C
          +
          345 ii = ii - (jjaam1*(nx-1))
          +
          346 IF (jnx.NE.jpage) jj = jj - (iz-1)
          +
          347C
          +
          348C IF SPACE IS OCCUPIED SKIP THIS STATION
          +
          349C
          +
          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
          +
          357C
          +
          358C PLACE VALUE TO BE PLOTTED IN CHARACTER ARRAY
          +
          359C
          +
          360 ifield = ifld(i)
          +
          361C
          +
          362C TEST FOR TYPE OF DATA
          +
          363C
          +
          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
          +
          371C
          +
          372C IF ORIGINALLY FIXED POINT OR HAS BEEN CONVERTED
          +
          373C FROM FLOATING POINT TO FIXED POINT
          +
          374C
          +
          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
          +
          385C
          +
          386C FOR ALPHANUMERIC DATA
          +
          387C
          +
          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
          +
          397C
          +
          398C PRINT JTH ROW AND VALUES OF J
          +
          399C
          +
          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
          +
          408C
          +
          409C SAVE LAST INUM BYTES OF I
          +
          410C
          +
          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)
          +
          428C
          +
          429C CALCULATE AND PRINT LAT/LON AT CORNERS
          +
          430C
          +
          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
          +
          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
          +
          w3fb05
          subroutine w3fb05(xi, xj, xmeshl, orient, alat, along)
          Converts the coordinates of a location from the grid(i,j) coordinate system overlaid on the polar ste...
          Definition w3fb05.f:40
          +
          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
          diff --git a/w3fp05_8f.html b/w3fp05_8f.html index ef135c08..24ccf7fd 100644 --- a/w3fp05_8f.html +++ b/w3fp05_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp05.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fp05.f File Reference
          +
          w3fp05.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3fp05 (rdata, ktbl, cnst, title, krect, kcontr, linev, iwidth)
           Prints a two-dimensional grid of any shape, with contouring, if desired.
           

          Detailed Description

          Printer contour subroutine.

          @@ -107,8 +113,8 @@

          Definition in file w3fp05.f.

          Function/Subroutine Documentation

          - -

          ◆ w3fp05()

          + +

          ◆ w3fp05()

          @@ -117,49 +123,49 @@

          subroutine w3fp05 ( real, dimension(1)  - RDATA, + rdata, integer, dimension(407)  - KTBL, + ktbl, real, dimension(4)  - CNST, + cnst, character*1, dimension(*)  - TITLE, + title,   - KRECT, + krect,   - KCONTR, + kcontr,   - LINEV, + linev,   - IWIDTH  + iwidth  @@ -202,7 +208,7 @@

          diff --git a/w3fp05_8f.js b/w3fp05_8f.js index a7f61b31..e5f25496 100644 --- a/w3fp05_8f.js +++ b/w3fp05_8f.js @@ -1,4 +1,4 @@ var w3fp05_8f = [ - [ "w3fp05", "w3fp05_8f.html#a5d4251a5f962d24d56f5ce0b3b4212b8", null ] + [ "w3fp05", "w3fp05_8f.html#a68a1b19e798523cddbf6d2aea4751362", null ] ]; \ No newline at end of file diff --git a/w3fp05_8f_source.html b/w3fp05_8f_source.html index ffd18f91..da98bbf7 100644 --- a/w3fp05_8f_source.html +++ b/w3fp05_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp05.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +
          @@ -76,617 +81,625 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fp05.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Printer contour subroutine.
          +
          3C> @author Ralph Jones @date 1989-10-13
          +
          4
          +
          5C> Prints a two-dimensional grid of any shape, with
          +
          6C> contouring, if desired. grid values are scaled according to
          +
          7C> to constants specified by the programer, rounded, and printed
          +
          8C> as 4,3, or 2 digit integers with sign, the sign marking the
          +
          9C> grid position of the printed number. if contouring is requested,
          +
          10C> bessel's interpolation formula is used to optain the contour lines.
          +
          11C> contours are indicated by alphabetic characters ranging from a to
          +
          12C> h or numeric characters from 0 to 9. contour origin and interval
          +
          13C> are specified by the programmer in terms of printed values.
          +
          14C>
          +
          15C> Program history log:
          +
          16C> - Ralph Jones 1989-10-13
          +
          17C> - Ralph Jones 1992-05-02 Add save
          +
          18C>
          +
          19C> @param[in] RDATA Real array of grid data to be printed.
          +
          20C> @param[in] KTBL Integer array with shape of array.
          +
          21C> @param[in] CNST Real array of four elements, used in
          +
          22C> scaling for printing and contouring.
          +
          23C> @param[in] TITLE Is a array of 132 characters or less of
          +
          24C> hollerith data, 1st char. must be blank.
          +
          25C> printed at bottom of the map.
          +
          26C> @param[in] KRECT 1 if grid is rectangular, 0 otherwise.
          +
          27C> @param[in] KCONTR 1 for contouring , 0 otherwise.
          +
          28C> @param[in] LINEV 0 is for 6 lines per vertical inch,
          +
          29C> non-zero 8 lines per vertical inch.
          +
          30C> @param[in] IWIDTH Number of characters in print line,
          +
          31C> 132 is standard printer.
          +
          32C>
          +
          33C> @note Normal subroutine return, unless number of rows is greater than 200,
          +
          34C> prints error message and exits.
          +
          35C>
          +
          36C> @author Ralph Jones @date 1989-10-13
          +
          +
          37 SUBROUTINE w3fp05(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,LINEV,IWIDTH)
          +
          38C
          +
          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)
          +
          48C
          +
          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
          +
          68C
          +
          69 LOGICAL DONE
          +
          70 LOGICAL LCNTR
          +
          71 LOGICAL RECT
          +
          72C
          +
          73 CHARACTER*1 TITLE(*)
          +
          74C
          +
          75 equivalence(crmx,vdja(29))
          +
          76 equivalence(kline(1),klines(8))
          +
          77 equivalence(vdjc(1),rwa(1))
          +
          78C
          +
          79C ... THE VAULUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE
          +
          80C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE
          +
          81C ... FLOATING POINT NUMBER FOR THE COMPUTER.
          +
          82C
          +
          83 SAVE
          +
          84C
          +
          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/
          +
          96C
          +
          97C ... LIMNRW IS LIMIT ON NUMBER OF ROWS ALLOWED
          +
          98C ... AND IS DIMENSION OF KRLOC ...
          +
          99C
          +
          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/
          +
          106C
          +
          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)
          +
          115C
          +
          116C COMPUTE VALUES FOR PRINTER WIDTH
          +
          117C
          +
          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
          +
          125C
          +
          126 IF (linev .EQ. 0) GO TO 100
          +
          127C ...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
          +
          134C
          +
          135 100 CONTINUE
          +
          136 linate = 2
          +
          137 r4 = 0.33333333
          +
          138 r32 = 1.0/18.0
          +
          139 con2 = 6.0
          +
          140 nbtwn = 2
          +
          141C
          +
          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)
          +
          151C TO SET NO. OF DIGITS TO BE PRINTED
          +
          152C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR
          +
          153 nodig = iabs(kcontr/10)
          +
          154 nodig = 3 - nodig
          +
          155C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED
          +
          156 IF (nodig.LT.1 .OR. nodig.GT.3) nodig = 3
          +
          157C 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
          +
          162C OTHERWISE RESET NCONQ
          +
          163 nconq = 0
          +
          164 GO TO 400
          +
          165 300 CONTINUE
          +
          166 lcntr = .true.
          +
          167C WITH NCONQ=1 FOR LETTERS,AND =2 FOR NUMBERS IN CONTOUR BANDS
          +
          168 400 CONTINUE
          +
          169 IF (nconq .EQ. 2) GO TO 600
          +
          170C OTHERWISE SET AS LETTERS
          +
          171C
          +
          172 kcow = 16
          +
          173 DO 500 j = 1,kcow
          +
          174 kalph(j) = kalfa(j)
          +
          175 500 CONTINUE
          +
          176 GO TO 800
          +
          177C
          +
          178 600 CONTINUE
          +
          179 kcow = 20
          +
          180 DO 700 j = 1,kcow
          +
          181 kalph(j) = knumb(j)
          +
          182 700 CONTINUE
          +
          183C
          +
          184800 CONTINUE
          +
          185 radj = 4 * kcow
          +
          186 kd=1
          +
          187C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW
          +
          188C *** THIS IS KRLOC
          +
          189C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX)
          +
          190C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET
          +
          191 IF (ktbl(1 ).EQ.(-1)) GO TO 1100
          +
          192C *** 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
          +
          200C
          +
          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
          +
          214C *** TWO-DIMENSIONAL FORM
          +
          215C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT
          +
          216C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE
          +
          217C *** 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
          +
          223C ... ELSE, NRWS EXCEEDS LIMIT ALLOWED ...
          +
          224 1200 CONTINUE
          +
          225 WRITE (output,8000) nrws,limnrw
          +
          226 GO TO 7400
          +
          227C
          +
          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)
          +
          250C *** PRINT I-LABELS ACROSS TOP OF MAP
          +
          251 1700 CONTINUE
          +
          252C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH
          +
          253 IF (linate.EQ.1) WRITE (output,8100)
          +
          254C ...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
          +
          259C
          +
          260 1800 CONTINUE
          +
          261 IF (.NOT.lcntr) GO TO 2000
          +
          262C *** INITIALIZE CONTOUR WORKING AREA
          +
          263 DO 1900 j=1,pagn3
          +
          264 rwc(j)=crmx
          +
          265 rwd(j)=crmx
          +
          266 1900 CONTINUE
          +
          267C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS
          +
          268C
          +
          269 2000 CONTINUE
          +
          270 kra = 1
          +
          271 kc = ktf+1
          +
          272 assign 2100 to kbr
          +
          273 GO TO 5900
          +
          274C
          +
          275 2100 CONTINUE
          +
          276 kra = 2
          +
          277 kc = kc+kca
          +
          278 assign 2200 to kbr
          +
          279 GO TO 5900
          +
          280C
          +
          281 2200 CONTINUE
          +
          282 kr = 0
          +
          283C *** TEST IF THIS IS LAST PAGE
          +
          284 IF (imax.GT.pgmax-1) GO TO 2300
          +
          285 lmr = imax*5 + 2
          +
          286 done = .true.
          +
          287C *** DO LEFT J-LABELS
          +
          288 2300 CONTINUE
          +
          289 jcurr = jmax
          +
          290C
          +
          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
          +
          315C
          +
          316 2700 CONTINUE
          +
          317 klines(3) = khtbl(ktb+1)
          +
          318 klines(4) = khtbl(kta+1)
          +
          319 klines(5) = khblnk
          +
          320C
          +
          321 2800 CONTINUE
          +
          322 DO 2900 j = 6,mxpg
          +
          323 klines(j) = khblnk
          +
          324 2900 CONTINUE
          +
          325 IF (.NOT.done) GO TO 3000
          +
          326C *** 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)
          +
          331C *** 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
          +
          344C
          +
          345 3200 CONTINUE
          +
          346 ktb = mod(ktemp,1000)/100
          +
          347C
          +
          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
          +
          370C *** 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
          +
          381C *** 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
          +
          386C *** TEST BOTTOM OF MAP
          +
          387 IF (kr.EQ.nrws) GO TO 5700
          +
          388C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW
          +
          389 assign 4100 to kbr
          +
          390 GO TO 5900
          +
          391C
          +
          392 4100 CONTINUE
          +
          393 IF (.NOT.lcntr) GO TO 2400
          +
          394C *** DO CONTOURING
          +
          395 DO 4200 jj=1,mxpg
          +
          396 klines(jj)=khblnk
          +
          397 4200 CONTINUE
          +
          398C *** 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
          +
          415C ...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
          +
          421C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW
          +
          422C *** 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)
          +
          434C *** 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
          +
          457C
          +
          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
          +
          465C
          +
          466 5700 CONTINUE
          +
          467 IF (linate.EQ.1) WRITE (output,8300)
          +
          468 IF (linate.EQ.2) WRITE (output,8400)
          +
          469 klines(1) = khblnk
          +
          470C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE
          +
          471 assign 5800 to kbr
          +
          472 GO TO 6900
          +
          473C
          +
          474 5800 CONTINUE
          +
          475 IF (linate.EQ.1) WRITE (output,8300)
          +
          476 IF (linate.EQ.2) WRITE (output,8400)
          +
          477C *** PRINT TITLE
          +
          478 WRITE (output,8600) (title(ii),ii=1,lw)
          +
          479C *** TEST END OF MAP
          +
          480 IF (krloc(kclmx).EQ.kcmx) RETURN
          +
          481C *** ADJUST PAGE LINE BOUNDARIES
          +
          482C
          +
          483 IF (imax.GT.pgmax)imax = imax-pgmax
          +
          484 imin = ka
          +
          485 pagnl = pagnl + pgmax
          +
          486 pagnr = pagnr + pgmax
          +
          487 GO TO 1700
          +
          488C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS
          +
          489C
          +
          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
          +
          518C
          +
          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)
          +
          528C
          +
          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
          +
          543C
          +
          544 6600 CONTINUE
          +
          545 pgcnta = min(pgmax,krcnt+krfst-pagnl)
          +
          546 GO TO 6100
          +
          547C
          +
          548 6700 CONTINUE
          +
          549 pgcnta = 0
          +
          550 6800 CONTINUE
          +
          551 pccnt = 0
          +
          552 GO TO 6100
          +
          553C
          +
          554C *** ROUTINE TO PRINT I-LABELS
          +
          555C
          +
          556 6900 CONTINUE
          +
          557 DO 7000 kk = 2,mxpg
          +
          558 klines(kk) = khblnk
          +
          559 7000 CONTINUE
          +
          560C
          +
          561C
          +
          562 kk = 1
          +
          563 ka = imin
          +
          564 lbl = min(imax,pgmax)
          +
          565C
          +
          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
          +
          577C
          +
          578 7100 CONTINUE
          +
          579 kline(kk+1) = khtbl(kta+1)
          +
          580 kline(kk+2) = khtbl(ktb+1)
          +
          581C
          +
          582 7200 CONTINUE
          +
          583 kk = kk + 5
          +
          584 ka = ka+1
          +
          585 7300 CONTINUE
          +
          586C
          +
          587 WRITE (output,8500) (klines(ii),ii=1,mxpg)
          +
          588C
          +
          589 GO TO kbr,(1800,2100,2200,4100,5800)
          +
          590C
          +
          591 7400 RETURN
          +
          592C
          +
          +
          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/w3fp06_8f.html b/w3fp06_8f.html index 76f26e59..0c363b1a 100644 --- a/w3fp06_8f.html +++ b/w3fp06_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp06.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fp06.f File Reference
          +
          w3fp06.f File Reference
          @@ -94,29 +100,29 @@

          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...
           
          subroutine climo (cf1, cf2, unit, for, aftbef)
           Sets time-averaged titles.
           
          subroutine line01 (id, mask, ktitle)
           Creates the first line of title.
           
          subroutine line02 (id, mask, ktitle)
           Creates the second line of title.
           
          subroutine line03 (id, ktitle)
           Creates the third line of title.
           
          subroutine setcl (cf2, unit, ktitle)
           Encodes time-averaged title.
           
          subroutine value1 (s, c, e, num)
           Creates value1 of surface from ids.
           
          subroutine w3fp06 (id, ktitle, n)
           Provides a title for data fields formulated according to nmc o.n.
           

          Detailed Description

          NMC title subroutine.

          @@ -125,8 +131,8 @@

          Definition in file w3fp06.f.

          Function/Subroutine Documentation

          - -

          ◆ climo()

          + +

          ◆ climo()

          @@ -135,31 +141,31 @@

          subroutine climo ( real  - CF1, + cf1, real  - CF2, + cf2, character*4  - UNIT, + unit, character*5  - FOR, + for, character*7  - AFTBEF  + aftbef  @@ -205,8 +211,8 @@

          -

          ◆ line01()

          + +

          ◆ line01()

          @@ -215,19 +221,19 @@

          subroutine line01 ( integer(8), dimension(6)  - ID, + id, integer(4), dimension(8)  - MASK, + mask, character * 324  - KTITLE  + ktitle  @@ -239,7 +245,7 @@

          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.
          +
          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.
            • @@ -259,8 +265,8 @@

            -

            ◆ line02()

            + +

            ◆ line02()

            @@ -269,19 +275,19 @@

            subroutine line02 ( integer(8), dimension(6)  - ID, + id, integer(4), dimension(8)  - MASK, + mask, character * 324  - KTITLE  + ktitle  @@ -314,8 +320,8 @@

            -

            ◆ line03()

            + +

            ◆ line03()

            @@ -324,13 +330,13 @@

            subroutine line03 ( integer(8), dimension(6)  - ID, + id, character * 324  - KTITLE  + ktitle  @@ -361,8 +367,8 @@

            -

            ◆ setcl()

            + +

            ◆ setcl()

            @@ -371,19 +377,19 @@

            subroutine setcl (   - CF2, + cf2, character*4  - UNIT, + unit, character*324  - KTITLE  + ktitle  @@ -419,8 +425,8 @@

            -

            ◆ value1()

            + +

            ◆ value1()

            @@ -429,25 +435,25 @@

            subroutine value1 ( integer  - S, + s, integer  - C, + c, integer  - E, + e, character*8  - NUM  + num  @@ -479,8 +485,8 @@

            -

            ◆ w3fp06()

            + +

            ◆ w3fp06()

            @@ -489,19 +495,19 @@

            subroutine w3fp06 ( integer(8), dimension(6)  - ID, + id, character * 324  - KTITLE, + ktitle,   - N  + n  @@ -547,7 +553,7 @@

            diff --git a/w3fp06_8f.js b/w3fp06_8f.js index 37049d16..c0cff6af 100644 --- a/w3fp06_8f.js +++ b/w3fp06_8f.js @@ -1,10 +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 ] + [ "climo", "w3fp06_8f.html#ae0b22fa11b8fe72122318b34fff3c384", null ], + [ "line01", "w3fp06_8f.html#ae1b5ebd2418050ad3b381f3f8d608bc6", null ], + [ "line02", "w3fp06_8f.html#ad054774044780f0d653a6e9e187b21f9", null ], + [ "line03", "w3fp06_8f.html#a947acf07eeb32317d7ff0c144682c8ad", null ], + [ "setcl", "w3fp06_8f.html#a85c5aff8a14219277412b5178d23c8eb", null ], + [ "value1", "w3fp06_8f.html#a50f973cd14b24a8da68b625d31c18dfa", null ], + [ "w3fp06", "w3fp06_8f.html#a1912bdef4280f84618d529e4764ac8fd", null ] ]; \ No newline at end of file diff --git a/w3fp06_8f_source.html b/w3fp06_8f_source.html index b643975d..8c45ed5f 100644 --- a/w3fp06_8f_source.html +++ b/w3fp06_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp06.f Source File @@ -23,10 +23,9 @@
            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ + +
            @@ -76,1063 +81,1083 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fp06.f
            +
            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
            -
            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
            -
            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
            -
            line02
            subroutine line02(ID, MASK, KTITLE)
            Creates the second line of title.
            Definition: w3fp06.f:808
            -
            line01
            subroutine line01(ID, MASK, KTITLE)
            Creates the first line of title.
            Definition: w3fp06.f:70
            -
            value1
            subroutine value1(S, C, E, NUM)
            Creates value1 of surface from ids.
            Definition: w3fp06.f:746
            -
            climo
            subroutine climo(CF1, CF2, UNIT, FOR, AFTBEF)
            Sets time-averaged titles.
            Definition: w3fp06.f:942
            -
            w3fp06
            subroutine w3fp06(ID, KTITLE, N)
            Provides a title for data fields formulated according to nmc o.n.
            Definition: w3fp06.f:26
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief NMC title subroutine.
            +
            3C> @author Ralph Jones @date 1988-11-28
            +
            4
            +
            5C> Provides a title for data fields formulated according to
            +
            6C> nmc o.n. 84. the extracted information is converted into up to
            +
            7C> 81 words and stored at a user provided location.
            +
            8C>
            +
            9C> Program history log:
            +
            10C> - Ralph Jones 1988-11-28
            +
            11C> - Ralph Jones 1990-02-12 Convert to cray cft77 fortran
            +
            12C> - Ralph Jones 1991-04-26 Add q type 23, 136, 137, 71, 159, 75, 118,
            +
            13C> 119, 24 to tables, changes for big records.
            +
            14C> - Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables
            +
            15C>
            +
            16C> @param[in] N Integer number of lines of output desired
            +
            17C> - = 1 First 88 char. the abbreviated title (line 1 starts at arg2(1))
            +
            18C> - = 2 First 216 char. decimal values of the parameters
            +
            19C> - = 3 All 324 char., hexidecimal dump of the 12 word field label (line 3 char. 221)
            +
            20C> @param ID, KTITLE
            +
            21C>
            +
            22C> @note See NMC O.N. 84 for data field abbreviations.
            +
            23C>
            +
            24C> @author Ralph Jones @date 1988-11-28
            +
            +
            25 SUBROUTINE w3fp06(ID,KTITLE,N)
            +
            26C
            +
            27 INTEGER(8) ID(6)
            +
            28 INTEGER(4) MASK(8)
            +
            29C
            +
            30 CHARACTER * 324 KTITLE
            +
            31C
            +
            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'/
            +
            40C
            +
            41 CALL line01(id,mask,ktitle)
            +
            42 IF (n.GT.1) GO TO 10
            +
            43 RETURN
            +
            44C
            +
            45 10 CONTINUE
            +
            46 CALL line02(id,mask,ktitle)
            +
            47 IF (n.GT.2) GO TO 20
            +
            48 RETURN
            +
            49C
            +
            50 20 CONTINUE
            +
            51 CALL line03(id,ktitle)
            +
            52 RETURN
            +
            +
            53 END
            +
            54C> @brief Creates the first line of title.
            +
            55C> @author Ralph Jones @date 1988-09-02
            +
            56
            +
            57C> Creates the fist line of the title from the id words.
            +
            58C> call by w3fp06() to make 1st line of title. Words 1 to 22.
            +
            59C>
            +
            60C> Program history log:
            +
            61C> - Ralph Jones 1988-09-02
            +
            62C> - Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables.
            +
            63C>
            +
            64C> @param[in] ID Id words (6 integer words) office note 84.
            +
            65C> @param[in] MASK Mask for unpacking id words (8 integer words).
            +
            66C> @param[out] KTITLE Character *324 array
            +
            67C>
            +
            68C> @author Ralph Jones @date 1988-09-02
            +
            +
            69 SUBROUTINE line01(ID,MASK,KTITLE)
            +
            70
            +
            71C
            +
            72C CREATES THE FIRST 22 WORDS OF TITLER
            +
            73C
            +
            74 INTEGER(8) ID(6)
            +
            75 INTEGER(4) MASK(8)
            +
            76 INTEGER(4) SHFMSK(17)
            +
            77C
            +
            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
            +
            100C
            +
            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
            +
            107C
            +
            108C IDWORDS: MASK CONTROL (INTEGER)
            +
            109C
            +
            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'/
            +
            127C
            +
            128C REFERENCE TABLE FOR SNAME.
            +
            129C
            +
            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/
            +
            147C
            +
            148C SNAME TABLE.
            +
            149C
            +
            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)/' '/
            +
            168C
            +
            169C REFERENCE TABLE FOR QNAME.
            +
            170C
            +
            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/
            +
            337C
            +
            338C QNAME TABLE: CHARACTER*6
            +
            339C
            +
            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 '/
            +
            506C
            +
            507C REFERENCE TABLE FOR G (GENERATING PROGRAM NAME)
            +
            508C
            +
            509 DATA kk(1)/57/
            +
            510 DATA kk(2)/58/
            +
            511 DATA kk(3)/59/
            +
            512C
            +
            513C G TABLE (GENERATING PROGRM NAME):
            +
            514C
            +
            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 '/
            +
            519C
            +
            520 DATA after /' AFTER '/
            +
            521 DATA dn /'DN'/
            +
            522 DATA qname1/' THCK '/
            +
            523 DATA qname2/' THKDN'/
            +
            524 DATA qname3/' PRSDN'/
            +
            525C
            +
            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 /'-'/
            +
            532C
            +
            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)
            +
            541C
            +
            542C 1. UNPACK ID WORDS.
            +
            543C
            +
            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
            +
            555C
            +
            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)
            +
            573C
            +
            574 ks = iand(ishft(id(3),-40_8),255_8)
            +
            575C
            +
            576C 2. FIND WHICH PARAMETER (Q) IS INDICATED BE THE ID WORDS.
            +
            577C
            +
            578 DO 20 n = 1,166
            +
            579 nn = n
            +
            580 IF (q.EQ.ll(n)) GO TO 30
            +
            581 20 CONTINUE
            +
            582C
            +
            583C CAN NOT FIND A LEGAL Q
            +
            584 GO TO 170
            +
            585C
            +
            586 30 CONTINUE
            +
            587 unit(1:4) = unit1(1:4)
            +
            588 for(1:5) = for1(1:5)
            +
            589 aftbef(1:7) = after(1:7)
            +
            590C
            +
            591 IF (e1.GT.128) e1 = -(jkeep(6)-128)
            +
            592 IF (e2.GT.128) e2 = -(jkeep(8)-128)
            +
            593C
            +
            594C 3. FIND WHICH SURFACE IS INDICATED BY THE ID WORDS
            +
            595C AS BEING THE FIRST SURFACE.
            +
            596C
            +
            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
            +
            604C
            +
            605 50 CONTINUE
            +
            606C
            +
            607C 4. BEGIN PROCESSING OF A ONE-SURFACE TITLE
            +
            608C
            +
            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
            +
            615C
            +
            616C 5. FIND WHICH SURFACE IS INDICATED BY THE ID WORDS
            +
            617C AS BEING THE SECOND SURFACE.
            +
            618C
            +
            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
            +
            626C
            +
            627 70 CONTINUE
            +
            628C
            +
            629C 6. BEGIN PROCESSING OF A TWO-SURFACE TITLE
            +
            630C
            +
            631 CALL value1(s1,c1,e1,inum1)
            +
            632 CALL value1(s2,c2,e2,inum2)
            +
            633 WRITE (ktitle(1:20),200) inum1 , sname(k1) , inum2
            +
            634C
            +
            635 80 CONTINUE
            +
            636 qwrite = qname(nn)
            +
            637C
            +
            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)
            +
            642C
            +
            643C 7. SET DATE/TIME FIELDS
            +
            644C
            +
            645C A. CHECK IF F1 AND F2 ARE IN HRS, HALF DAYS OR DAYS.
            +
            646C
            +
            647 rf1 = f1
            +
            648 rf2 = f2
            +
            649C
            +
            650C B: IF F1 IN HALF DAYS: CONVERT TO HOURS
            +
            651C
            +
            652 IF (jn.EQ.15.OR.jt.EQ.7) THEN
            +
            653 rf1 = rf1 * 12.0
            +
            654 rf2 = rf2 * 12.0
            +
            655 ENDIF
            +
            656C
            +
            657C C: IF F1 IN DAYS: CONVERT TO HOURS
            +
            658C
            +
            659 IF (jt.EQ.10) THEN
            +
            660 rf1 = rf1 * 24.0
            +
            661 rf2 = rf2 * 24.0
            +
            662 ENDIF
            +
            663C
            +
            664C D: CONVERT HOURS TO DAYS IF HOURS GREATER THAN 72
            +
            665C
            +
            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
            +
            673C
            +
            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
            +
            685C
            +
            686C 8. SET GENERATING PROGRAM NAME
            +
            687C
            +
            688 DO 110 k = 1,3
            +
            689 IF (g.EQ.kk(k)) GO TO 130
            +
            690 110 CONTINUE
            +
            691C
            +
            692 DO 120 l = 1,3
            +
            693 kwrite(l) = kname1(l)
            +
            694 120 CONTINUE
            +
            695 GO TO 150
            +
            696C
            +
            697 130 CONTINUE
            +
            698 DO 140 l = 1,3
            +
            699 kwrite(l) = kname( 3*(k-1) + l)
            +
            700 140 CONTINUE
            +
            701C
            +
            702C 9. ENCODE THE TITLE LINE
            +
            703C
            +
            704C 9.1 DISTINGUISH BETWEEN ANALYSIS AND ZERO FORECASTS
            +
            705C AND 'REAL' FORECASTS
            +
            706C
            +
            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
            +
            716C
            +
            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
            +
            720C
            +
            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
            +
            725C
            +
            726 170 CONTINUE
            +
            727 WRITE (ktitle(1:88),230) q
            +
            728 RETURN
            +
            +
            729 END
            +
            730C> @brief Creates value1 of surface from ids.
            +
            731C> @author Ralph Jones @date 1988-11-28
            +
            732
            +
            733C> Creates the numerical value for the surface
            +
            734C> to be built into the first line of the title.
            +
            735C>
            +
            736C> Program history log:
            +
            737C> - Ralph Jones 1988-11-28
            +
            738C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
            +
            739C>
            +
            740C> @param[in] S Integer number of surface.
            +
            741C> @param[in] C,E Numerical value of the surface (SURFACE = S * 10 ** E).
            +
            742C> @param[out] NUM 7 character value of the surface for the title.
            +
            743C>
            +
            744C> @author Ralph Jones @date 1988-11-28
            +
            +
            745 SUBROUTINE value1(S,C,E,NUM)
            +
            746
            +
            747C
            +
            748 INTEGER C
            +
            749 INTEGER E
            +
            750 INTEGER S
            +
            751C
            +
            752 CHARACTER*8 JNUM
            +
            753 CHARACTER*8 KNUM
            +
            754 CHARACTER*7 LTEMP
            +
            755 CHARACTER*8 NUM
            +
            756 CHARACTER*1 POINT
            +
            757 CHARACTER*1 ZERO
            +
            758C
            +
            759 DATA jnum /' 0.0000 '/
            +
            760 DATA knum /' '/
            +
            761 DATA point /'.'/
            +
            762 DATA zero /'0'/
            +
            763C
            +
            764 101 FORMAT ( i6,' ')
            +
            765C
            +
            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)
            +
            773C
            +
            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
            +
            779C
            +
            780 100 CONTINUE
            +
            781 num = jnum
            +
            782 GO TO 150
            +
            783C
            +
            784 110 CONTINUE
            +
            785 num = knum
            +
            786C
            +
            787 150 CONTINUE
            +
            788C
            +
            789 RETURN
            +
            +
            790 END
            +
            791C> @brief Creates the second line of title.
            +
            792C> @author Ralph Jones @date 1988-11-28
            +
            793
            +
            794C> Creates the second line of the title from the id words.
            +
            795C> called by w3fp06. words 23 to 54.
            +
            796C>
            +
            797C> Program history log:
            +
            798C> - Ralph Jones 1988-11-28
            +
            799C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
            +
            800C> - Ralph Jones 1991-03-01 Changes for big records.
            +
            801C>
            +
            802C> @param[in] ID Id words (6 integer words) office note 84
            +
            803C> @param[in] MASK Mask for unpacking id words (8 words)
            +
            804C> @param[out] KTITLE Title character*324
            +
            805C>
            +
            806C> @author Ralph Jones @date 1988-11-28
            +
            +
            807 SUBROUTINE line02(ID,MASK,KTITLE)
            +
            808
            +
            809C
            +
            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))
            +
            818C
            +
            819 CHARACTER * 324 KTITLE
            +
            820C
            +
            821C IDWORDS: MASK CONTROL (INTEGER)
            +
            822C
            +
            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'/
            +
            842C
            +
            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,' ')
            +
            846C
            +
            847C UNPACK ID WORDS.
            +
            848C
            +
            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
            +
            858C
            +
            859C CONVERT IBM 32 BIT F.P. NUMBER TO IEEE F.P. NUMBER
            +
            860C
            +
            861C CALL USSCTC(ID(5),5,A,1)
            +
            862 irtemp=id(5)
            +
            863 call q9ie32(rtemp(2),rtemp(1),1,istat)
            +
            864 a=rtemp(1)
            +
            865C
            +
            866C CONVERT 16 BIT SIGNED INTEGER INTO A 64 BIT INTEGER.
            +
            867C
            +
            868 IF (btest(ikeep(17),15_8)) THEN
            +
            869 ikeep(17) = ior(ikeep(17),maskn)
            +
            870 ENDIF
            +
            871C
            +
            872C TEST FOR BIG RECORD
            +
            873C
            +
            874 IF (ikeep(13).EQ.0) THEN
            +
            875 ikeep(13) = iand(id(6),mask32)
            +
            876 END IF
            +
            877C
            +
            878 WRITE (ktitle(89:216),100) (ikeep(i),i=1,15) , a , ikeep(17)
            +
            879 RETURN
            +
            +
            880 END
            +
            881C> @brief Creates the third line of title.
            +
            882C> @author Ralph Jones @date 1988-11-28
            +
            883
            +
            884C> Creates the third line of the title from the id words.
            +
            885C> called by w3fp06 to create words 55 to 81 of the title.
            +
            886C>
            +
            887C> Program history log:
            +
            888C> - Ralph Jones 1988-11-28
            +
            889C> - Ralph Jones 1990-02-03 Convert to cray cft77 fortran.
            +
            890C>
            +
            891C> @param[in] ID ID words (6 integer) office note 84.
            +
            892C> @param[out] KTITLE Character*324 array.
            +
            893C>
            +
            894C> @author Ralph Jones @date 1988-11-28
            +
            +
            895 SUBROUTINE line03(ID,KTITLE)
            +
            896
            +
            897C
            +
            898 INTEGER(8) ID(6)
            +
            899 INTEGER(8) MASK32
            +
            900 INTEGER ID84(12)
            +
            901C
            +
            902 CHARACTER * 324 KTITLE
            +
            903C
            +
            904 DATA mask32/z'00000000FFFFFFFF'/
            +
            905C
            +
            906C FORTRAN INTERNAL WRITE STATEMENT REPLACES ENCODE
            +
            907C
            +
            908 100 FORMAT ( 12(1x,z8))
            +
            909C
            +
            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
            +
            914C
            +
            915 WRITE (ktitle(217:324),100) (id84(i),i=1,12)
            +
            916 RETURN
            +
            +
            917 END
            +
            918C> @brief Sets time-averaged titles.
            +
            919C> @author Ralph Jones @date 1988-11-28
            +
            920
            +
            921C> Fills in the first thirteen characters in the title
            +
            922C> to make the title a time-averaged title.
            +
            923C>
            +
            924C> Program history log:
            +
            925C> - Ralph Jones 1988-11-28
            +
            926C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
            +
            927C>
            +
            928C> @param[in] CF1 Forecast period length.
            +
            929C> @param[in] CF2 Length of the average.
            +
            930C> @param[inout] UNIT
            +
            931C> - [in] Originally set to ' hrs'.
            +
            932C> - [out] Set to ' dys' if necessary.
            +
            933C> @param[inout] FOR
            +
            934C> - [in] Originally set to ' for '.
            +
            935C> - [out] Set to ' ctr '.
            +
            936C> @param[inout] AFTBEF
            +
            937C> - [in] Originally set to ' after '.
            +
            938C> - [out] Set to ' befor ' if necessary.
            +
            939C>
            +
            940C> @author Ralph Jones @date 1988-11-28
            +
            +
            941 SUBROUTINE climo(CF1,CF2,UNIT,FOR,AFTBEF)
            +
            942
            +
            943C
            +
            944 REAL CF1
            +
            945 REAL CF2
            +
            946C
            +
            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
            +
            954C
            +
            955 DATA befor /' BEFOR '/
            +
            956 DATA for1 /' CTR '/
            +
            957 DATA unit1 /' DYS'/
            +
            958 DATA unit2 /' HRS'/
            +
            959C
            +
            960C SET FOR TO ' CTR '
            +
            961C
            +
            962 for(1:5) = for1(1:5)
            +
            963C
            +
            964C DIFFERENCE = CENTERDAY - RUNDATE = F1 + 2 DAYS
            +
            965C CHANGE CF1 TO HOURS, ADD 48 HOURS
            +
            966C
            +
            967 diff = cf1 * 12.0 + 48.0
            +
            968C
            +
            969C IF DIFF NEGATIVE, SET AFTBEF TO ' BEFOR '
            +
            970C
            +
            971 IF (diff.LT.0.0) aftbef(1:7) = befor(1:7)
            +
            972C
            +
            973 cf2 = cf2 * 12.0
            +
            974C
            +
            975 IF (abs(diff).LE.72.0) THEN
            +
            976 cf1 = abs(diff)
            +
            977 cf2 = cf2 / 24.0
            +
            978C
            +
            979C SET UNIT TO ' HRS '
            +
            980C
            +
            981 unit(1:4) = unit2(1:4)
            +
            982 GO TO 100
            +
            983 ENDIF
            +
            984C
            +
            985 cf1 = abs(diff / 24.0 )
            +
            986 cf2 = cf2 / 24.0
            +
            987C
            +
            988C SET UNIT TO ' DYS '
            +
            989C
            +
            990 unit(1:4) = unit1(1:4)
            +
            991C
            +
            992 100 CONTINUE
            +
            993 RETURN
            +
            +
            994 END
            +
            995C> @brief Encodes time-averaged title
            +
            996C> @author Ralph Jones @date 1988-11-28
            +
            997
            +
            998C> Encodes the first thirteen characters in the title
            +
            999C> to make the title a time-averaged title.
            +
            1000C>
            +
            1001C> Program history log:
            +
            1002C> - Ralph Jones 1988-11-28
            +
            1003C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
            +
            1004C>
            +
            1005C> @param[in] CF2 Length of the forecast period
            +
            1006C> @param[in] UNIT Units for cf2
            +
            1007C> @param[inout] KTITLE
            +
            1008C> - [in] Title to be modified
            +
            1009C> - [out] Title with the time-averaged included
            +
            1010C>
            +
            1011C> @author Ralph Jones @date 1988-11-28
            +
            +
            1012 SUBROUTINE setcl(CF2,UNIT,KTITLE)
            +
            1013
            +
            1014C
            +
            1015 CHARACTER*324 KTITLE
            +
            1016 CHARACTER*13 BLANK
            +
            1017 CHARACTER*4 UNIT
            +
            1018 CHARACTER*4 DUNIT
            +
            1019 CHARACTER*4 HUNIT
            +
            1020C
            +
            1021 DATA blank /' '/
            +
            1022 DATA dunit /'-DAY'/
            +
            1023 DATA hunit /'-HR '/
            +
            1024C
            +
            1025 100 FORMAT (1x, f4.1, a4, ' AVG' )
            +
            1026C
            +
            1027 ktitle(1:13) = blank(1:13)
            +
            1028C
            +
            1029 WRITE (ktitle(1:13),100) cf2 , dunit(1:4)
            +
            1030C
            +
            1031 RETURN
            +
            +
            1032 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
            +
            w3fp06
            subroutine w3fp06(id, ktitle, n)
            Provides a title for data fields formulated according to nmc o.n.
            Definition w3fp06.f:26
            +
            value1
            subroutine value1(s, c, e, num)
            Creates value1 of surface from ids.
            Definition w3fp06.f:746
            +
            setcl
            subroutine setcl(cf2, unit, ktitle)
            Encodes time-averaged title.
            Definition w3fp06.f:1013
            +
            line03
            subroutine line03(id, ktitle)
            Creates the third line of title.
            Definition w3fp06.f:896
            +
            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
            +
            line01
            subroutine line01(id, mask, ktitle)
            Creates the first line of title.
            Definition w3fp06.f:70
            diff --git a/w3fp10_8f.html b/w3fp10_8f.html index 3147fa98..8a6bd391 100644 --- a/w3fp10_8f.html +++ b/w3fp10_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp10.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +

            @@ -62,7 +62,7 @@
            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fp10.f File Reference
            +
            w3fp10.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fp10 (rdata, ktbl, cnst, title, krect, kcontr, linev, iwidth)
             Prints a two-dimensional grid of any shape, with contouring, if desired.
             

            Detailed Description

            Printer contour subroutine.

            @@ -107,8 +113,8 @@

            Definition in file w3fp10.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fp10()

            + +

            ◆ w3fp10()

            @@ -117,49 +123,49 @@

            subroutine w3fp10 ( real, dimension(*)  - RDATA, + rdata, integer, dimension(*)  - KTBL, + ktbl, real, dimension(4)  - CNST, + cnst, integer, dimension(33)  - TITLE, + title,   - KRECT, + krect,   - KCONTR, + kcontr,   - LINEV, + linev,   - IWIDTH  + iwidth  @@ -171,7 +177,7 @@

            +

            Program History Log

            @@ -195,7 +201,7 @@

            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.
            +
            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.

            @@ -211,7 +217,7 @@

            diff --git a/w3fp10_8f.js b/w3fp10_8f.js index 539c5b8b..f5f18993 100644 --- a/w3fp10_8f.js +++ b/w3fp10_8f.js @@ -1,4 +1,4 @@ var w3fp10_8f = [ - [ "w3fp10", "w3fp10_8f.html#a2d0f404c14f9e2ea8e6a9f0e911a825e", null ] + [ "w3fp10", "w3fp10_8f.html#ac8a2ca08aafc6e727d1e230f69c734b3", null ] ]; \ No newline at end of file diff --git a/w3fp10_8f_source.html b/w3fp10_8f_source.html index c33bce1e..f13c97e6 100644 --- a/w3fp10_8f_source.html +++ b/w3fp10_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp10.f Source File @@ -23,10 +23,9 @@

            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,718 +81,726 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fp10.f
            +
            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
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief Printer contour subroutine.
            +
            3C> @author Ralph Jones @date 1989-09-08
            +
            4
            +
            5C> Prints a two-dimensional grid of any shape, with
            +
            6C> contouring, if desired. Grid values are scaled according to
            +
            7C> to constants specified by the programer, rounded, and printed
            +
            8C> as 4,3, or 2 digit integers with sign, the sign marking the
            +
            9C> grid position of the printed number. If contouring is requested,
            +
            10C> bessel's interpolation formula is used to optain the contour lines.
            +
            11C> Contours are indicated by alphabetic characters ranging from a to
            +
            12C> h or numeric characters from 0 to 9. Contour origin and interval
            +
            13C> are specified by the programmer in terms of printed values.
            +
            14C>
            +
            15C> ### Program History Log
            +
            16C> Date | Programmer | Comments
            +
            17C> -----|------------|---------
            +
            18C> 1989-09-08 | Ralph Jones | Initial
            +
            19C> 1992-05-02 | Ralph Jones | Convert to cray cft77 fortran, add save.
            +
            20C>
            +
            21C> @param[in] RDATA Real array of grid data to be printed.
            +
            22C> @param[in] KTBL Integer array with shape of array.
            +
            23C> @param[in] CNST Real array of four elements, used in
            +
            24C> scaling for printing and contouring.
            +
            25C> @param[in] TITLE Is a array of 132 characters or less of
            +
            26C> hollerith data, 1st char. must be blank.
            +
            27C> printed at bottom of the map.
            +
            28C> @param[in] KRECT 1 if grid is rectangular, 0 otherwise.
            +
            29C> @param[in] KCONTR 1 for contouring , 0 otherwise.
            +
            30C> @param[in] LINEV 0 is for 6 lines per vertical inch,
            +
            31C> non-zero 8 lines per vertical inch.
            +
            32C> @param[in] IWIDTH Number of characters in print line,
            +
            33C> 132 is standard printer.
            +
            34C>
            +
            35C> Return conditions: Normal subroutine return, unless number of rows is
            +
            36C> greater than 200, prints error message and exits.
            +
            37C>
            +
            38C> @note Special version of w3fp05(), 1st point is upper left hand
            +
            39C> corner. Written on request of peter chase because some
            +
            40C> grib fields can start with the upper left hand corner
            +
            41C> as the 1st point of a grid.
            +
            42C>
            +
            43C> @author Ralph Jones @date 1989-09-08
            +
            +
            44 SUBROUTINE w3fp10(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,
            +
            45 & LINEV,IWIDTH)
            +
            46C
            +
            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)
            +
            56C
            +
            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
            +
            71C
            +
            72 LOGICAL DONE
            +
            73 LOGICAL LCNTR
            +
            74 LOGICAL RECT
            +
            75C
            +
            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)
            +
            88C
            +
            89 equivalence(crmx,vdja(29))
            +
            90 equivalence(kline(1),klines(8))
            +
            91 equivalence(vdjc(1),rwa(1))
            +
            92C
            +
            93C ... THE VALUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE
            +
            94C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE
            +
            95C ... FLOATING POINT NUMBER FOR THE COMPUTER.
            +
            96C
            +
            97 SAVE
            +
            98C> The value CRMX is machine dependent, it should be
            +
            99C> set to a value a little less than the largest positive
            +
            100C> 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
            +
            112C> 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/
            +
            119C
            +
            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)
            +
            128C
            +
            129C COMPUTE VALUES FOR PRINTER WIDTH
            +
            130C
            +
            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
            +
            138C
            +
            139 IF (linev .NE. 0) THEN
            +
            140C
            +
            141C ...OTHERWISE LINEV IS NON-ZERO, SO 8 LINES/INCH IS DESIRED...
            +
            142C
            +
            143 linate = 1
            +
            144 r4 = 0.250
            +
            145 r32 = 0.03125
            +
            146 con2 = 10.0
            +
            147 nbtwn = 3
            +
            148C
            +
            149 ELSE
            +
            150C
            +
            151 linate = 2
            +
            152 r4 = 0.33333333
            +
            153 r32 = 1.0 / 18.0
            +
            154 con2 = 6.0
            +
            155 nbtwn = 2
            +
            156 ENDIF
            +
            157C
            +
            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)
            +
            166C
            +
            167C TO SET NO. OF DIGITS TO BE PRINTED
            +
            168C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR
            +
            169C
            +
            170 nodig = iabs(kcontr/10)
            +
            171 nodig = 3 - nodig
            +
            172C
            +
            173C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED
            +
            174C
            +
            175 IF (nodig.LT.1 .OR. nodig.GT.3) nodig = 3
            +
            176C
            +
            177C ANY OUT-OF-RANGE WILL GET 4 DIGITS
            +
            178C
            +
            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
            +
            183C
            +
            184C OTHERWISE RESET NCONQ
            +
            185C
            +
            186 nconq = 0
            +
            187 GO TO 400
            +
            188C
            +
            189 300 CONTINUE
            +
            190 lcntr = .true.
            +
            191C
            +
            192C WITH NCONQ = 1 FOR LETTERS,AND = 2 FOR NUMBERS IN CONTOUR BANDS
            +
            193C
            +
            194 400 CONTINUE
            +
            195 IF (nconq .NE. 2) THEN
            +
            196C
            +
            197C OTHERWISE SET AS LETTERS
            +
            198C
            +
            199 kcow = 16
            +
            200 DO 500 j = 1,kcow
            +
            201 kalph(j) = kalfa(j)
            +
            202 500 CONTINUE
            +
            203C
            +
            204 ELSE
            +
            205C
            +
            206 kcow = 20
            +
            207 DO 700 j = 1,kcow
            +
            208 kalph(j) = knumb(j)
            +
            209 700 CONTINUE
            +
            210C
            +
            211 ENDIF
            +
            212C
            +
            213 radj = 4 * kcow
            +
            214 kd = 1
            +
            215C
            +
            216C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW
            +
            217C *** THIS IS KRLOC
            +
            218C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX)
            +
            219C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET
            +
            220C
            +
            221 IF (ktbl(1 ).NE.(-1)) THEN
            +
            222C
            +
            223C *** ONE-DIMENSIONAL FORM
            +
            224C
            +
            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
            +
            236C
            +
            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
            +
            248C
            +
            249 ELSE
            +
            250C
            +
            251C *** TWO-DIMENSIONAL FORM
            +
            252C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT
            +
            253C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE
            +
            254C *** THAT IS, WITH THE FIRST INDEX VARYING THE FASTEST
            +
            255C
            +
            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
            +
            263C
            +
            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
            +
            280C
            +
            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)
            +
            286C
            +
            287C *** PRINT I-LABELS ACROSS TOP OF MAP
            +
            288C
            +
            289 1700 CONTINUE
            +
            290C
            +
            291C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH
            +
            292C
            +
            293 IF (linate.EQ.1) WRITE (output,8100)
            +
            294C
            +
            295C ...WHICH PREPARES PRINTER FOR 6 LINES PER INCH
            +
            296C
            +
            297 IF (linate.EQ.2) WRITE (output,8200)
            +
            298 klines(1) = khrstr
            +
            299 kbr = 1
            +
            300 GO TO 6900
            +
            301C
            +
            302 1800 CONTINUE
            +
            303 IF (.NOT.lcntr) GO TO 2000
            +
            304C
            +
            305C *** INITIALIZE CONTOUR WORKING AREA
            +
            306C
            +
            307 DO 1900 j = 1,pagn3
            +
            308 rwc(j) = crmx
            +
            309 rwd(j) = crmx
            +
            310 1900 CONTINUE
            +
            311C
            +
            312C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS
            +
            313C
            +
            314 2000 CONTINUE
            +
            315 kra = 1
            +
            316 kc = ktf + 1
            +
            317 kbr = 2
            +
            318 GO TO 5900
            +
            319C
            +
            320 2100 CONTINUE
            +
            321 kra = 2
            +
            322 kc = kc + kca
            +
            323 kbr = 3
            +
            324 GO TO 5900
            +
            325C
            +
            326 2200 CONTINUE
            +
            327 kr = 0
            +
            328C
            +
            329C *** TEST IF THIS IS LAST PAGE
            +
            330C
            +
            331 IF (imax.GT.pgmax-1) GO TO 2300
            +
            332 lmr = imax * 5 + 2
            +
            333 done = .true.
            +
            334C
            +
            335C *** DO LEFT J-LABELS
            +
            336C
            +
            337 2300 CONTINUE
            +
            338 jcurr = jmin
            +
            339C
            +
            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
            +
            349C
            +
            350 2500 CONTINUE
            +
            351 IF (linate.EQ.1) WRITE (output,8300)
            +
            352 IF (linate.EQ.2) WRITE (output,8400)
            +
            353C
            +
            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
            +
            366C
            +
            367 2700 CONTINUE
            +
            368 klines(3) = khtbl(ktb+1)
            +
            369 klines(4) = khtbl(kta+1)
            +
            370 klines(5) = khblnk
            +
            371C
            +
            372 2800 CONTINUE
            +
            373 DO 2900 j = 6,mxpg
            +
            374 klines(j) = khblnk
            +
            375 2900 CONTINUE
            +
            376 IF (.NOT.done) GO TO 3000
            +
            377C
            +
            378C *** DO RIGHT J-LABELS IF LAST PAGE OF MAP
            +
            379C
            +
            380 kline(lmr) = klines(2)
            +
            381 kline(lmr+1) = klines(3)
            +
            382 kline(lmr+2) = klines(4)
            +
            383 kline(lmr+3) = klines(5)
            +
            384C
            +
            385C *** FETCH AND CONVERT GRID VALUES TO A1 FORMAT FOR WHOLE LINE
            +
            386C
            +
            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
            +
            399C
            +
            400 3200 CONTINUE
            +
            401 ktb = mod(ktemp,1000)/100
            +
            402C
            +
            403 3300 CONTINUE
            +
            404 ktc = mod(ktemp,100)/10
            +
            405 ktd = mod(ktemp,10)
            +
            406 GO TO (3400,3500,3600),nodig
            +
            407C
            +
            408 3400 CONTINUE
            +
            409 kline(klx+1) = khtbl(ktc+1)
            +
            410 kline(klx+2) = khtbl(ktd+1)
            +
            411 GO TO 3700
            +
            412C
            +
            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
            +
            418C
            +
            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)
            +
            424C
            +
            425 3700 CONTINUE
            +
            426 klx = klx + 5
            +
            427 krx = krx + 1
            +
            428 3800 CONTINUE
            +
            429C
            +
            430C *** FOLLOWING CHECKS FOR POLE POINT AND INSERTS PROPER CHARACTER.
            +
            431C
            +
            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
            +
            440C
            +
            441 3900 CONTINUE
            +
            442 kline(kx+1) = khastr
            +
            443C
            +
            444C *** PRINT LINE OF MAP DATA
            +
            445C
            +
            446 4000 CONTINUE
            +
            447 WRITE (output,8500) (klines(ii),ii=1,mxpg)
            +
            448 krloc(kr) = krx
            +
            449 jcurr = jcurr + 1
            +
            450C JCURR = JCURR + JRWMP
            +
            451C
            +
            452C *** TEST BOTTOM OF MAP
            +
            453C
            +
            454 IF (kr.EQ.nrws) GO TO 5700
            +
            455C
            +
            456C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW
            +
            457C
            +
            458 kbr = 4
            +
            459 GO TO 5900
            +
            460C
            +
            461 4100 CONTINUE
            +
            462 IF (.NOT.lcntr) GO TO 2400
            +
            463C
            +
            464C *** DO CONTOURING
            +
            465C
            +
            466 DO 4200 jj = 1,mxpg
            +
            467 klines(jj) = khblnk
            +
            468 4200 CONTINUE
            +
            469C
            +
            470C *** VERTICAL INTERPOLATIONS
            +
            471C
            +
            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
            +
            477C
            +
            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
            +
            482C
            +
            483 4400 CONTINUE
            +
            484 vdjc(kk) = r32*(rwa(kk)+rwd(kk)-rwb(kk)-rwc(kk))
            +
            485C
            +
            486 4500 CONTINUE
            +
            487 vdjb(kk) = r4*(rwc(kk)-rwb(kk)-con2*vdjc(kk))
            +
            488C
            +
            489 4600 CONTINUE
            +
            490 vdja(kk)=rwb(kk)
            +
            491C
            +
            492 4700 CONTINUE
            +
            493C
            +
            494C ...DO 2 OR 3 ROWS OF CONTOURING BETWEEN GRID ROWS...
            +
            495C
            +
            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
            +
            501C
            +
            502C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW
            +
            503C *** HORIZONTAL INTERPOLATIONS
            +
            504C
            +
            505 hdc = 0.0
            +
            506 IF (vdja(1).GE.crmx) GO TO 4900
            +
            507 hdc = r50*(vdja(4)+vdja(1)-vdja(2)-vdja(3))
            +
            508C
            +
            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)
            +
            517C
            +
            518C *** COMPUTE AND STORE CONTOUR CHARACTERS, 5 PER POINT
            +
            519C
            +
            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
            +
            533C
            +
            534 5100 CONTINUE
            +
            535 kxb = kxb + 5
            +
            536C
            +
            537 5200 CONTINUE
            +
            538C
            +
            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
            +
            545C
            +
            546 5500 CONTINUE
            +
            547 khda = hda
            +
            548 kdb = iabs(mod(khda,kcow))
            +
            549 kline(kxb+1) = kalph(kdb+1)
            +
            550 GO TO 5300
            +
            551C
            +
            552 5600 CONTINUE
            +
            553 GO TO 2400
            +
            554C
            +
            555 5700 CONTINUE
            +
            556 IF (linate.EQ.1) WRITE (output,8300)
            +
            557 IF (linate.EQ.2) WRITE (output,8400)
            +
            558 klines(1) = khblnk
            +
            559C
            +
            560C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE
            +
            561C
            +
            562 kbr = 5
            +
            563 GO TO 6900
            +
            564C
            +
            565 5800 CONTINUE
            +
            566 IF (linate.EQ.1) WRITE (output,8300)
            +
            567 IF (linate.EQ.2) WRITE (output,8400)
            +
            568C
            +
            569C *** PRINT TITLE
            +
            570C
            +
            571 WRITE (output,8600) (title(ii),ii=1,lw)
            +
            572C
            +
            573C *** TEST END OF MAP
            +
            574C
            +
            575 IF (krloc(kclmx).EQ.kcmx) RETURN
            +
            576C
            +
            577C *** ADJUST PAGE LINE BOUNDARIES
            +
            578C
            +
            579 IF (imax.GT.pgmax) imax = imax - pgmax
            +
            580 imin = ka
            +
            581 pagnl = pagnl + pgmax
            +
            582 pagnr = pagnr + pgmax
            +
            583 GO TO 1700
            +
            584C
            +
            585C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS
            +
            586C
            +
            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
            +
            605C
            +
            606 6000 CONTINUE
            +
            607 rect = krect.EQ.1.AND.pgcnta.LE.krcnt
            +
            608C
            +
            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
            +
            617C
            +
            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
            +
            626C
            +
            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
            +
            636C
            +
            637 6500 CONTINUE
            +
            638 IF (pccnt.GT.0) GO TO 6600
            +
            639 pgcnta = 0
            +
            640 pccnt = 0
            +
            641 GO TO 6100
            +
            642C
            +
            643 6600 CONTINUE
            +
            644 pgcnta = min(pgmax,krcnt+krfst-pagnl)
            +
            645 GO TO 6100
            +
            646C
            +
            647 6700 CONTINUE
            +
            648 pgcnta = 0
            +
            649C
            +
            650 6800 CONTINUE
            +
            651 pccnt = 0
            +
            652 GO TO 6100
            +
            653C
            +
            654C *** ROUTINE TO PRINT I-LABELS
            +
            655C
            +
            656 6900 CONTINUE
            +
            657 DO 7000 kk = 2,mxpg
            +
            658 klines(kk) = khblnk
            +
            659 7000 CONTINUE
            +
            660C
            +
            661 kk = 1
            +
            662 ka = imin
            +
            663 lbl = min(imax,pgmax)
            +
            664C
            +
            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
            +
            676C
            +
            677 7100 CONTINUE
            +
            678 kline(kk+1) = khtbl(kta+1)
            +
            679 kline(kk+2) = khtbl(ktb+1)
            +
            680C
            +
            681 7200 CONTINUE
            +
            682 kk = kk + 5
            +
            683 ka = ka + 1
            +
            684C
            +
            685 7300 CONTINUE
            +
            686C
            +
            687 WRITE (output,8500) (klines(ii),ii=1,mxpg)
            +
            688C
            +
            689 GO TO (1800,2100,2200,4100,5800) kbr
            +
            690C
            +
            691 7400 CONTINUE
            +
            692 RETURN
            +
            693C
            +
            +
            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/w3fp11_8f.html b/w3fp11_8f.html index ab5854c7..5959d986 100644 --- a/w3fp11_8f.html +++ b/w3fp11_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp11.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@

            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fp11.f File Reference
            +
            w3fp11.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fp11 (ipds0, ipds, titl, ierr)
             Converts GRIB formatted product definition section version 1 to a one line readable title.
             

            Detailed Description

            One-line GRIB titler from pds section.

            @@ -107,8 +113,8 @@

            Definition in file w3fp11.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fp11()

            + +

            ◆ w3fp11()

            @@ -117,25 +123,25 @@

            subroutine w3fp11 ( character * 8  - IPDS0, + ipds0, character * (*)  - IPDS, + ipds, character * 86  - TITL, + titl, integer  - IERR  + ierr  @@ -147,7 +153,7 @@

            +

            Program History Log:

            @@ -273,7 +279,7 @@

            diff --git a/w3fp11_8f.js b/w3fp11_8f.js index 26f7219c..5f2ab8a1 100644 --- a/w3fp11_8f.js +++ b/w3fp11_8f.js @@ -1,4 +1,4 @@ var w3fp11_8f = [ - [ "w3fp11", "w3fp11_8f.html#a60348721f6e1b543427aba610af0a85d", null ] + [ "w3fp11", "w3fp11_8f.html#a0e68dda36ce06180df15d26525b8ad92", null ] ]; \ No newline at end of file diff --git a/w3fp11_8f_source.html b/w3fp11_8f_source.html index 0bdb07d2..8941b2ae 100644 --- a/w3fp11_8f_source.html +++ b/w3fp11_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp11.f Source File @@ -23,10 +23,9 @@

            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,840 +81,848 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fp11.f
            +
            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
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief One-line GRIB titler from pds section.
            +
            3C> @author Ralph Jones @date 1991-06-19
            +
            4
            +
            5C> Converts GRIB formatted product definition section version
            +
            6C> 1 to a one line readable title. GRIB section 0 is also tested to
            +
            7C> verify that GRIB data is being deciphered.
            +
            8C>
            +
            9C> ### Program History Log:
            +
            10C> Date | Programmer | Comments
            +
            11C> -----|------------|---------
            +
            12C> 1991-06-19 | Ralph Jones | Initial
            +
            13C> 1992-05-29 | Ralph Jones | Add water temp to tables
            +
            14C> 1993-01-19 | Ralph Jones | Add montgomary stream function to tables. add code for surface value 113. add condensation pressure to tables
            +
            15C> 1993-02-19 | Ralph Jones | Add cape and tke (157 & 158) to tables
            +
            16C> 1993-02-24 | Ralph Jones | Add GRIB type pmsle (130) to tables
            +
            17C> 1993-03-26 | Ralph Jones | Add GRIB type sglyr (175) to tables
            +
            18C> 1993-03-27 | Ralph Jones | Changes for revised o.n.388 mar. 3,1993
            +
            19C> 1993-03-29 | Ralph Jones | Add save statement
            +
            20C> 1993-04-16 | Ralph Jones | Add GRIB type lat, lon (176,177) to tables
            +
            21C> 1993-04-25 | Ralph Jones | Add GRIB type 204, 205, 211, 212, 218
            +
            22C> 1993-05-18 | Ralph Jones | Add test for model 70
            +
            23C> 1993-06-26 | Ralph Jones | Add GRIB type 128, 129, take out test for MODEL 86.
            +
            24C> 1993-08-07 | Ralph Jones | Add GRIB type 156 (cin), 150 (cbmzw), 151 (cbtzw), 152 (cbtmw) to tables.
            +
            25C> 1993-10-14 | Ralph Jones | Change for o.n. 388 rev. oct. 8,1993
            +
            26C> 1993-10-29 | Ralph Jones | Change for 'l cdc' 'm cdc' 'h cdc'
            +
            27C> 1993-10-14 | Ralph Jones | Change for o.n. 388 rev. nov. 19,1993
            +
            28C> 1994-02-05 | Ralph Jones | Change for o.n. 388 rev. dec. 14,1993. add model number 86 and 87.
            +
            29C> 1994-03-24 | Ralph Jones | Add GRIB type 24 (toto3), 206 (uvpi)
            +
            30C> 1994-06-04 | Ralph Jones | Change uvpi to uvi
            +
            31C> 1994-06-16 | Ralph Jones | Add GRIB type 144,145,146,147,148,149 soilw,pevpr,cwork,u-gwd,v-gwd,pv to tables.
            +
            32C> 1994-06-22 | Ralph Jones | Add ncar (60) to centers
            +
            33C> 1994-07-25 | Ralph Jones | Correction for 71, 72, 213 (t cdc), (cdcon), (cdlyr)
            +
            34C> 1994-10-27 | Ralph Jones | Add GRIB type 191 (prob), 192 (probn), add test for model 90, 91, 92, 93, add sub center 2.
            +
            35C> 1995-02-09 | Ralph Jones | Correction for century for fnoc
            +
            36C> 1995-04-11 | Ralph Jones | Correction for lmh and lmv
            +
            37C> 1995-06-20 | Ralph Jones | Add GRIB type 189 (vstm), 190 (hlcy), 193 (pop), 194 (cpofp), 195 (cpozp), 196 (ustm), 197 (vstm) to tables.
            +
            38C> 1995-08-07 | Ralph Jones | Add GRIB type 153 (clwmr), 154 (o3mr), 221 (hpbl), 237 (o3tot).
            +
            39C> 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
            +
            40C> ^ | ^ | Level 119, add 120 layer betwwen two eta levels. change name of level 107 to (sigl), change name of level 108 to (sigy).
            +
            41C> 1995-09-26 | Ralph Jones | Add level 204 (htfl) highest tropsphere freezing level.
            +
            42C> 1995-10-19 | Ralph Jones | Change some of the level abreviations.
            +
            43C> 1995-12-13 | Ralph Jones | Add 8 sub-centers to tables
            +
            44C> 1996-03-04 | Ralph Jones | Changes for o.n. 388 jan 2, 1996
            +
            45C> 1996-03-22 | Ralph Jones | Change scusf to csusf
            +
            46C> 1996-10-01 | Mark Iredell | Recognize forecast time units 1 to 12 and correct for year 2000
            +
            47C> 1996-10-31 | Ralph Jones | Change array and table for ics1 to 10.
            +
            48C> 1996-10-01 | Mark Iredell | Allow parameter table version up to 127
            +
            49C> 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)
            +
            50C> 1998-12-21 | Stephen Gilbert | Replaced function ichar with mova2i.
            +
            51C> 1901-01-05 | Boi Vuong | Add level 247 (ehlt) equilibrium level
            +
            52C> 1902-05-01 | Boi Vuong | Changes for o.n. 388 mar 21, 2002
            +
            53C> 1902-03-25 | Boi Vuong | Add GRIB table version 129 and 130
            +
            54C> 1903-07-02 | Stephen Gilbert | Added 5 new params to table version 129
            +
            55C> 1904-14-04 | Boi Vuong | Add GRIB table version 131 and added 12 new parameter to table version 129
            +
            56C> 1904-08-09 | Boi Vuong | Add parameter (thflx) to table version 129
            +
            57C> 1905-02-08 | Cooke | Corrected entry for freezing rain, crfzr to cfrzr in the hhnam1 array
            +
            58C> 1906-08-11 | Boi Vuong | Add levels (235,236,237,238,240,245) and added new parameters to table version 129 and added
            +
            59C> ^ | ^ | One parameter 154 to table version 130 and added table version 128
            +
            60C> 1907-04-05 | Boi Vuong | Add parameters to table version 128, 129 and 130
            +
            61C> 1907-05-15 | Boi Vuong | Added time range indicator 51 and new table 140
            +
            62C>
            +
            63C> @param[in] IPDS0 GRIB section 0 read as character*8
            +
            64C> @param[in] IPDS GRIB pds section read as character*28
            +
            65C> @param[out] TITL Character*86 output print line
            +
            66C> @param[out] IERR
            +
            67C> 0 - Completed satisfactorily
            +
            68C> 1 - GRIB section 0, can not find 'GRIB'
            +
            69C> 2 - GRIB is not version 1
            +
            70C> 3 - Length of pds section is less than 28
            +
            71C> 4 - Could not match type indicator
            +
            72C> 5 - Could not match type level
            +
            73C> 6 - Could not interpret originator of code
            +
            74C> 7 - Could not interpret sub center 7 originator of code
            +
            75C> 8 - Could not interpret sub center 9 originator of code
            +
            76C> 9 - Parameter table version not 1 or 2
            +
            77C>
            +
            +
            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
            +
            97C
            +
            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
            +
            119C
            +
            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))
            +
            126C
            +
            127 SAVE
            +
            128C
            +
            129 DATA center/ 7, 8, 9, 34, 52, 54, 57,
            +
            130 & 58, 59, 60, 61, 62, 74, 85,
            +
            131 & 97, 98, 99/
            +
            132C
            +
            133C TABLE 3 - TYPE AND VALUE OF LEVELS (PDS OCTETS 10, 11 AND 12)
            +
            134C
            +
            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'/
            +
            157C
            +
            158C GRIB TABLE VERSION 2 (PDS OCTET 4 = 2)
            +
            159C
            +
            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'/
            +
            238C
            +
            239C GRIB TABLE VERSION 128 (PDS OCTET 4 = 128)
            +
            240C ( OCEANGRAPHIC PARAMETER )
            +
            241C
            +
            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'/
            +
            266C
            +
            267C GRIB TABLE VERSION 129 (PDS OCTET 4 = 129)
            +
            268C
            +
            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',' ',' ',' ',' ',' '/
            +
            299C
            +
            300C GRIB TABLE VERSION 130 (PDS OCTET 4 = 130)
            +
            301C ( FOR LAND MODELING AND LAND DATA ASSIMILATION )
            +
            302C
            +
            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 ',' '/
            +
            337C
            +
            338C GRIB TABLE VERSION 140 (PDS OCTET 4 = 140)
            +
            339C ( FOR WORLD AREA FORECAST SYSTEM (WAF/ICAO)
            +
            340C
            +
            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 '/
            +
            375C
            +
            376C GRIB TABLE VERSION 131 (PDS OCTET 4 = 131)
            +
            377C
            +
            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 '/
            +
            450C
            +
            451C ONE LINE CHANGE FOR HDS (IBM370) (ASCII NAME GRIB IN HEX)
            +
            452C
            +
            453C DATA GRIB /Z47524942/
            +
            454C
            +
            455C ONE LINE CHANGE FOR CRAY AND WORKSTATIONS
            +
            456C
            +
            457 DATA grib /'GRIB'/
            +
            458C
            +
            459C TABLE O (PDS OCTET 5) NATIONAL/INTERNATIONAL
            +
            460C ORIGINATING CENTERS
            +
            461C
            +
            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 '/
            +
            472C
            +
            473C TABLE C (PDS OCTET 26) NATIONAL SUB-CENTERS
            +
            474C
            +
            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'/
            +
            503C
            +
            504C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
            +
            505C
            +
            506C 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
            +
            507C - NO. OF ENTRIES IN TYPE LEVEL
            +
            508C - NO. OF ENTRIES IN CNTR PROD. DTA.
            +
            509C - NO. OF ENTRIES IN SUB CNTR1 PROD. DTA.
            +
            510C - NO. OF ENTRIES IN SUB CNTR2 PROD. DTA.
            +
            511C
            +
            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
            +
            523C
            +
            524 titl(1:30) = ' '
            +
            525 titl(31:60) = ' '
            +
            526 titl(61:86) = ' '
            +
            527C
            +
            528C ---------------------------------------------------------------------
            +
            529C$ 2.0 TEST SECTION 0 FOR ASCII 'GRIB'
            +
            530C
            +
            531 IF (grib(1:4) .NE. ipds0(1:4)) THEN
            +
            532 ierr = 1
            +
            533 RETURN
            +
            534 ENDIF
            +
            535C
            +
            536C TEST SECTION 0 FOR GRIB VERSION 1
            +
            537C
            +
            538 IF (mova2i(ipds0(8:8)).NE.1) THEN
            +
            539 ierr = 2
            +
            540 RETURN
            +
            541 END IF
            +
            542C
            +
            543C TEST THE LENGTH OF THE PDS (SECTION 1)
            +
            544C
            +
            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
            +
            553C
            +
            554C TEST PDS (OCTET 4) FOR PARAMETER TABLE VERSION
            +
            555C NUMBER 1 OR 2 OR 128, 129 OR 130 OR 131 OR 140
            +
            556C
            +
            557 iver = mova2i(idpds(4:4))
            +
            558 IF (iver.GT.131) THEN
            +
            559 ierr = 9
            +
            560 RETURN
            +
            561 END IF
            +
            562C
            +
            563C 4.0 FIND THE INDICATOR AND TYPE LEVELS
            +
            564C
            +
            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
            +
            610C
            +
            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 '
            +
            616C
            +
            617C TAKE OUT AFTER ALL PROGRAMS ARE CHANGED THAT USE 24
            +
            618C FOR TOTAL OZONE.
            +
            619C
            +
            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))
            +
            626C
            +
            627C CORRECTION FOR 'NLAT' 'ELON' 'L CDC' 'M CDC', 'H CDC',
            +
            628C 'T CDC'
            +
            629C
            +
            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
            +
            641C
            +
            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
            +
            654C 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
            +
            680C
            +
            681C 5.0 INSERT THE YEAR,DAY,MONTH AND TIME
            +
            682C
            +
            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))
            +
            689C
            +
            690C SUBTRACT 1 FROM CENTURY TO MAKE 4 DIGIT YEAR
            +
            691C
            +
            692 icen = icen - 1
            +
            693C
            +
            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
            +
            708C
            +
            709C ADD CORRECTION IF BYTE 21 (TIME RANGE) IS 2
            +
            710C
            +
            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
            +
            717C
            +
            718C PRECIP AMOUNTS
            +
            719C
            +
            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'
            +
            726C
            +
            727C AVERAGE
            +
            728C
            +
            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'
            +
            735C
            +
            736C CLIMATOLOGICAL MEAN VALUE
            +
            737C
            +
            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
            +
            747C
            +
            748C TEST FOR ANALYSIS (MAKE CORRECTION IF MODEL IS ANALYSIS)
            +
            749C
            +
            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
            +
            766C
            +
            767C TEST FOR 00-HR FCST (INITIALIZED ANALYSIS)
            +
            768C
            +
            769 IF (timerg.EQ.1.AND.p1.EQ.0) THEN
            +
            770 titl(29:42) = ' 00-HR FCST '
            +
            771 ENDIF
            +
            772C
            +
            773C$ 3.0 FIND WHO GENERATED THE CODE
            +
            774C$ CHECK FOR SUB-CENTERS
            +
            775C
            +
            776 igenc = mova2i(idpds(5:5))
            +
            777 isubc = mova2i(idpds(26:26))
            +
            778C
            +
            779C TEST FOR SUB-CENTERS WHEN CENTER IS 7
            +
            780C
            +
            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
            +
            791C
            +
            792C TEST FOR SUB-CENTERS WHEN CENTER IS 9
            +
            793C
            +
            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
            +
            803C
            +
            804C TEST TO SEE IF CENTER IN TABLES
            +
            805C
            +
            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
            +
            812C
            +
            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/w3fp12_8f.html b/w3fp12_8f.html index 045a91b8..643b507e 100644 --- a/w3fp12_8f.html +++ b/w3fp12_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp12.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@
            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fp12.f File Reference
            +
            w3fp12.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fp12 (id8, iflag, idpds, icent, iscale, ier)
             Formats the product definition section according to the specifications set by WMO.
             

            Detailed Description

            Creates the product definition section.

            @@ -107,8 +113,8 @@

            Definition in file w3fp12.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fp12()

            + +

            ◆ w3fp12()

            @@ -117,37 +123,37 @@

            subroutine w3fp12 ( integer(8), dimension ( 4)  - ID8, + id8, character*1  - IFLAG, + iflag, character*1, dimension (28)  - IDPDS, + idpds, integer  - ICENT, + icent, integer  - ISCALE, + iscale,   - IER  + ier  @@ -159,7 +165,7 @@

            +

            Program History Log:

            @@ -169,7 +175,7 @@

            - + @@ -215,7 +221,7 @@

            diff --git a/w3fp12_8f.js b/w3fp12_8f.js index 073b9d80..f0e8eab0 100644 --- a/w3fp12_8f.js +++ b/w3fp12_8f.js @@ -1,4 +1,4 @@ var w3fp12_8f = [ - [ "w3fp12", "w3fp12_8f.html#a43259ead9ef06e1822639a8f2aa106aa", null ] + [ "w3fp12", "w3fp12_8f.html#a90be3644f6c4c935c450a188c5193a3f", null ] ]; \ No newline at end of file diff --git a/w3fp12_8f_source.html b/w3fp12_8f_source.html index 2e14e3c7..f3493707 100644 --- a/w3fp12_8f_source.html +++ b/w3fp12_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp12.f Source File @@ -23,10 +23,9 @@

            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
            1992-11-02 Ralph Jones Correction at same level as w3fp12() in v77w3lib on hds
            1993-03-29 Ralph Jones Add save statement
            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,620 +81,628 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fp12.f
            +
            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
            -
            mova2i
            integer function mova2i(a)
            This Function copies a bit string from a Character*1 variable to an integer variable.
            Definition: mova2i.f:25
            -
            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
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief Creates the product definition section
            +
            3C> @author A.J. McClees @date 1991-07-30
            +
            4
            +
            5C> Formats the product definition section according to the
            +
            6C> specifications set by WMO. Using o.n. 84 id's (1st 8 words)
            +
            7C> as the input data. New subroutine corresponds to the revision
            +
            8C> #1 of the WMO GRIB standards made march 15, 1991.
            +
            9C>
            +
            10C> ### Program History Log:
            +
            11C> Date | Programmer | Comments
            +
            12C> -----|------------|---------
            +
            13C> 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.
            +
            14C> 1992-01-06 | A.J. McClees | Delete paramater 202 (accumulated evap) and make parameter 57 (evaporation) the equivalent of o.n.84 117.
            +
            15C> 1992-11-02 | Ralph Jones | Correction at same level as w3fp12() in v77w3lib on hds
            +
            16C> 1993-03-29 | Ralph Jones | Add save statement
            +
            17C> 1993-04-16 | Ralph Jones | Add 176, 177 lat, lon to tables
            +
            18C> 1993-08-03 | Ralph Jones | Add 156 (cin), 204 (dswrf), 205 (dlwrf) 211 (uswrf), 212 (ulwrf) to tables
            +
            19C> 1995-02-07 | Ralph Jones | Change pds byte 4, version number to 2.
            +
            20C> 1995-07-14 | Ralph Jones | Correction for sfc lft x
            +
            21C> 1998-03-10 | Boi Vuong | Remove the cdir$ integer=64 directive
            +
            22C> 1998-12-21 | Stephen Gilbert | Replaced Function ICHAR with mova2i().
            +
            23C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
            +
            24C> 1999-03-15 | Stephen Gilbert | Specified 8-byte integer array explicitly for ID8
            +
            25C> 1999-03-22 | B. Facey | Remove the date recalculation for mean charts. this includes the previous change to w3movdat.
            +
            26C>
            +
            27C> @param[in] ID8 First 8 id workds (o.n.84) integer*4
            +
            28C> @param[in] ICENT Century, 2 digits, for 1991 it is 20.
            +
            29C> @param[in] IFLAG Indication of inclusion or omission of grid definition and/or bit map code character*1
            +
            30C> @param[in] ISCALE 10 scaler integer*4
            +
            31C> @param[out] IDPDS GRIB product definition section character*1 (28)
            +
            32C> @param[out] IER
            +
            33C> = 0 completed smoothly
            +
            34C> = 1 Indicator parameter N.A. to GRIB
            +
            35C> = 2 Level indicator N.A. to GRIB
            +
            36C> = 3 Time range N.A. to GRIB notation
            +
            37C> = 4 Layers or levels N.A. to GRIB
            +
            38C>
            +
            39C> @author A.J. McClees @date 1991-07-30
            +
            +
            40 SUBROUTINE w3fp12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER)
            +
            41C
            +
            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/
            +
            62C
            +
            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)
            +
            69C
            +
            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)
            +
            76C
            +
            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/
            +
            111C DATA MSK1 /Z'00000FFF'/,
            +
            112C & MSK2 /Z'0FFFFF00'/,
            +
            113C & MSK3 /Z'0000007F'/,
            +
            114C & MSK4 /Z'00000080'/,
            +
            115C & MSK5 /Z'F0000000'/,
            +
            116C & MSK6 /Z'00000200'/,
            +
            117C & MSK7 /Z'000000FF'/
            +
            118C 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/
            +
            126C
            +
            127C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
            +
            128C
            +
            129C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
            +
            130C$ - NO. OF ENTRIES IN TYPE LEVEL
            +
            131C
            +
            132 iq = 163
            +
            133C
            +
            134C$ 1.1 COPY O.N. 84 ID'S INTO WORK SPACE
            +
            135C
            +
            136 DO 100 n = 1,4
            +
            137 idwk(n) = id8(n)
            +
            138 100 CONTINUE
            +
            139C ---------------------------------------------------------------------
            +
            140C 2.0 NO. OF OCTETS IN THE PDS IN THE FIRST 3
            +
            141C$ 2.1 SET CNTR ID, DATA TYPE, GRID DEF AND FLAG
            +
            142C
            +
            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
            +
            159C
            +
            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)
            +
            179C---------------------------------------------------------------------
            +
            180C
            +
            181C$ 3.0 FORM INDICATOR PARAMETER
            +
            182C
            +
            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
            +
            188C
            +
            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
            +
            195C
            +
            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))
            +
            212C
            +
            213C N IS A SPECIAL TEST FOR WAVE HGTS, M AND KS ARE SPECIAL FOR
            +
            214C ACCUMULATED PRECIP
            +
            215C
            +
            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
            +
            223C
            +
            224 IF (m .EQ. 0 .AND. q .EQ. 1) THEN
            +
            225 idpds(9) = char(210)
            +
            226 ENDIF
            +
            227C
            +
            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
            +
            237C
            +
            238C$ 4.0 DETERMINE IF LAYERS OR LEVEL AND FORM TYPE
            +
            239C
            +
            240C ......... M = THE M MARKER FROM O.N.84 CHECK ABOVE
            +
            241C ......... S1 = S1 TYPE OF SURFACE
            +
            242C
            +
            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)
            +
            248C
            +
            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)
            +
            254C
            +
            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)
            +
            260C
            +
            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)
            +
            266C
            +
            267 ELSE IF (s1 .EQ. 7) THEN
            +
            268 idpds(10) = char(111)
            +
            269C 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)
            +
            274C
            +
            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)
            +
            280C
            +
            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
            +
            292C
            +
            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)
            +
            298C
            +
            299C SET LEVEL AND PARAMETER FOR MSL PRESSURE
            +
            300C
            +
            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)
            +
            308C
            +
            309 ELSE IF (s1 .EQ. 129) THEN
            +
            310 idpds(10) = char(1)
            +
            311 idpds(11) = char(0)
            +
            312 idpds(12) = char(0)
            +
            313C
            +
            314 ELSE IF (s1 .EQ. 130) THEN
            +
            315 idpds(10) = char(7)
            +
            316 idpds(11) = char(0)
            +
            317 idpds(12) = char(0)
            +
            318C
            +
            319 ELSE IF (s1 .EQ. 131) THEN
            +
            320 idpds(10) = char(6)
            +
            321 idpds(11) = char(0)
            +
            322 idpds(12) = char(0)
            +
            323C
            +
            324 ELSE IF (s1 .EQ. 133) THEN
            +
            325 idpds(10) = char(1)
            +
            326 idpds(11) = char(0)
            +
            327 idpds(12) = char(0)
            +
            328C
            +
            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)
            +
            340C
            +
            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)
            +
            348C
            +
            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)
            +
            356C
            +
            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
            +
            365C
            +
            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
            +
            375C
            +
            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)
            +
            384C
            +
            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)
            +
            391C
            +
            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)
            +
            398C
            +
            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)
            +
            405C
            +
            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
            +
            422C
            +
            423C$ 6.0 DATE - YR.,MO,DA,& INITIAL HR AND CENTURY
            +
            424C
            +
            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)
            +
            431C---------------------------------------------------------------------
            +
            432C
            +
            433C$ OCTET (17) N.A. FROM O.N. 84 DATA
            +
            434C
            +
            435C$ 7.0 INDICATOR OF TIME UNIT, TIME RANGE 1 AND 2, AND TIME
            +
            436C RANGE FLAG
            +
            437C
            +
            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)
            +
            448C
            +
            449 ELSE IF (t .EQ. 1) THEN
            +
            450 print 710, t, id8
            +
            451 ier = 3
            +
            452 RETURN
            +
            453C
            +
            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
            +
            460C
            +
            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
            +
            464C
            +
            465 idpds(18) = char(1)
            +
            466C CORRECTION FOR 00 HR FCST
            +
            467 itemp = f1 - f2
            +
            468 IF (itemp.LT.0) itemp = 0
            +
            469C 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)
            +
            475C
            +
            476 ELSE
            +
            477 idpds(18) = char(1)
            +
            478C CORRECTION FOR 00 HR FCST
            +
            479 itemp = f1 - f2
            +
            480 IF (itemp.LT.0) itemp = 0
            +
            481C 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
            +
            488C
            +
            489 ELSE IF (t .EQ. 4) THEN
            +
            490C
            +
            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)
            +
            499C
            +
            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)
            +
            508C
            +
            509 ENDIF
            +
            510C
            +
            511 ELSE IF (t .EQ. 5) THEN
            +
            512 idpds(18) = char(1)
            +
            513C CORRECTION FOR 00 HR FCST
            +
            514 itemp = f1 - f2
            +
            515 IF (itemp.LT.0) itemp = 0
            +
            516C 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)
            +
            522C
            +
            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)
            +
            531C****CALCULATE NEW DATE BASED ON THE BEGINNING OF THE DATA IN MEAN
            +
            532C INCR = (F1)
            +
            533C IF (INCR.LT.0) THEN
            +
            534C RINC=0
            +
            535C RINC(2)=INCR
            +
            536C PRINT *, 'INCR=',INCR
            +
            537C CALL W3FS04 (IDWK(4),JDATE,INCR,IERR)
            +
            538C IYR=ICHAR(LIDWK(25))
            +
            539C PRINT *, 'IYR = ', IYR
            +
            540C IF(IYR.LT.20)THEN
            +
            541C MDATE(1)=2000+IYR
            +
            542C ELSE
            +
            543C MDATE(1)=1900+IYR
            +
            544C ENDIF
            +
            545C MDATE(2) = ICHAR(LIDWK(26))
            +
            546C MDATE(3) = ICHAR(LIDWK(27))
            +
            547C MDATE(4) = ICHAR(LIDWK(28))
            +
            548C PRINT *, 'CHANGE DATE BY - ', RINC(2)
            +
            549C CALL W3MOVDAT(RINC,MDATE,NDATE)
            +
            550C PRINT *,'NEW DATE =',NDATE(1),NDATE(2),NDATE(3),NDATE(5)
            +
            551C IYEAR = MOD(NDATE(1),100)
            +
            552C LIDWK(25) = CHAR(IYEAR)
            +
            553C LIDWK(26) = CHAR(NDATE(2))
            +
            554C LIDWK(27) = CHAR(NDATE(3))
            +
            555C LIDWK(28) = CHAR(NDATE(4))
            +
            556C 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)
            +
            570C*****THE NUMBER OF CASES AVERAGED IS ASSUMING ONE TIME A DAY
            +
            571C L = (F2/2) + 1
            +
            572C***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)
            +
            576C
            +
            577 ELSE IF (t .EQ. 7) THEN
            +
            578 print 710, t, id8
            +
            579 ier = 3
            +
            580 RETURN
            +
            581C
            +
            582 ELSE IF (t .EQ. 10) THEN
            +
            583 print 710, t, id8
            +
            584 ier = 3
            +
            585 RETURN
            +
            586C
            +
            587 710 FORMAT (' W3FP12 (710) - NOT APPLICABLE (YET) TO GRIB. ',
            +
            588 & ', T = ',i2,/,
            +
            589 & ' O.N. 84 IDS ARE ',/,
            +
            590 & 1x,4(z16,' '))
            +
            591C
            +
            592 ENDIF
            +
            593 ier = 0
            +
            594 RETURN
            +
            +
            595 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
            +
            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
            diff --git a/w3fp13_8f.html b/w3fp13_8f.html index 9b28e43d..e7064b6e 100644 --- a/w3fp13_8f.html +++ b/w3fp13_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp13.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@

            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fp13.f File Reference
            +
            w3fp13.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fp13 (grib, pds, id8, ierr)
             Converts GRIB version 1 formatted product definition section to an office note 84 id label.
             

            Detailed Description

            Convert GRIB PDS edition 1 to O.N.

            @@ -107,8 +113,8 @@

            Definition in file w3fp13.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fp13()

            + +

            ◆ w3fp13()

            @@ -117,25 +123,25 @@

            subroutine w3fp13 ( character * 8  - GRIB, + grib, character * 1, dimension ( *)  - PDS, + pds, integer, dimension (12)  - ID8, + id8,   - IERR  + ierr  @@ -147,7 +153,7 @@

            +

            Program History Log:

            @@ -194,7 +200,7 @@

            diff --git a/w3fp13_8f.js b/w3fp13_8f.js index 11279f7c..a53b0a56 100644 --- a/w3fp13_8f.js +++ b/w3fp13_8f.js @@ -1,4 +1,4 @@ var w3fp13_8f = [ - [ "w3fp13", "w3fp13_8f.html#a4bb36ff2a73a0614b75ec00e2b804740", null ] + [ "w3fp13", "w3fp13_8f.html#a56fb62646dcbbcea7bc5239ed6f5acd0", null ] ]; \ No newline at end of file diff --git a/w3fp13_8f_source.html b/w3fp13_8f_source.html index a07a0ad8..1cff85d5 100644 --- a/w3fp13_8f_source.html +++ b/w3fp13_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fp13.f Source File @@ -23,10 +23,9 @@

            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,938 +81,946 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fp13.f
            +
            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
            -
            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
            -
            w3fi01
            subroutine w3fi01(LW)
            Determines the number of bytes in a full word for the particular machine (IBM or cray).
            Definition: w3fi01.f:19
            -
            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
            -
            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
            -
            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
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief Convert GRIB PDS edition 1 to O.N. 84 ID.
            +
            3C> @author A.J. McClees @date 1991-10-07
            +
            4
            +
            5C> Converts GRIB version 1 formatted product definition
            +
            6C> section to an office note 84 id label. Formats all that is appli-
            +
            7C> cable in the first 8 words of O.N. 84. (caution ****see remarks)
            +
            8C>
            +
            9C> ### Program History Log:
            +
            10C> Date | Programmer | Comments
            +
            11C> -----|------------|---------
            +
            12C> 1991-10-07 | A.J. McClees | Initial
            +
            13C> 1992-01-06 | Ralph Jones | Convert to silicongraphics 3.3 fortran 77
            +
            14C> 1993-03-29 | Ralph Jones | Add save statement
            +
            15C> 1994-04-17 | Ralph Jones | Complete rewrite to use sbyte, make code portable, upgrade to on388
            +
            16C> 1994-05-05 | Ralph Jones | Correction in two tables
            +
            17C> 1996-08-02 | Ralph Jones | Error using T marker
            +
            18C> 1996-09-03 | Ralph Jones | Add mercator grids 8 and 53 to tables
            +
            19C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
            +
            20C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i()
            +
            21C>
            +
            22C> @param[in] GRIB GRIB section 0 read as character*8
            +
            23C> @param[in] PDS GRIB PDS section 1 read as character*1 PDS(*)
            +
            24C> @param[out] ID8 12 Integer*4 formatted O.N. 84 ID. 6 integer 64 bit words on cray
            +
            25C> @param[out] IERR
            +
            26C> 0 - Completed satisfactorily
            +
            27C> 1 - Grib block 0 not correct
            +
            28C> 2 - Length of pds not correct
            +
            29C> 3 - Could not match type indicator
            +
            30C> 4 - Grid type not in tables
            +
            31C> 5 - Could not match type level
            +
            32C> 6 - Could not interpret originator of code
            +
            33C>
            +
            34C> @note Some of the id's will not be exact to the o.n. 84
            +
            35C> for locating field on the dataset. These differences
            +
            36C> are mainly due to truncation errors with layers.
            +
            37C> For example: .18019 sig .47191 sig r h for 36.o hrs
            +
            38C> will convert to: .18000 sig .47000 sig r h for 36.0 hrs
            +
            39C> !!!!!!!the above id's now forced to be exact!!!!!!!!!
            +
            40C> If j the word count is greater then 32743, j is stored
            +
            41C> in the 12th id word. Bits 16-31 of the 8th id word are
            +
            42C> set to zero.
            +
            43C>
            +
            44C> @author A.J. McClees @date 1991-10-07
            +
            +
            45 SUBROUTINE w3fp13 (GRIB, PDS, ID8, IERR )
            +
            46C
            +
            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)
            +
            57C
            +
            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
            +
            75C INTEGER S2
            +
            76 INTEGER T
            +
            77 INTEGER TR
            +
            78C
            +
            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 ( *)
            +
            86C
            +
            87 SAVE
            +
            88C
            +
            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))
            +
            95C
            +
            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/
            +
            123C
            +
            124 DATA igen / 7, 58, 66, 98/
            +
            125C
            +
            126C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER.
            +
            127C ICXG2 1.0000, .98230, .96470,
            +
            128C .85000, .84368, .47191,
            +
            129C .18017, .81573, .25011
            +
            130C #################
            +
            131C
            +
            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'/
            +
            135C
            +
            136C ########### NUMBERS CALCULATED BY GRIB LAYER.
            +
            137C ICXGB2 1.00000, .98000, .96000,
            +
            138C .85000, .84000, .47000,
            +
            139C .18000, .82000, .25000
            +
            140C #################
            +
            141C
            +
            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'/
            +
            145C
            +
            146C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE.
            +
            147C ICXG1 .98230, .89671, .78483
            +
            148C .94316, .84367, .999.00, .25011
            +
            149C #################
            +
            150C
            +
            151 DATA icxg1 /z'00017FB6', z'00015E47', z'00013293',
            +
            152 a z'0001706C', z'0001498F', z'0000863C', z'000061B3'/
            +
            153C
            +
            154C ########### NUMBERS CALCULATED BY GRIB LAYER.
            +
            155C ICXGB1 .98230, .89670, .78480
            +
            156C .94320, .84370, 998.00, .25000
            +
            157C #################
            +
            158C
            +
            159 DATA icxgb1/z'00017FB6', z'00015E46', z'00013290',
            +
            160 a z'00017070', z'00014992', z'000185D8', z'000061A8'/
            +
            161C
            +
            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/
            +
            189C
            +
            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/
            +
            197C
            +
            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/
            +
            205C
            +
            206C DATA MSK1 /Z0000FFFF/,
            +
            207C & MSK2 /Z00000080/,
            +
            208C & MSK3 /Z00000000/,
            +
            209C & MSK4 /Z00000200/
            +
            210C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE
            +
            211C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
            +
            212 DATA msk1 /65535/,
            +
            213 & msk2 /128/,
            +
            214 & msk3 /0/,
            +
            215 & msk4 /512/
            +
            216C
            +
            217C MAKE SECTION 0, PUT 'GRIB' IN ASCII
            +
            218C
            +
            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)
            +
            227C
            +
            228C CONVERT PDS INTO 25 INTEGER NUMBERS
            +
            229C
            +
            230 CALL w3fi69(pds,id)
            +
            231C
            +
            232C ID(1) = NUMBER OF BYTES IN PDS
            +
            233C ID(2) = PARAMETER TABLE VERSION NUMBER
            +
            234C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
            +
            235C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
            +
            236C ID(5) = GRID IDENTIFICATION
            +
            237C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
            +
            238C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
            +
            239C ID(8) = INDICATOR OF PARAMETER AND UNITS
            +
            240C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER
            +
            241C ID(10) = LEVEL 1
            +
            242C ID(11) = LEVEL 2
            +
            243C ID(12) = YEAR OF CENTURY
            +
            244C ID(13) = MONTH OF YEAR
            +
            245C ID(14) = DAY OF MONTH
            +
            246C ID(15) = HOUR OF DAY
            +
            247C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
            +
            248C ID(17) = FCST TIME UNIT
            +
            249C ID(18) = P1 PERIOD OF TIME
            +
            250C ID(19) = P2 PERIOD OF TIME
            +
            251C ID(20) = TIME RANGE INDICATOR
            +
            252C ID(21) = NUMBER INCLUDED IN AVERAGE
            +
            253C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS
            +
            254C ID(23) = CENTURY
            +
            255C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2)
            +
            256C ID(25) = SCALING POWER OF 10
            +
            257C
            +
            258C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE
            +
            259C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS
            +
            260C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS
            +
            261C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT.
            +
            262C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND
            +
            263C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR
            +
            264C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN
            +
            265C OFFICE NOTE 84.
            +
            266C
            +
            267C NO. NAME STARTING BIT NO. OF BITS
            +
            268C -----------------------------------------
            +
            269C 1 Q 0 12
            +
            270C 2 S1 12 12
            +
            271C 3 F1 24 8
            +
            272C 4 T 32 4
            +
            273C 5 C1 36 20
            +
            274C 6 E1 56 8
            +
            275C 7 M 64 4
            +
            276C 8 X 68 8
            +
            277C 9 S2 76 12
            +
            278C 10 F2 88 8
            +
            279C 11 N 96 4
            +
            280C 12 C2 100 20
            +
            281C 13 E2 120 8
            +
            282C 14 CD 128 8
            +
            283C 15 CM 136 8
            +
            284C 16 KS 144 8
            +
            285C 17 K 152 8
            +
            286C 18 GES 160 4
            +
            287C 19 164 12
            +
            288C 20 NW 176 16
            +
            289C 21 YY 192 8
            +
            290C 22 MM 200 8
            +
            291C 23 DD 208 8
            +
            292C 24 II 216 8
            +
            293C 25 R 224 8
            +
            294C 26 G 232 8
            +
            295C 27 J 240 16
            +
            296C OR 27 J 352 32 J > 32743
            +
            297C----------------------------------------------
            +
            298C
            +
            299C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
            +
            300C$ - NO. OF ENTRIES IN TYPE LEVEL
            +
            301C$ - NO. OF ENTRIES IN CNTR PROD. DTA.
            +
            302C$ - INITIAL ZEROS IN O.N. 84 LABEL
            +
            303C
            +
            304 iq = 255
            +
            305 ic = 4
            +
            306 in = 34
            +
            307C
            +
            308C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
            +
            309C
            +
            310 CALL w3fi01(lw)
            +
            311 IF (lw.EQ.4) THEN
            +
            312 nwords = 12
            +
            313 ELSE
            +
            314 nwords = 6
            +
            315 END IF
            +
            316C
            +
            317C ZERO OUTPUT ARRAY
            +
            318C
            +
            319 DO n = 1,nwords
            +
            320 id8(n) = 0
            +
            321 END DO
            +
            322C
            +
            323C ---------------------------------------------------------------------
            +
            324C$ 2.0 VERIFY GRIB IN SECTION 0
            +
            325C
            +
            326 IF (.NOT. grib(1:4) .EQ. igrib(1:4)) THEN
            +
            327 ierr = 1
            +
            328 RETURN
            +
            329 END IF
            +
            330C
            +
            331C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS
            +
            332C
            +
            333 IF (id(1).NE.28) THEN
            +
            334 ierr = 2
            +
            335 print *,'IERR = ',ierr,',LENGTH OF PDS = ',id(1)
            +
            336 RETURN
            +
            337 END IF
            +
            338C
            +
            339C$ 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS.
            +
            340C
            +
            341C IF CENTER NOT U.S., STORE CENTER IN G MARKER
            +
            342C IF CENTER U.S. STORE MODEL NO. IN G MARKER
            +
            343C
            +
            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
            +
            349C
            +
            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
            +
            366C
            +
            367 350 CONTINUE
            +
            368C
            +
            369C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER
            +
            370C
            +
            371C (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)
            +
            376C (NMC) run
            +
            377 ELSE IF (id(4).EQ.25) THEN
            +
            378 CALL sbyte(id8,1,224,8)
            +
            379C (RGL) run
            +
            380 ELSE IF (id(4).EQ.39.OR.id(4).EQ.64) THEN
            +
            381 CALL sbyte(id8,2,224,8)
            +
            382C (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)
            +
            389C (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)
            +
            394C (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)
            +
            398C (HCN) run
            +
            399 ELSE IF ( id(4).EQ.70) THEN
            +
            400 CALL sbyte(id8,6,224,8)
            +
            401C (RUC) run
            +
            402 ELSE IF ( id(4).EQ.86) THEN
            +
            403 CALL sbyte(id8,7,224,8)
            +
            404C Not applicable, set to 255
            +
            405 ELSE
            +
            406 CALL sbyte(id8,255,224,8)
            +
            407 END IF
            +
            408 END IF
            +
            409C
            +
            410C$ 4.0 FORM TYPE DATA PARAMETER
            +
            411C
            +
            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
            +
            425C
            +
            426 410 CONTINUE
            +
            427C
            +
            428C Q DATA TYPE, BITS 1-12
            +
            429C
            +
            430 CALL sbyte(id8,ll(iii),0,12)
            +
            431C
            +
            432C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
            +
            433C
            +
            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
            +
            441C
            +
            442C$ 5.0 FORM TYPE LEVEL
            +
            443C
            +
            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)
            +
            463C
            +
            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)
            +
            483C
            +
            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)
            +
            503C
            +
            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)
            +
            521C 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)
            +
            528C
            +
            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)
            +
            553C***********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)
            +
            560C
            +
            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)
            +
            566C LEVEL = ID(11)
            +
            567C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED
            +
            568C LEVEL = IAND (IPDS(3),MSK1)
            +
            569C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN
            +
            570C E1 = 4
            +
            571C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN
            +
            572C E1 = 3
            +
            573C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN
            +
            574C E1 = 2
            +
            575C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN
            +
            576C E1 = 1
            +
            577C 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)
            +
            583C*************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)
            +
            589C
            +
            590 ELSE IF (id(9) .EQ. 1) THEN
            +
            591 m = 0
            +
            592 s1 = 129
            +
            593C***** S1 = 133 ALSO POSSIBILITY
            +
            594 CALL sbyte(id8,s1,12,12)
            +
            595 CALL sbyte(id8,0,64,32)
            +
            596C
            +
            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)
            +
            602C
            +
            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)
            +
            608C
            +
            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)
            +
            646C
            +
            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)
            +
            683C
            +
            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)
            +
            720C
            +
            721 ELSE IF (id(9) .EQ. 108) THEN
            +
            722 m = 2
            +
            723 s1 = 148
            +
            724C**** S1 = 144 ALSO POSSIBILITY
            +
            725C**** 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
            +
            752C*****TAKE SCALING INTO ACCOUNT .01
            +
            753 e1 = e1 + 2
            +
            754 e1 = ior(e1,msk2)
            +
            755 CALL sbyte(id8,e1,56,8)
            +
            756C
            +
            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)
            +
            778C*******TAKE SCALING INTO ACCOUNT .01
            +
            779 e2 = e2 + 2
            +
            780 e2 = ior(e2,msk2)
            +
            781 CALL sbyte(id8,e2,120,8)
            +
            782C
            +
            783 END IF
            +
            784C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD
            +
            785C
            +
            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)
            +
            804C
            +
            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
            +
            818C
            +
            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))
            +
            839C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
            +
            840C PRINT *, 'CHANGE DATE BY - ', RINC(2)
            +
            841 CALL w3movdat(rinc,mdate,ndate)
            +
            842C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
            +
            843C 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
            +
            851C
            +
            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)
            +
            857C
            +
            858C ***** NAVG IS IN BITES 22 23 *****
            +
            859C USING BITE 23 ONLY *******
            +
            860C FIX LATER ******************************************
            +
            861C
            +
            862C 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))
            +
            879C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
            +
            880C PRINT *, 'CHANGE DATE BY - ', RINC(2)
            +
            881 CALL w3movdat(rinc,mdate,ndate)
            +
            882C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
            +
            883C 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
            +
            892C
            +
            893C$ 7.0 TRANSFER THE DATE
            +
            894C
            +
            895 iwork(1) = pds(13)
            +
            896 iwork(2) = pds(14)
            +
            897 iwork(3) = pds(15)
            +
            898 iwork(4) = pds(16)
            +
            899C
            +
            900 710 CONTINUE
            +
            901C
            +
            902C TEST FOR 64 BIT COMPUTER (CRAY)
            +
            903C
            +
            904 IF (lw.EQ.8) idate = ishft(idate,-32)
            +
            905 CALL sbyte(id8,idate,192,32)
            +
            906C
            +
            907 ierr = 0
            +
            908 RETURN
            +
            +
            909 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
            +
            sbyte
            subroutine sbyte(iout, in, iskip, nbyte)
            Definition sbyte.f:12
            +
            w3fi01
            subroutine w3fi01(lw)
            Determines the number of bytes in a full word for the particular machine (IBM or cray).
            Definition w3fi01.f:19
            +
            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
            +
            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
            +
            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/w3fq07_8f.html b/w3fq07_8f.html deleted file mode 100644 index 11fb9879..00000000 --- a/w3fq07_8f.html +++ /dev/null @@ -1,235 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: w3fq07.f File Reference - - - - - - - - - - - - - -
            -
            - - - - - - -
            -
            NCEPLIBS-w3emc -  2.11.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 80 of file w3fq07.f.

            - -
            -
            -
            -
            - - - - diff --git a/w3fq07_8f.js b/w3fq07_8f.js deleted file mode 100644 index 77546f30..00000000 --- a/w3fq07_8f.js +++ /dev/null @@ -1,4 +0,0 @@ -var w3fq07_8f = -[ - [ "w3fq07", "w3fq07_8f.html#a621d5a7f77939450e814033c6f3b1535", null ] -]; \ No newline at end of file diff --git a/w3fq07_8f_source.html b/w3fq07_8f_source.html deleted file mode 100644 index 76c3d982..00000000 --- a/w3fq07_8f_source.html +++ /dev/null @@ -1,559 +0,0 @@ - - - - - - - -NCEPLIBS-w3emc: w3fq07.f Source File - - - - - - - - - - - - - -
            -
            - - - - - - -
            -
            NCEPLIBS-w3emc -  2.11.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/w3fs13_8f.html b/w3fs13_8f.html index 5ed6ab61..3eb48174 100644 --- a/w3fs13_8f.html +++ b/w3fs13_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs13.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@
            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fs13.f File Reference
            +
            w3fs13.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fs13 (iyr, imo, ida, jdy)
             0converts year, month and day to day of year.
             

            Detailed Description

            Year, month, and day to day of year.

            @@ -107,8 +113,8 @@

            Definition in file w3fs13.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fs13()

            + +

            ◆ w3fs13()

            @@ -117,25 +123,25 @@

            subroutine w3fs13 (   - IYR, + iyr,   - IMO, + imo,   - IDA, + ida,   - JDY  + jdy  @@ -146,7 +152,7 @@

            0converts year, month and day to day of year.

            -

            +

            Program History Log:

            @@ -177,7 +183,7 @@

            diff --git a/w3fs13_8f.js b/w3fs13_8f.js index ebd520e1..67e90e53 100644 --- a/w3fs13_8f.js +++ b/w3fs13_8f.js @@ -1,4 +1,4 @@ var w3fs13_8f = [ - [ "w3fs13", "w3fs13_8f.html#a7ae96960810e2a780cc1dfaa4740e4ec", null ] + [ "w3fs13", "w3fs13_8f.html#afce9c885afc9ee59a125a8db9ac5eee4", null ] ]; \ No newline at end of file diff --git a/w3fs13_8f_source.html b/w3fs13_8f_source.html index 946af537..75bda413 100644 --- a/w3fs13_8f_source.html +++ b/w3fs13_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs13.f Source File @@ -23,10 +23,9 @@

            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,56 +81,64 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fs13.f
            +
            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
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief Year, month, and day to day of year.
            +
            3C> @author Ralph Jones @date 1985-08-31
            +
            4
            +
            5C> 0converts year, month and day to day of year.
            +
            6C>
            +
            7C> ### Program History Log:
            +
            8C> Date | Programmer | Comments
            +
            9C> -----|------------|---------
            +
            10C> 1985-07-31 | Ralph Jones | Initial.
            +
            11C> 1989-11-02 | Ralph Jones | Convert to cray cft77 fortran.
            +
            12C>
            +
            13C> @param[in] IYR Year of century, 00-99 or year of era, 1901-2099
            +
            14C> @param[in] IMO Month of year, 1-12
            +
            15C> @param[in] IDA Day of month, 1-31
            +
            16C> @param[out] JDY Day of year, 1-366
            +
            17C>
            +
            18C> @note This procedure is valid only from the years 1901-2099 inclusive.
            +
            19C>
            +
            +
            20 SUBROUTINE w3fs13(IYR,IMO,IDA,JDY)
            +
            21C
            +
            22 INTEGER JTABLE(24)
            +
            23C
            +
            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/
            +
            26C
            +
            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/w3fs15_8f.html b/w3fs15_8f.html index b7faee6a..61dd58f1 100644 --- a/w3fs15_8f.html +++ b/w3fs15_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs15.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@

            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fs15.f File Reference
            +
            w3fs15.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fs15 (idate, jtau, ndate)
             Updates or backdates a fullword date/time word (o.n.
             

            Detailed Description

            Updating office note 85 date/time word.

            @@ -107,8 +113,8 @@

            Definition in file w3fs15.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fs15()

            + +

            ◆ w3fs15()

            @@ -117,19 +123,19 @@

            subroutine w3fs15 ( character*1, dimension(4)  - IDATE, + idate,   - JTAU, + jtau, character*1, dimension(4)  - NDATE  + ndate  @@ -141,7 +147,7 @@

            +

            Program History Log:

            @@ -200,7 +206,7 @@

            diff --git a/w3fs15_8f.js b/w3fs15_8f.js index 90f21db1..9998e9da 100644 --- a/w3fs15_8f.js +++ b/w3fs15_8f.js @@ -1,4 +1,4 @@ var w3fs15_8f = [ - [ "w3fs15", "w3fs15_8f.html#ada3b10209aac56c01b05d096d84e6471", null ] + [ "w3fs15", "w3fs15_8f.html#a6503e7b854ccc60e9a09e85413642c5c", null ] ]; \ No newline at end of file diff --git a/w3fs15_8f_source.html b/w3fs15_8f_source.html index 424625c0..9caddd4f 100644 --- a/w3fs15_8f_source.html +++ b/w3fs15_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs15.f Source File @@ -23,10 +23,9 @@

            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,218 +81,226 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fs15.f
            +
            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
            -
            mova2i
            integer function mova2i(a)
            This Function copies a bit string from a Character*1 variable to an integer variable.
            Definition: mova2i.f:25
            -
            w3fs15
            subroutine w3fs15(IDATE, JTAU, NDATE)
            Updates or backdates a fullword date/time word (o.n.
            Definition: w3fs15.f:47
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief Updating office note 85 date/time word.
            +
            3C> @author Ralph Jones @date 1987-02-09
            +
            4
            +
            5C> Updates or backdates a fullword date/time word (o.n. 84) by a specified
            +
            6C> number of hours.
            +
            7C>
            +
            8C> ### Program History Log:
            +
            9C> Date | Programmer | Comments
            +
            10C> -----|------------|---------
            +
            11C> Unknown | Robert Allard | Initial.
            +
            12C> 1987-02-19 | Ralph Jones | Clean up code
            +
            13C> 1987-02-19 | Ralph Jones | Change to microsoft fortran 4.10
            +
            14C> 1989-05-12 | Ralph Jones | Correct order of bytes in date word for pc
            +
            15C> 1989-08-04 | Ralph Jones | Clean up code, get rid of assign, correction for memory set to indefinite.
            +
            16C> 1989-10-25 | Ralph Jones | Change to cray cft77 fortran
            +
            17C> 1995-11-15 | Ralph Jones | Add save statement
            +
            18C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i
            +
            19C>
            +
            20C> @param[in] IDATE Packed binary date/time as follows:
            +
            21C> Byte | Variable | Range
            +
            22C> -----|----------|------
            +
            23C> Byte 1 | is year of century | 00-99
            +
            24C> Byte 2 | is month | 01-12
            +
            25C> Byte 3 | is day of month | 01-31
            +
            26C> Byte 4 | is hour | 00-23
            +
            27C> Subroutine takes advantage of fortran address passing, IDATE and NDATE may
            +
            28C> be a character*1 array of four, the left 32 bits of 64 bit integer word.
            +
            29C> An office note 85 label can be stored in 4 integer words. If integer the
            +
            30C> 2nd word is used. Output is stored in left 32 bits. for a office note 84
            +
            31C> label the 7th word is in the 4th cray 64 bit integer, the left 32 bits.
            +
            32C> @param[in] JTAU Number of hours to update (if positive) or backdate (if negative)
            +
            33C> @param[out] NDATE New date/time word returned in the same format as 'IDATE'.
            +
            34C> 'NDATE' and 'IDATE' may be the same variable.
            +
            35C>
            +
            36C> @note This routine is valid only for the 20th century.
            +
            37C>
            +
            38C> @note The format of the date/time word is the same as the seventh word of
            +
            39C> the packed data field label (see o.n. 84) and the third word of a binary
            +
            40C> data set label (see o.n. 85).
            +
            41C>
            +
            42C> Exit states: An error found by out of range tests on the given date/time
            +
            43C> information will be indicated by returning a binary zero word in 'NDATE'.
            +
            44C>
            +
            45C> @author Ralph Jones @date 1987-02-09
            +
            +
            46 SUBROUTINE w3fs15(IDATE,JTAU,NDATE)
            +
            47C
            +
            48 INTEGER ITABYR(13)
            +
            49 INTEGER LPTB(13)
            +
            50 INTEGER NOLPTB(13)
            +
            51C
            +
            52 CHARACTER*1 IDATE(4)
            +
            53 CHARACTER*1 NDATE(4)
            +
            54C
            +
            55 SAVE
            +
            56C
            +
            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/
            +
            62C
            +
            63C ...WHERE ICENTY IS FOR THE 20TH CENTURY ASSUMED FOR THE GIVEN
            +
            64C ... YEAR WITHIN THE CENTURY
            +
            65C
            +
            66 iyr = mova2i(idate(1))
            +
            67 imonth = mova2i(idate(2))
            +
            68 iday = mova2i(idate(3))
            +
            69 ihour = mova2i(idate(4))
            +
            70C
            +
            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
            +
            79C
            +
            80 ndate(1) = idate(1)
            +
            81 ndate(2) = idate(2)
            +
            82 ndate(3) = idate(3)
            +
            83 ndate(4) = idate(4)
            +
            84 RETURN
            +
            85C
            +
            86 100 CONTINUE
            +
            87 jahr = iyr + icenty
            +
            88 kabul = 1
            +
            89 GO TO 900
            +
            90C
            +
            91C ...WHERE 900 IS SUBROUTINE TO INITIALIZE ITABYR
            +
            92C ...AND RETURN THRU KABUL
            +
            93C
            +
            94 200 CONTINUE
            +
            95 ihryr = ihour + 24 * (iday - 1) + itabyr(imonth)
            +
            96 ihryr2 = ihryr + jtau
            +
            97C
            +
            98C ...TO TEST FOR BACKDATED INTO PREVIOUS YEAR...
            +
            99C
            +
            100 300 CONTINUE
            +
            101 IF (ihryr2 .LT. 0) GO TO 700
            +
            102C
            +
            103 DO 400 m = 2,13
            +
            104 IF (ihryr2 .LT. itabyr(m)) GO TO 600
            +
            105 400 CONTINUE
            +
            106C
            +
            107C ...IF IT FALLS THRU LOOP TO HERE, IT IS INTO NEXT YEAR...
            +
            108C
            +
            109 jahr = jahr + 1
            +
            110 ihryr2 = ihryr2 - itabyr(13)
            +
            111 kabul = 2
            +
            112 GO TO 900
            +
            113C
            +
            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
            +
            121C
            +
            122C ...ALL FINISHED. RETURN TO CALLING PROGRAM.......................
            +
            123C ...COMES TO 700 IF NEG TOTAL HRS. BACK UP INTO PREVIOUS YEAR
            +
            124C
            +
            125 700 CONTINUE
            +
            126 jahr = jahr - 1
            +
            127 kabul = 3
            +
            128 GO TO 900
            +
            129C
            +
            130C ...WHICH IS CALL TO INITIALIZE ITABYR AND RETURN THRU KABUL
            +
            131C
            +
            132 800 CONTINUE
            +
            133 ihryr2 = itabyr(13) + ihryr2
            +
            134 GO TO 300
            +
            135C
            +
            136C ...SUBROUTINE INITYR...
            +
            137C ...CALLED BY GO TO 900 AFTER ASSIGNING RETURN NO. TO KABUL...
            +
            138C ...ITABYR HAS MONTHLY ACCUMULATING TOTAL HRS REL TO BEGIN OF YR.
            +
            139C ...DEPENDS ON WHETHER JAHR IS LEAP YEAR OR NOT.
            +
            140C
            +
            141 900 CONTINUE
            +
            142 iquot = jahr / 4
            +
            143 irmndr = jahr - 4 * iquot
            +
            144 IF (irmndr .NE. 0) GO TO 1000
            +
            145C
            +
            146C ...WAS MODULO 4, SO MOST LIKELY A LEAP YEAR,
            +
            147C
            +
            148 iquot = jahr / 100
            +
            149 irmndr = jahr - 100 * iquot
            +
            150 IF (irmndr .NE. 0) GO TO 1200
            +
            151C
            +
            152C ...COMES THIS WAY IF A CENTURY YEAR...
            +
            153C
            +
            154 iquot = jahr / 400
            +
            155 irmndr = jahr - 400 * iquot
            +
            156 IF (irmndr .EQ. 0) GO TO 1200
            +
            157C
            +
            158C ...COMES TO 1000 IF NOT A LEAP YEAR...
            +
            159C
            +
            160 1000 CONTINUE
            +
            161 DO 1100 i = 1,13
            +
            162 itabyr(i) = nolptb(i)
            +
            163 1100 CONTINUE
            +
            164 GO TO 1400
            +
            165C
            +
            166C ...COMES TO 1200 IF LEAP YEAR
            +
            167C
            +
            168 1200 CONTINUE
            +
            169 DO 1300 i = 1,13
            +
            170 itabyr(i) = lptb(i)
            +
            171 1300 CONTINUE
            +
            172C
            +
            173 1400 CONTINUE
            +
            174 GO TO (200,300,800) kabul
            +
            175C
            +
            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
            +
            183C
            +
            184 1600 CONTINUE
            +
            185 ndate(1) = char(0)
            +
            186 ndate(2) = char(0)
            +
            187 ndate(3) = char(0)
            +
            188 ndate(4) = char(0)
            +
            189C
            +
            190C ...WHICH FLAGS AN ERROR CONDITION ...
            +
            191C
            +
            192 RETURN
            +
            +
            193 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
            +
            w3fs15
            subroutine w3fs15(idate, jtau, ndate)
            Updates or backdates a fullword date/time word (o.n.
            Definition w3fs15.f:47
            diff --git a/w3fs21_8f.html b/w3fs21_8f.html index cfe4e2a7..97996941 100644 --- a/w3fs21_8f.html +++ b/w3fs21_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs21.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@
            @@ -76,16 +76,22 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            Functions/Subroutines
            -
            -
            w3fs21.f File Reference
            +
            w3fs21.f File Reference
            @@ -94,11 +100,11 @@

            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...
             
            subroutine w3fs21 (idate, nmin)
             Calculates the number of minutes since 0000, 1 January 1978.
             

            Detailed Description

            Number of minutes since jan 1, 1978.

            @@ -107,8 +113,8 @@

            Definition in file w3fs21.f.

            Function/Subroutine Documentation

            - -

            ◆ w3fs21()

            + +

            ◆ w3fs21()

            @@ -117,13 +123,13 @@

            subroutine w3fs21 ( integer, dimension(5)  - IDATE, + idate, integer  - NMIN  + nmin  @@ -134,7 +140,7 @@

            Calculates the number of minutes since 0000, 1 January 1978.

            -

            +

            Program History Log:

            @@ -166,7 +172,7 @@

            diff --git a/w3fs21_8f.js b/w3fs21_8f.js index 32661925..5c6e9e3b 100644 --- a/w3fs21_8f.js +++ b/w3fs21_8f.js @@ -1,4 +1,4 @@ var w3fs21_8f = [ - [ "w3fs21", "w3fs21_8f.html#a337c53a535dd6a8066f313eb9889201c", null ] + [ "w3fs21", "w3fs21_8f.html#a9af93d7745b3435c83155476954bbdb8", null ] ]; \ No newline at end of file diff --git a/w3fs21_8f_source.html b/w3fs21_8f_source.html index f96e8c6f..594ba76d 100644 --- a/w3fs21_8f_source.html +++ b/w3fs21_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs21.f Source File @@ -23,10 +23,9 @@

            - - + @@ -34,22 +33,28 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0

            - + +/* @license-end */ + +
            @@ -76,86 +81,94 @@
            - +
            +
            +
            +
            +
            Loading...
            +
            Searching...
            +
            No Matches
            +
            +
            +
            -
            -
            w3fs21.f
            +
            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
            -
            iw3jdn
            function iw3jdn(IYEAR, MONTH, IDAY)
            Computes julian day number from year (4 digits), month, and day.
            Definition: iw3jdn.f:42
            -
            w3fs21
            subroutine w3fs21(IDATE, NMIN)
            Calculates the number of minutes since 0000, 1 January 1978.
            Definition: w3fs21.f:22
            +Go to the documentation of this file.
            1C> @file
            +
            2C> @brief Number of minutes since jan 1, 1978
            +
            3C> @author A. Desmarais @date 1984-06-21
            +
            4
            +
            5C> Calculates the number of minutes since 0000, 1 January 1978.
            +
            6C>
            +
            7C> ### Program History Log:
            +
            8C> Date | Programmer | Comments
            +
            9C> -----|------------|---------
            +
            10C> 1984-06-21 | A. Desmarais | Initial.
            +
            11C> 1989-07-14 | Ralph Jones | Convert to cyber 205 fortran 200, change logic so it will work in 21 century.
            +
            12C> 1989-11-02 | Ralph Jones | Convert to cray cft77 fortran.
            +
            13C>
            +
            14C> @param[in] IDATE (INTEGER Size 5) Array containing year of century, month,
            +
            15C> day, hour and minute. IDATE(1) may be a two digit year or 4. If 2 digits
            +
            16c> and GE than 78 1900 is added to it. If LT 78 then 2000 is added to it. If 4
            +
            17C> digits the subroutine will work correctly to the year 3300 A.D.
            +
            18C> @param[out] NMIN (INTEGER) Number of minutes since 1 January 1978.
            +
            19C>
            +
            20C> @author A. Desmarais @date 1984-06-21
            +
            +
            21 SUBROUTINE w3fs21(IDATE, NMIN)
            +
            22C
            +
            23 INTEGER IDATE(5)
            +
            24 INTEGER NMIN
            +
            25 INTEGER JDN78
            +
            26C
            +
            27 DATA jdn78 / 2443510 /
            +
            28C
            +
            29C*** IDATE(1) YEAR OF CENTURY
            +
            30C*** IDATE(2) MONTH OF YEAR
            +
            31C*** IDATE(3) DAY OF MONTH
            +
            32C*** IDATE(4) HOUR OF DAY
            +
            33C*** IDATE(5) MINUTE OF HOUR
            +
            34C
            +
            35 nmin = 0
            +
            36C
            +
            37 iyear = idate(1)
            +
            38C
            +
            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
            +
            46C
            +
            47C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY
            +
            48C
            +
            49 ijdn = iw3jdn(iyear,idate(2),idate(3))
            +
            50C
            +
            51C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE
            +
            52C NUMBER OF DAYS BETWEEN DATES
            +
            53C
            +
            54 ndays = ijdn - jdn78
            +
            55C
            +
            56C*** NUMBER OF MINUTES
            +
            57C
            +
            58 nmin = ndays * 1440 + idate(4) * 60 + idate(5)
            +
            59C
            +
            60 RETURN
            +
            +
            61 END
            +
            iw3jdn
            function iw3jdn(iyear, month, iday)
            Computes julian day number from year (4 digits), month, and day.
            Definition iw3jdn.f:42
            +
            w3fs21
            subroutine w3fs21(idate, nmin)
            Calculates the number of minutes since 0000, 1 January 1978.
            Definition w3fs21.f:22
            diff --git a/w3fs26_8f.html b/w3fs26_8f.html index 51fb315e..cceda4a3 100644 --- a/w3fs26_8f.html +++ b/w3fs26_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs26.f File Reference @@ -23,10 +23,9 @@
            - - + @@ -34,21 +33,22 @@
            -
            NCEPLIBS-w3emc -  2.11.0 +
            +
            NCEPLIBS-w3emc 2.11.0
            - + +/* @license-end */ +
            @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3fs26.f File Reference
          +
          w3fs26.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3fs26 (jldayn, iyear, month, iday, idaywk, idayyr)
           Computes year (4 digits), month, day, day of week, day of year from julian day number.
           

          Detailed Description

          Year, month, day from julian day number.

          @@ -107,8 +113,8 @@

          Definition in file w3fs26.f.

          Function/Subroutine Documentation

          - -

          ◆ w3fs26()

          + +

          ◆ w3fs26()

          @@ -117,37 +123,37 @@

          subroutine w3fs26 (   - JLDAYN, + jldayn,   - IYEAR, + iyear,   - MONTH, + month,   - IDAY, + iday,   - IDAYWK, + idaywk,   - IDAYYR  + idayyr  @@ -159,7 +165,7 @@

          +

          Program History Log:

          Date | Programmer | Comments --—|---------—|------— 1987-03-29 | Ralph Jones | 1989-10-25 | Ralph Jones | Convert to cray cft77 fortran

          Parameters
          @@ -199,7 +205,7 @@

          diff --git a/w3fs26_8f.js b/w3fs26_8f.js index da29fd5f..4b60aaed 100644 --- a/w3fs26_8f.js +++ b/w3fs26_8f.js @@ -1,4 +1,4 @@ var w3fs26_8f = [ - [ "w3fs26", "w3fs26_8f.html#ab9c55405126eb6b249eb3d6542c0bb30", null ] + [ "w3fs26", "w3fs26_8f.html#a907c7328b67cac5929274519593d6c83", null ] ]; \ No newline at end of file diff --git a/w3fs26_8f_source.html b/w3fs26_8f_source.html index 12f9c849..5012dde1 100644 --- a/w3fs26_8f_source.html +++ b/w3fs26_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3fs26.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,95 +81,103 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3fs26.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Year, month, day from julian day number
          +
          3C> @author Ralph Jones @date 1987-03-29
          +
          4
          +
          5C> Computes year (4 digits), month, day, day of week, day of year from julian
          +
          6C> day number. this subroutine will work from 1583 a.d. to 3300 a.d.
          +
          7C>
          +
          8C> ### Program History Log:
          +
          9C> Date | Programmer | Comments
          +
          10C> -----|------------|---------
          +
          11C> 1987-03-29 | Ralph Jones |
          +
          12C> 1989-10-25 | Ralph Jones | Convert to cray cft77 fortran
          +
          13C>
          +
          14C> @param[in] JLDAYN (INT) Julian day number
          +
          15C> @param[out] IYEAR (INT) Year (4 digits)
          +
          16C> @param[out] MONTH (INT) Month
          +
          17C> @param[out] IDAY (INT) Day
          +
          18C> @param[out] IDAYWK (INT) Day of week (1 is sunday, 7 is sat)
          +
          19C> @param[out] IDAYYR (INT) Day of year (1 to 366)
          +
          20C>
          +
          21C> @note A julian day number can be computed by using one of the following
          +
          22C> statement functions. A day of week can be computed from the julian day
          +
          23C> number. A day of year can be computed from a julian day number and year.
          +
          24C>
          +
          25C> JDN(IYEAR,MONTH,IDAY) = IDAY - 32075
          +
          26C> + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4
          +
          27C> + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12
          +
          28C> - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4
          +
          29C>
          +
          30C> IYR (4 DIGITS) , IDYR(1-366) Day of year
          +
          31C>
          +
          32C> JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4
          +
          33C> -3 * ((IYR + 4899) / 100) / 4 + IDYR
          +
          34C>
          +
          35C> Day of week from julian day number, 1 is sunday, 7 is saturday.
          +
          36C>
          +
          37C> JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1
          +
          38C>
          +
          39C> Day of year from julian day number and 4 digit year.
          +
          40C>
          +
          41C> JDAYYR(JLDAYN,IYEAR) = JLDAYN -
          +
          42C> (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4)
          +
          43C>
          +
          44C> The first function was in a letter to the editor communications
          +
          45C> of the acm volume 11 / number 10 / october, 1968. the 2nd
          +
          46C> function was derived from the first. This subroutine was also
          +
          47C> included in the same letter. Julian day number 1 is
          +
          48C> jan 1,4713 b.c. a julian day number can be used to replace a
          +
          49C> day of century, this will take care of the date problem in
          +
          50C> the year 2000, or reduce program changes to one line change
          +
          51C> of 1900 to 2000. Julian day numbers can be used for finding
          +
          52C> record numbers in an archive or day of week, or day of year.
          +
          53C>
          +
          54C> @author Ralph Jones @date 1987-03-29
          +
          +
          55 SUBROUTINE w3fs26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR)
          +
          56C
          +
          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/w3ft00_8f.html b/w3ft00_8f.html index bc6be6c9..e56f99f1 100644 --- a/w3ft00_8f.html +++ b/w3ft00_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft00.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft00.f File Reference
          +
          w3ft00.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          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.
           

          Detailed Description

          Data field tranformation subroutine.

          @@ -107,8 +113,8 @@

          Definition in file w3ft00.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft00()

          + +

          ◆ w3ft00()

          @@ -117,79 +123,79 @@

          subroutine w3ft00 ( real, dimension(ia,ja)  - FLD, + fld, real, dimension(ib,jb)  - B, + b,   - IA, + ia,   - JA, + ja,   - IB, + ib,   - JB, + jb,   - CIP, + cip,   - CJP, + cjp,   - FIPB, + fipb,   - FJPB, + fjpb,   - SC, + sc,   - ARG, + arg,   - LIN  + lin  @@ -200,7 +206,7 @@

          Transforms data contained in a grid array by translation, rotation about a common point and dilatation to a new grid array.

          -

          +

          Program History Log:

          @@ -246,7 +252,7 @@

          diff --git a/w3ft00_8f.js b/w3ft00_8f.js index 7b28a9ec..38704bd3 100644 --- a/w3ft00_8f.js +++ b/w3ft00_8f.js @@ -1,4 +1,4 @@ var w3ft00_8f = [ - [ "w3ft00", "w3ft00_8f.html#a0df888e118ff615726dfe75f1f268c21", null ] + [ "w3ft00", "w3ft00_8f.html#aef914a82466f1f10f20f61a45cba4676", null ] ]; \ No newline at end of file diff --git a/w3ft00_8f_source.html b/w3ft00_8f_source.html index 31c11915..c8a4f949 100644 --- a/w3ft00_8f_source.html +++ b/w3ft00_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft00.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,170 +81,178 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft00.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Data field tranformation subroutine.
          +
          3C> @author J. McDonell @date 1974-09-01
          +
          4
          +
          5C> Transforms data contained in a grid array by translation, rotation about a
          +
          6C> common point and dilatation to a new grid array.
          +
          7C>
          +
          8C> ### Program History Log:
          +
          9C> Date | Programmer | Comments
          +
          10C> -----|------------|---------
          +
          11C> 1974-09-01 | J. McDonell | Initial.
          +
          12C> 1984-06-27 | Ralph Jones | Change to ibm vs fortran.
          +
          13C>
          +
          14C> @param[in] IA (Integer) i-dimension of the input array fa
          +
          15C> @param[in] JA (Integer) j-dimension of the input array fa
          +
          16C> @param[in] IB (Integer) i-dimension of the output array fb
          +
          17C> @param[in] JB (Integer) j-dimension of the output array fb
          +
          18C> @param[in] SC (Real) Scale change (dilation) expressed as a ratio of the
          +
          19C> transformed to the origional field.
          +
          20C> @param[in] ARG (Real) Degree measure of the angle required to rotate the
          +
          21C> j-row of the origional grid into coincidence with the new grid. (+ counter-
          +
          22C> clockwise, - clockwise)
          +
          23C> @param[in] LIN (Integer) Interpolation method switch
          +
          24C> - .eq. 1 bilinear interpolation
          +
          25C> - .ne. 1 biquadratic interpolation
          +
          26C> @param FLD
          +
          27C> @param B
          +
          28C> @param CIP
          +
          29C> @param CJP
          +
          30C> @param FIPB
          +
          31C> @param FJPB
          +
          32C>
          +
          33C> @remark In general 'fa' and 'fb' cannot be equivalenced although there are
          +
          34C> situations in which it would be safe to do so. care should be taken that
          +
          35C> all of the new grid points lie within the origional grid, no error checks
          +
          36C> are made.
          +
          37C>
          +
          38C> @author J. McDonell @date 1974-09-01
          +
          +
          39 SUBROUTINE w3ft00(FLD,B,IA,JA,IB,JB,CIP,CJP,FIPB,FJPB,SC,ARG,LIN)
          +
          40C
          +
          41 REAL B(IB,JB)
          +
          42 REAL ERAS(4)
          +
          43 REAL FLD(IA,JA)
          +
          44C
          +
          45 equivalence(ci,sti), (cj,stj)
          +
          46C
          +
          47 theta = arg * (3.14159 / 180.0)
          +
          48 sint = sin(theta)
          +
          49 cost = cos(theta)
          +
          50C
          +
          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
          +
          69C
          +
          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
          +
          76C
          +
          77 40 CONTINUE
          +
          78 kquad = 5
          +
          79C
          +
          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
          +
          86C
          +
          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
          +
          93C
          +
          94 90 CONTINUE
          +
          95 kquad = 5
          +
          96C
          +
          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
          +
          102C
          +
          103 110 CONTINUE
          +
          104 b(in,jn) = fld(ii,jj)
          +
          105 GO TO 180
          +
          106C
          +
          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
          +
          115C
          +
          116 IF ((lin-1).NE.0) GO TO 150
          +
          117C
          +
          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
          +
          125C
          +
          126 150 CONTINUE
          +
          127 xi2tm = xdeli * (xdeli - 1.0) * 0.25
          +
          128 xj2tm = xdelj * (xdelj - 1.0) * 0.25
          +
          129 j1 = j - 1
          +
          130C
          +
          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
          +
          136C
          +
          137 di = eras(2) + (eras(3) - eras(2)) * xdelj + (eras(1) -
          +
          138 & eras(2) - eras(3) + eras(4)) * xj2tm
          +
          139C
          +
          140 170 CONTINUE
          +
          141 b(in,jn) = di
          +
          142C
          +
          143 180 CONTINUE
          +
          144C
          +
          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/w3ft01_8f.html b/w3ft01_8f.html index b5da0c53..1e259218 100644 --- a/w3ft01_8f.html +++ b/w3ft01_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft01.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft01.f File Reference
          +
          w3ft01.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          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.
           

          Detailed Description

          Interpolate values in a data field.

          @@ -107,8 +113,8 @@

          Definition in file w3ft01.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft01()

          + +

          ◆ w3ft01()

          @@ -117,49 +123,49 @@

          subroutine w3ft01 (   - STI, + sti,   - STJ, + stj, real, dimension(ii,jj)  - FLD, + fld,   - HI, + hi,   - II, + ii,   - JJ, + jj,   - NCYCLK, + ncyclk,   - LIN  + lin  @@ -170,7 +176,7 @@

          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:

          @@ -216,7 +222,7 @@

          diff --git a/w3ft01_8f.js b/w3ft01_8f.js index d9a2ee1b..4499b343 100644 --- a/w3ft01_8f.js +++ b/w3ft01_8f.js @@ -1,4 +1,4 @@ var w3ft01_8f = [ - [ "w3ft01", "w3ft01_8f.html#a5712b189cf471fffe9b1529a75949729", null ] + [ "w3ft01", "w3ft01_8f.html#a526211242588a42f89dd5f724dd78595", null ] ]; \ No newline at end of file diff --git a/w3ft01_8f_source.html b/w3ft01_8f_source.html index 8543e3df..447e3be0 100644 --- a/w3ft01_8f_source.html +++ b/w3ft01_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft01.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,188 +81,196 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft01.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Interpolate values in a data field.
          +
          3C> @author James McDonell @date 1984-06-27
          +
          4
          +
          5C> For a given grid coordinate in a data array, estimates
          +
          6C> a data value for that point using either a linear or quadratic
          +
          7C> interpolation method.
          +
          8C>
          +
          9C> ### Program History Log:
          +
          10C> Date | Programmer | Commment
          +
          11C> -----|------------|---------
          +
          12C> 1984-06-27 | James McDonell | Initial
          +
          13C> 1989-11-01 | Ralph Jones | Change to cray cft77 fortran
          +
          14C>
          +
          15C> @param[in] STI Real*4 i grid coordinate of the point for which
          +
          16C> an interpolated value is desired.
          +
          17C> @param[in] STJ Real*4 j grid coordinate of the point for which
          +
          18C> an interpolated value is desired.
          +
          19C> @param[in] FLD Real*4 size(ii,jj) data field.
          +
          20C> @param[in] II Integer*4 number of columns in 'fld'.
          +
          21C> @param[in] JJ Integer*4 number of rows in 'fld'.
          +
          22C> @param[in] NCYCLK Integer*4 code to specify if grid is cyclic or
          +
          23C> not:
          +
          24C> - = 0 Non-cyclic in ii, non-cyclic in jj
          +
          25C> - = 1 Cyclic in ii, non-cyclic in jj
          +
          26C> - = 2 Cyclic in jj, non-cyclic in ii
          +
          27C> - = 3 Cyclic in ii, cyclic in jj
          +
          28C> @param[in] LIN Integer*4 code specifying interpolation method:
          +
          29C> - = 1 Linear interpolation
          +
          30C> - .NE.1 Quadratic interpolation
          +
          31C> @param[out] HI Real*4 data field value at (sti,stj) obtained
          +
          32C> by interpolation.
          +
          33C>
          +
          34C> @author James McDonell @date 1984-06-27
          +
          +
          35 SUBROUTINE w3ft01(STI,STJ,FLD,HI,II,JJ,NCYCLK,LIN)
          +
          36C
          +
          37 REAL ERAS(4)
          +
          38 REAL FLD(II,JJ)
          +
          39 REAL JY(4)
          +
          40C
          +
          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
          +
          62C
          +
          63C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 170
          +
          64C
          +
          65 GO TO 170
          +
          66C
          +
          67 10 CONTINUE
          +
          68 icyclk = 0
          +
          69 jcyclk = 0
          +
          70 IF (ncyclk) 20,120,20
          +
          71C
          +
          72 20 CONTINUE
          +
          73 IF (ncyclk / 2 .NE. 0) jcyclk = 1
          +
          74 IF (ncyclk .NE. 2) icyclk = 1
          +
          75 IF (icyclk) 30,70,30
          +
          76C
          +
          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
          +
          83C
          +
          84 40 CONTINUE
          +
          85 ip2 = 3
          +
          86 im1 = ii - 1
          +
          87 GO TO 60
          +
          88C
          +
          89 50 CONTINUE
          +
          90 ip2 = 2
          +
          91 im1 = ii - 2
          +
          92C
          +
          93 60 CONTINUE
          +
          94 ip1 = i + 1
          +
          95C
          +
          96 70 CONTINUE
          +
          97 IF (jcyclk) 80,120,80
          +
          98C
          +
          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
          +
          105C
          +
          106 90 CONTINUE
          +
          107 jy(4) = 3
          +
          108 jy(1) = jj - 1
          +
          109 GO TO 110
          +
          110C
          +
          111 100 CONTINUE
          +
          112 jy(4) = 2
          +
          113 jy(1) = jj - 2
          +
          114C
          +
          115 110 CONTINUE
          +
          116 jy(3) = j + 1
          +
          117 jy(2) = j
          +
          118C
          +
          119 120 CONTINUE
          +
          120 IF (lin.EQ.1) GO TO 160
          +
          121 IF (icyclk) 140,130,140
          +
          122C
          +
          123 130 CONTINUE
          +
          124 IF ((i.LT.2).OR.(i.GE.(ii-1))) xi2tm = 0.0
          +
          125C
          +
          126 140 CONTINUE
          +
          127 IF (jcyclk) 160,150,160
          +
          128C
          +
          129 150 CONTINUE
          +
          130 IF ((j.LT.2).OR.(j.GE.(jj-1))) xj2tm = 0.0
          +
          131C
          +
          132 160 CONTINUE
          +
          133C
          +
          134C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
          +
          135C
          +
          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
          +
          140C
          +
          141C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
          +
          142C
          +
          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
          +
          147C
          +
          148 170 CONTINUE
          +
          149 DO 180 k = 1,4
          +
          150 j1 = jy(k)
          +
          151C
          +
          152C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
          +
          153C
          +
          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
          +
          159C
          +
          160 hi = eras(2) + (eras(3) - eras(2)) * xdelj + (eras(1) -
          +
          161 & eras(2) - eras(3) + eras(4)) * xj2tm
          +
          162C
          +
          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/w3ft02_8f.html b/w3ft02_8f.html index 3444b356..3fc31a8f 100644 --- a/w3ft02_8f.html +++ b/w3ft02_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft02.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft02.f File Reference
          +
          w3ft02.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft02 (rain, imax, jmax, pi, pj, amount)
           Interpolate, using a fancy non-linear method, gridded quantitative precipitation forecasts to a specific interior point.
           

          Detailed Description

          Interpolate precipitation to specific point.

          @@ -107,8 +113,8 @@

          Definition in file w3ft02.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft02()

          + +

          ◆ w3ft02()

          @@ -117,37 +123,37 @@

          subroutine w3ft02 ( real, dimension(imax,jmax)  - RAIN, + rain,   - IMAX, + imax,   - JMAX, + jmax,   - PI, + pi,   - PJ, + pj,   - AMOUNT  + amount  @@ -158,8 +164,8 @@

          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().

          -

          +

          One point (e.g. an observation station) per call to w3ft02().

          +

          Program History Log:

          @@ -193,7 +199,7 @@

          diff --git a/w3ft02_8f.js b/w3ft02_8f.js index 3df492fb..c11c24f0 100644 --- a/w3ft02_8f.js +++ b/w3ft02_8f.js @@ -1,4 +1,4 @@ var w3ft02_8f = [ - [ "w3ft02", "w3ft02_8f.html#ab2829ffb3ea29d17638612b1e6f4bcdf", null ] + [ "w3ft02", "w3ft02_8f.html#a2d66a49241741b516a284f7881c67160", null ] ]; \ No newline at end of file diff --git a/w3ft02_8f_source.html b/w3ft02_8f_source.html index ef6439d8..da1f0f3a 100644 --- a/w3ft02_8f_source.html +++ b/w3ft02_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft02.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,222 +81,230 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft02.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Interpolate precipitation to specific point.
          +
          3C> @author Robert Hirano @date 1979-08-05
          +
          4
          +
          5C> Interpolate, using a fancy non-linear method,
          +
          6C> gridded quantitative precipitation forecasts to a specific
          +
          7C> interior point. One point (e.g. an observation station)
          +
          8C> per call to w3ft02().
          +
          9C>
          +
          10C> ### Program History Log:
          +
          11C> Date | Programmer | Comment
          +
          12C> -----|------------|--------
          +
          13C> 1979-08-05 | Robert Hirano | Initial.
          +
          14C> 1996-06-23 | Farley | Converted to cray fortran 77
          +
          15C>
          +
          16C> @param[in] RAIN Real*4 grid field of (forecast) precipitation.
          +
          17C> @param[in] IMAX Integer*4 i-dimension of rain field.
          +
          18C> @param[in] JMAX Integer *4 j-dimension of rain field.
          +
          19C> @param[in] PI Real*4 i-coordinate of interpolation point.
          +
          20C> @param[in] PJ Real*4 j-coordinate of interpolation point.
          +
          21C> @param[out] AMOUNT Real*4 amount of precip interpolated to pi,pj.
          +
          22C>
          +
          23C> @author Robert Hirano @date 1979-08-05
          +
          +
          24 SUBROUTINE w3ft02 (RAIN, IMAX, JMAX, PI, PJ, AMOUNT)
          +
          25C
          +
          26C INTERPOLATE PRECIPITATION FROM RAIN FIELD
          +
          27C TO INTERNAL POINT (PI,PJ). RESULT IN AMOUNT
          +
          28C
          +
          29 real RAIN(IMAX,JMAX)
          +
          30C
          +
          31C CHECK FOR INTERPOLATION POINT OUTSIDE GRID
          +
          32C
          +
          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
          +
          36C
          +
          37C SET UP RAIN AMMOUNTS AT CORNERS OF BOX SURROUNDING POINT (PI,PJ
          +
          38C
          +
          39C R2 R4
          +
          40C
          +
          41C (PI,PJ)
          +
          42C
          +
          43C R1 R3
          +
          44C
          +
          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)
          +
          51C
          +
          52C CHECK FOR NO RAIN AT ALL
          +
          53C
          +
          54 IF(amax1(r1,r2,r3,r4).LE.0.) GO TO 150
          +
          55C
          +
          56C GOT SOME -- FIND APPROPRIATE SECTOR AND SECTION
          +
          57C OF THE GRID BOX IN WHICH THE STATION IS LOCATED
          +
          58C
          +
          59 ai = pi-i
          +
          60 aj=pj-j
          +
          61 x = 0.5
          +
          62C
          +
          63C MEANINOF IC FOR SECTORS (K=1) OR SECTIONS (K=2)
          +
          64C
          +
          65C 2 4
          +
          66C
          +
          67C 1 3
          +
          68C
          +
          69C ALSO REFERENCED AS
          +
          70C
          +
          71C TOP DIAGONAL / T D
          +
          72C /
          +
          73C NEAR RIGHT / N R
          +
          74C
          +
          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
          +
          91C
          +
          92C SET UP SECTORS THIS BUSINESS IN EFFECT ROTATES THE SECTORS
          +
          93C FOR CONVENIENCE IN LATER INTERPOLATIONS
          +
          94C
          +
          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
          +
          124C
          +
          125C IF NO RAIN IN CORNER SECTTOR WHERE STATION IS - QUIT
          +
          126C
          +
          127 IF(r.LE.0.) GO TO 150
          +
          128 x = 0.5 * x
          +
          129 16 CONTINUE
          +
          130 1 CONTINUE
          +
          131C
          +
          132C INTERPOLATE TO STATION IN EASY (NON-CORNER) SECTIONS
          +
          133C
          +
          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
          +
          153C
          +
          154C CORNER (CENTER OF BOX) SECTION
          +
          155C
          +
          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
          +
          197C
          +
          +
          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/w3ft03_8f.html b/w3ft03_8f.html index fcb612c4..ea7ed22c 100644 --- a/w3ft03_8f.html +++ b/w3ft03_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft03.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft03.f File Reference
          +
          w3ft03.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft03 (fl, hi, sti, stj, maxi, maxj, itype)
           Do either bilinear or biquadratic interpolation for a point within a two-dimensional data array.
           

          Detailed Description

          A point interpolater.

          @@ -107,8 +113,8 @@

          Definition in file w3ft03.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft03()

          + +

          ◆ w3ft03()

          @@ -117,43 +123,43 @@

          subroutine w3ft03 ( real, dimension(maxi,maxj)  - FL, + fl,   - HI, + hi,   - STI, + sti,   - STJ, + stj,   - MAXI, + maxi,   - MAXJ, + maxj,   - ITYPE  + itype  @@ -164,7 +170,7 @@

          Do either bilinear or biquadratic interpolation for a point within a two-dimensional data array.

          -

          +

          Program History Log:

          @@ -208,7 +214,7 @@

          diff --git a/w3ft03_8f.js b/w3ft03_8f.js index 23682383..85d7e522 100644 --- a/w3ft03_8f.js +++ b/w3ft03_8f.js @@ -1,4 +1,4 @@ var w3ft03_8f = [ - [ "w3ft03", "w3ft03_8f.html#a86672f0df93a525a9c2f295bf3e9de0b", null ] + [ "w3ft03", "w3ft03_8f.html#a4989ac1555e50285597693623cc2da77", null ] ]; \ No newline at end of file diff --git a/w3ft03_8f_source.html b/w3ft03_8f_source.html index e801959e..13ed2904 100644 --- a/w3ft03_8f_source.html +++ b/w3ft03_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft03.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,102 +81,110 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft03.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief A point interpolater.
          +
          3C> @author James Howcroft @date 1979-02-15
          +
          4
          +
          5C> Do either bilinear or biquadratic interpolation for a
          +
          6C> point within a two-dimensional data array.
          +
          7C>
          +
          8C> ### Program History Log:
          +
          9C> Date | Programmer | Comment
          +
          10C> -----|------------|--------
          +
          11C> 1979-02-15 | James Howcroft | Initial.
          +
          12C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
          +
          13C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
          +
          14C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
          +
          15C> 1993-03-29 | Ralph Jones | Add save statement.
          +
          16C> 1996-07-01 | Ralph Jones | Compile on cray.
          +
          17C>
          +
          18C> @param[in] FL Real*4 two-dimensional cartesian array of data.
          +
          19C> @param[in] MAXI Integer*4 i-dimension of fl.
          +
          20C> @param[in] MAXJ Integer*4 j-dimension of fl.
          +
          21C> @param[in] STI Real*4 i-coordinate to which a value is to be
          +
          22C> interpolated.
          +
          23C> @param[in] STJ Real*4 j-coordinate to which a value is to be
          +
          24C> interpolated.
          +
          25C> @param ITYPE
          +
          26C> @param[out] HI Real*4 interpolated output value.
          +
          27C>
          +
          28C> @remark No error checks are made. it is left for the user to
          +
          29C> determine that the point for which interpolation is desired
          +
          30C> lies within the grid.
          +
          31C>
          +
          32C> @author James Howcroft @date 1979-02-15
          +
          +
          33 SUBROUTINE w3ft03(FL,HI,STI,STJ,MAXI,MAXJ,ITYPE)
          +
          34C
          +
          35 REAL FL(MAXI,MAXJ)
          +
          36 REAL E (4)
          +
          37C
          +
          38 SAVE
          +
          39C
          +
          40 i = sti
          +
          41 j = stj
          +
          42 di = i
          +
          43 dj = j
          +
          44 di = sti - di
          +
          45 dj = stj - dj
          +
          46C
          +
          47 hi = 0.
          +
          48C 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
          +
          52C DO BILINEAR IF POINT IS BETWEEN ULTIMATE AND
          +
          53C 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
          +
          57C
          +
          58C 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
          +
          63C
          +
          64 200 CONTINUE
          +
          65C 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
          +
          75C
          +
          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/w3ft05_8f.html b/w3ft05_8f.html index 773e155a..54024212 100644 --- a/w3ft05_8f.html +++ b/w3ft05_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft05.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft05.f File Reference
          +
          w3ft05.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft05 (alola, apola, w1, w2, linear)
           Convert a northern hemisphere 2.5 degree lat.,lon.
           

          Detailed Description

          Convert (145,37) to (65,65) n.

          @@ -107,8 +113,8 @@

          Definition in file w3ft05.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft05()

          + +

          ◆ w3ft05()

          @@ -117,31 +123,31 @@

          subroutine w3ft05 ( real, dimension(145,37)  - ALOLA, + alola, real, dimension(4225)  - APOLA, + apola, real, dimension(4225)  - W1, + w1, real, dimension(4225)  - W2, + w2,   - LINEAR  + linear  @@ -153,7 +159,7 @@

          +

          Program History Log:

          @@ -177,7 +183,7 @@

          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.
            • +
          • 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.
          @@ -195,7 +201,7 @@

          diff --git a/w3ft05_8f.js b/w3ft05_8f.js index a3afe657..fbe3a43a 100644 --- a/w3ft05_8f.js +++ b/w3ft05_8f.js @@ -1,4 +1,4 @@ var w3ft05_8f = [ - [ "w3ft05", "w3ft05_8f.html#a752b36aee00d233764c2d4fc9aa83d48", null ] + [ "w3ft05", "w3ft05_8f.html#affc8959bc48cc6dde6f3d7930a8b407f", null ] ]; \ No newline at end of file diff --git a/w3ft05_8f_source.html b/w3ft05_8f_source.html index e92661b2..1609e26e 100644 --- a/w3ft05_8f_source.html +++ b/w3ft05_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft05.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,251 +81,259 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft05.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (145,37) to (65,65) n. hemi. grid
          +
          3C> @author Ralph Jones @date 1985-04-08
          +
          4
          +
          5C> Convert a northern hemisphere 2.5 degree lat.,lon. 145 by
          +
          6C> 37 grid to a polar stereographic 65 by 65 grid. The polar
          +
          7C> stereographic map projection is true at 60 deg. n. , The mesh
          +
          8C> length is 381 km. and the oriention is 80 deg. w.
          +
          9C>
          +
          10C> ### Program History Log:
          +
          11C> Date | Programmer | Comment
          +
          12C> -----|------------|--------
          +
          13C> 1985-04-08 | Ralph Jones | Initial.
          +
          14C> 1991-07-30 | Ralph Jones | convert to cray cft77 fortran.
          +
          15C> 1992-05-02 | Ralph Jones | add save.
          +
          16C>
          +
          17C> @param[in] ALOLA 145*37 grid 2.5 lat,lon grid n. hemi.
          +
          18C> 5365 point grid is type 29 or 1d hex o.n. 84
          +
          19C> @param[in] LINEAR 1 linear interpolation , ne.1 biquadratic
          +
          20C> @param[out] APOLA 65*65 grid of northern hemi.
          +
          21C> 4225 point grid is type 27 or 1b hex o.n. 84
          +
          22C> @param[out] W1 65*65 scratch field
          +
          23C> @param[out] W2 65*65 scratch field
          +
          24C>
          +
          25C> @remark
          +
          26C> - 1. W1 and w2 are used to store sets of constants which are
          +
          27C> reusable for repeated calls to the subroutine. If they are
          +
          28C> over written by the user, a warning message will be printed
          +
          29C> and w1 and w2 will be recomputed.
          +
          30C> - 2. Wind components are not rotated to the 65*65 grid orientation
          +
          31C> after interpolation. You may use w3fc08() to do this.
          +
          32C> - 3. The grid points values on the equator have been extrapolated
          +
          33C> outward to all the grid points outside the equator on the 65*65
          +
          34C> grid (about 1100 points).
          +
          35C> - 4. You should use the cray vectorized version w3ft05v on the cray
          +
          36C> it has 3 parameters in the call, runs about 10 times faster. Uses
          +
          37C> more memory.
          +
          38C>
          +
          39C> @author Ralph Jones @date 1985-04-08
          +
          +
          40 SUBROUTINE w3ft05(ALOLA,APOLA,W1,W2,LINEAR)
          +
          41C
          +
          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)
          +
          49C
          +
          50 INTEGER JY(4)
          +
          51 INTEGER OUT
          +
          52C
          +
          53 LOGICAL LIN
          +
          54C
          +
          55 SAVE
          +
          56C
          +
          57 DATA degprd/57.2957795/
          +
          58 DATA earthr/6371.2/
          +
          59 DATA iswt /0/
          +
          60 DATA out /6/
          +
          61C
          +
          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 ***)
          +
          65C
          +
          66 lin = .false.
          +
          67 IF (linear.EQ.1) lin = .true.
          +
          68C
          +
          69 IF (iswt.EQ.0) GO TO 300
          +
          70C
          +
          71C TEST W1 AND W2 TO SEE IF THEY WERE WRITTEN OVER
          +
          72C
          +
          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
          +
          78C
          +
          79 200 CONTINUE
          +
          80 WRITE (out,4000)
          +
          81C
          +
          82 300 CONTINUE
          +
          83 deg = 2.5
          +
          84 nn = 0
          +
          85 xmesh = 381.0
          +
          86 gi2 = (1.86603*earthr) / xmesh
          +
          87 gi2 = gi2 * gi2
          +
          88C
          +
          89C DO LOOP 800 PUTS SUBROUTINE W3FB01 IN LINE
          +
          90C
          +
          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
          +
          107C
          +
          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
          +
          119C
          +
          120 DO 900 kk = 1,10
          +
          121 savew1(kk) = w1(kk)
          +
          122 savew2(kk) = w2(kk)
          +
          123 900 CONTINUE
          +
          124C
          +
          125 iswt = 1
          +
          126C
          +
          127 1000 CONTINUE
          +
          128C
          +
          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
          +
          146C
          +
          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
          +
          150C
          +
          151C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1700
          +
          152C
          +
          153 GO TO 1700
          +
          154C
          +
          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
          +
          161C
          +
          162 1300 CONTINUE
          +
          163 ip2 = 3
          +
          164 im1 = 144
          +
          165 GO TO 1500
          +
          166C
          +
          167 1400 CONTINUE
          +
          168 ip2 = 2
          +
          169 im1 = 143
          +
          170C
          +
          171 1500 CONTINUE
          +
          172 ip1 = i + 1
          +
          173 IF (lin) GO TO 1600
          +
          174 IF ((j.LT.2).OR.(j.GE.36)) xj2tm=0.
          +
          175C.....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
          +
          180C
          +
          181 1600 CONTINUE
          +
          182C.....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
          +
          187C
          +
          188 1700 CONTINUE
          +
          189 IF (.NOT.lin) GO TO 1900
          +
          190C
          +
          191C LINEAR INTERPLOATION
          +
          192C
          +
          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
          +
          199C
          +
          200 apola(kk) = eras(2) + (eras(3) - eras(2)) * xdelj
          +
          201 GO TO 2100
          +
          202C
          +
          203 1900 CONTINUE
          +
          204C
          +
          205C QUADRATIC INTERPOLATION
          +
          206C
          +
          207 DO 2000 k = 1,4
          +
          208 j1 = jy(k)
          +
          209C.....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
          +
          216C
          +
          217 apola(kk) = eras(2)+(eras(3)-eras(2))*xdelj+(eras(1)-
          +
          218 & eras(2)-eras(3)+eras(4)) * xj2tm
          +
          219C
          +
          220 2100 CONTINUE
          +
          221C
          +
          222C SET POLE POINT , WMO STANDARD FOR U OR V
          +
          223C
          +
          224 apola(2113) = alola(73,37)
          +
          225C
          +
          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/w3ft05v_8f.html b/w3ft05v_8f.html index 98c5d303..da6da061 100644 --- a/w3ft05v_8f.html +++ b/w3ft05v_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft05v.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft05v.f File Reference
          +
          w3ft05v.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft05v (alola, apola, interp)
           Convert a northern hemisphere 2.5 degree lat.,lon.
           

          Detailed Description

          Convert (145,37) grid to (65,65) n.

          @@ -107,8 +113,8 @@

          Definition in file w3ft05v.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft05v()

          + +

          ◆ w3ft05v()

          @@ -117,19 +123,19 @@

          subroutine w3ft05v ( real, dimension(145,37)  - ALOLA, + alola, real, dimension(4225)  - APOLA, + apola,   - INTERP  + interp  @@ -141,13 +147,13 @@

          +

          Program History Log:

          - + @@ -180,7 +186,7 @@

          diff --git a/w3ft05v_8f.js b/w3ft05v_8f.js index 22a87013..4d587a0d 100644 --- a/w3ft05v_8f.js +++ b/w3ft05v_8f.js @@ -1,4 +1,4 @@ var w3ft05v_8f = [ - [ "w3ft05v", "w3ft05v_8f.html#a77ae0ff42d73bc3e901c84d6fae74d60", null ] + [ "w3ft05v", "w3ft05v_8f.html#a261ecb9571005278007fb4a6fbaf422a", null ] ]; \ No newline at end of file diff --git a/w3ft05v_8f_source.html b/w3ft05v_8f_source.html index daef8e6a..e1ee6bc8 100644 --- a/w3ft05v_8f_source.html +++ b/w3ft05v_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft05v.f Source File @@ -23,10 +23,9 @@

          Date Programmer Comment
          1985-04-10 Ralph Jones Vectorized version of w3ft05().
          1985-04-10 Ralph Jones Vectorized version of w3ft05().
          1989-10-21 Ralph Jones Changes to increase speed.
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,277 +81,285 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft05v.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (145,37) grid to (65,65) n. hemi. grid
          +
          3C> @author Ralph Jones @date 1985-04-10
          +
          4
          +
          5C> Convert a northern hemisphere 2.5 degree lat.,lon. 145 by
          +
          6C> 37 grid to a polar stereographic 65 by 65 grid. The polar
          +
          7C> stereographic map projection is true at 60 deg. n. , The mesh
          +
          8C> length is 381 km. and the oriention is 80 deg. w.
          +
          9C>
          +
          10C> ### Program History Log:
          +
          11C> Date | Programmer | Comment
          +
          12C> -----|------------|--------
          +
          13C> 1985-04-10 | Ralph Jones | Vectorized version of w3ft05().
          +
          14C> 1989-10-21 | Ralph Jones | Changes to increase speed.
          +
          15C> 1991-07-25 | Ralph Jones | Change to cray cft77 fortran.
          +
          16C>
          +
          17C> @param[in] ALOLA 145*37 gid 2.5 lat,lon grid n. hemisphere
          +
          18C> 5365 point grid is o.n. 84 type 29 or 1d hex
          +
          19C> interp - 1 linear interpolation , ne.1 biquadratic
          +
          20C> @param[out] APOLA 65*65 grid of northern hemisphere
          +
          21C> 4225 point grid is o.n.84 type 27 or 1b hex.
          +
          22C> @param INTERP
          +
          23C> @remark
          +
          24C> - 1. W1 and w2 are used to store sets of constants which are
          +
          25C> reusable for repeated calls to the subroutine.
          +
          26C> - 2. Wind components are not rotated to the 65*65 grid orientation
          +
          27C> after interpolation. you may use w3fc08 to do this.
          +
          28C> - 3. The grid points values on the equator have been extrapolated
          +
          29C> outward to all the grid points outside the equator on the 65*65
          +
          30C> grid (about 1100 points).
          +
          31C>
          +
          32C> @author Ralph Jones @date 1985-04-10
          +
          +
          33 SUBROUTINE w3ft05v(ALOLA,APOLA,INTERP)
          +
          34C
          +
          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)
          +
          42C
          +
          43 INTEGER IV(4225), JV(4225), JY(4225,4)
          +
          44 INTEGER IM1(4225), IP1(4225), IP2(4225)
          +
          45C
          +
          46 LOGICAL LIN
          +
          47C
          +
          48 SAVE
          +
          49C
          +
          50 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
          +
          51C
          +
          52 DATA degprd/57.2957795/
          +
          53 DATA earthr/6371.2/
          +
          54 DATA intrpo/99/
          +
          55 DATA iswt /0/
          +
          56C
          +
          57 lin = .false.
          +
          58 IF (interp.EQ.1) lin = .true.
          +
          59C
          +
          60 IF (iswt.EQ.1) GO TO 900
          +
          61C
          +
          62 orient = 80.0
          +
          63 deg = 2.5
          +
          64 xmesh = 381.0
          +
          65 gi2 = (1.86603 * earthr) / xmesh
          +
          66 gi2 = gi2 * gi2
          +
          67C
          +
          68C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
          +
          69C
          +
          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
          +
          76C
          +
          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
          +
          82C
          +
          83 xii(2113) = 1.0
          +
          84 DO 300 kk = 1,4225
          +
          85 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
          +
          86 300 CONTINUE
          +
          87C
          +
          88 DO 400 kk = 1,4225
          +
          89 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
          +
          90 400 CONTINUE
          +
          91C
          +
          92 DO 500 kk = 1,4225
          +
          93 wlon(kk) = 270.0 + orient - angle(kk)
          +
          94 500 CONTINUE
          +
          95C
          +
          96 DO 600 kk = 1,4225
          +
          97 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
          +
          98 600 CONTINUE
          +
          99C
          +
          100 DO 700 kk = 1,4225
          +
          101 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
          +
          102 700 CONTINUE
          +
          103C
          +
          104 xlat(2113) = 90.0
          +
          105 wlon(2113) = 0.0
          +
          106C
          +
          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
          +
          111C
          +
          112 iswt = 1
          +
          113 intrpo = interp
          +
          114 GO TO 1000
          +
          115C
          +
          116C AFTER THE 1ST CALL TO W3FT05V TEST INTERP, IF IT HAS
          +
          117C CHANGED RECOMPUTE SOME CONSTANTS
          +
          118C
          +
          119 900 CONTINUE
          +
          120 IF (interp.EQ.intrpo) GO TO 2100
          +
          121 intrpo = interp
          +
          122C
          +
          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
          +
          133C
          +
          134 IF (lin) GO TO 1400
          +
          135C
          +
          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
          +
          144C
          +
          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
          +
          154C
          +
          155 1400 CONTINUE
          +
          156C
          +
          157 IF (lin) GO TO 1700
          +
          158C
          +
          159 DO 1500 kk = 1,4225
          +
          160 IF (jv(kk).LT.2.OR.jv(kk).GT.35) xj2tm(kk) = 0.0
          +
          161 1500 CONTINUE
          +
          162C
          +
          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
          +
          169C
          +
          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
          +
          177C
          +
          178C LINEAR INTERPOLATION
          +
          179C
          +
          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
          +
          186C
          +
          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
          +
          195C
          +
          196 2100 CONTINUE
          +
          197 IF (lin) THEN
          +
          198C
          +
          199C LINEAR INTERPOLATION
          +
          200C
          +
          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
          +
          207C
          +
          208 DO 2300 kk = 1,4225
          +
          209 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
          +
          210 & * xdelj(kk)
          +
          211 2300 CONTINUE
          +
          212C
          +
          213 ELSE
          +
          214C
          +
          215C QUADRATIC INTERPOLATION
          +
          216C
          +
          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
          +
          239C
          +
          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
          +
          245C
          +
          246 ENDIF
          +
          247C
          +
          248C SET POLE POINT , WMO STANDARD FOR U OR V
          +
          249C
          +
          250 apola(2113) = alola(73,37)
          +
          251C
          +
          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/w3ft06_8f.html b/w3ft06_8f.html index b5635cb2..354cf4e9 100644 --- a/w3ft06_8f.html +++ b/w3ft06_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft06.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft06.f File Reference
          +
          w3ft06.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft06 (alola, apola, w1, w2, linear)
           Convert a southern hemisphere 2.5 degree lat.,lon.
           

          Detailed Description

          Convert (145,37) to (65,65) s.

          @@ -107,8 +113,8 @@

          Definition in file w3ft06.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft06()

          + +

          ◆ w3ft06()

          @@ -117,31 +123,31 @@

          subroutine w3ft06 ( real, dimension(145,37)  - ALOLA, + alola, real, dimension(4225)  - APOLA, + apola, real, dimension(4225)  - W1, + w1, real, dimension(4225)  - W2, + w2,   - LINEAR  + linear  @@ -153,7 +159,7 @@

          +

          Program History Log:

          @@ -179,7 +185,7 @@

        • 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.
          • +
        • 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
          @@ -195,7 +201,7 @@

          diff --git a/w3ft06_8f.js b/w3ft06_8f.js index db53290f..24fb6390 100644 --- a/w3ft06_8f.js +++ b/w3ft06_8f.js @@ -1,4 +1,4 @@ var w3ft06_8f = [ - [ "w3ft06", "w3ft06_8f.html#a251b117d0bb18aa51a81c14180fda635", null ] + [ "w3ft06", "w3ft06_8f.html#a9a0693ca342aef48beac578a24c71e76", null ] ]; \ No newline at end of file diff --git a/w3ft06_8f_source.html b/w3ft06_8f_source.html index f1fb6350..7368d27e 100644 --- a/w3ft06_8f_source.html +++ b/w3ft06_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft06.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,244 +81,252 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft06.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (145,37) to (65,65) s. hemi. grid.
          +
          3C> @author Ralph Jones @date 1984-06-18
          +
          4
          +
          5C> Convert a southern hemisphere 2.5 degree lat.,lon. 145 by
          +
          6C> 37 grid to a polar stereographic 65 by 65 grid. The polar
          +
          7C> stereographic map projection is true at 60 deg. s.; The mesh
          +
          8C> length is 381 km. and the oriention is 260 deg. w.(100e).
          +
          9C>
          +
          10C> ### Program History Log:
          +
          11C> Date | Programmer | Comment
          +
          12C> -----|------------|--------
          +
          13C> 1984-06-18 | Ralph Jones | Initial.
          +
          14C> 1991-07-30 | Ralph Jones | Convert to cray cft77 fortran.
          +
          15C> 1992-05-02 | Ralph Jones | Add save.
          +
          16C>
          +
          17C> @param[in] ALOLA 145*37 deg 2.5 lat,lon grid s. hemi.
          +
          18C> 5365 point grid is type 30 or 1e hex o.n. 84.
          +
          19C> @param[in] LINEAR 1 linear interpolation , ne.1 biquadratic.
          +
          20C> @param[out] APOLA 65*65 grid of southern hemi.
          +
          21C> 4225 point grid is type 28 or 1c hex o.n. 84.
          +
          22C> @param[out] W1 65*65 scratch field.
          +
          23C> @param[out] W2 65*65 scratch field. FT06F001 Error message
          +
          24C>
          +
          25C> @remark
          +
          26C> - 1. W1 and w2 are used to store sets of constants which are
          +
          27C> reusable for repeated calls to the subroutine. If they are
          +
          28C> over written by the user, a warning message will be printed
          +
          29C> and w1 and w2 will be recomputed.
          +
          30C> - 2. Wind components are not rotated to the 65*65 grid orientation
          +
          31C> after interpolation. You may use w3fc10() to do this.
          +
          32C> - 3. The grid points values on the equator have been extrapolated
          +
          33C> outward to all the grid points outside the equator on the 65*65
          +
          34C> grid (about 1100 points).
          +
          35C> - 4. You should use the cray vectorized verion w3ft06v() on the cray
          +
          36C> it has 3 parameters in the call, runs about times faster, uses
          +
          37C> more memory.
          +
          38C>
          +
          39C> @author Ralph Jones @date 1984-06-18
          +
          +
          40 SUBROUTINE w3ft06(ALOLA,APOLA,W1,W2,LINEAR)
          +
          41C
          +
          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)
          +
          49C
          +
          50 INTEGER JY(4)
          +
          51 INTEGER OUT
          +
          52C
          +
          53 LOGICAL LIN
          +
          54C
          +
          55 SAVE
          +
          56C
          +
          57 DATA degprd/57.2957795/
          +
          58 DATA earthr/6371.2/
          +
          59 DATA iswt /0/
          +
          60 DATA out /6/
          +
          61C
          +
          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 ***)
          +
          65C
          +
          66 lin = .false.
          +
          67 IF (linear.EQ.1) lin = .true.
          +
          68 IF (iswt.EQ.0) GO TO 300
          +
          69C
          +
          70C TEST TO SEE IF W1 OR W2 WAS WRITTEN OVER
          +
          71C
          +
          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
          +
          77C
          +
          78 200 CONTINUE
          +
          79 WRITE (out,4000)
          +
          80C
          +
          81 300 CONTINUE
          +
          82 deg = 2.5
          +
          83 nn = 0
          +
          84 xmesh = 381.0
          +
          85 gi2 = (1.86603*earthr) / xmesh
          +
          86 gi2 = gi2 * gi2
          +
          87C
          +
          88C DO LOOP 600 PUTS SUBROUTINE W3FB03 IN LINE
          +
          89C
          +
          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
          +
          114C
          +
          115 DO 700 kk=1,10
          +
          116 savew1(kk)=w1(kk)
          +
          117 savew2(kk)=w2(kk)
          +
          118 700 CONTINUE
          +
          119C
          +
          120 iswt = 1
          +
          121C
          +
          122 800 CONTINUE
          +
          123C
          +
          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
          +
          144C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1500
          +
          145 GO TO 1500
          +
          146C
          +
          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
          +
          153C
          +
          154 1100 CONTINUE
          +
          155 ip2 = 3
          +
          156 im1 = 144
          +
          157 GO TO 1300
          +
          158C
          +
          159 1200 CONTINUE
          +
          160 ip2 = 2
          +
          161 im1 = 143
          +
          162C
          +
          163 1300 CONTINUE
          +
          164 ip1 = i + 1
          +
          165 IF (lin) GO TO 1400
          +
          166 IF ((j.LT.2).OR.(j.GE.36)) xj2tm=0.
          +
          167C.....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
          +
          172C
          +
          173 1400 CONTINUE
          +
          174C.....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
          +
          179C
          +
          180 1500 CONTINUE
          +
          181C
          +
          182 IF (.NOT.lin) GO TO 1700
          +
          183C
          +
          184C LINEAR INTERPOLATION
          +
          185C
          +
          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
          +
          192C
          +
          193 apola(kk) = eras(2) + (eras(3) - eras(2)) * xdelj
          +
          194 GO TO 1900
          +
          195C
          +
          196 1700 CONTINUE
          +
          197C
          +
          198C QUADRATIC INTERPOLATION
          +
          199C
          +
          200 DO 1800 k = 1,4
          +
          201 j1 = jy(k)
          +
          202C.....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
          +
          209C
          +
          210 apola(kk) = eras(2)+(eras(3)-eras(2))*xdelj+(eras(1)-
          +
          211 & eras(2)-eras(3)+eras(4))*xj2tm
          +
          212C
          +
          213 1900 CONTINUE
          +
          214C
          +
          215C SET POLE POINT, WMO STANDARD FOR U OR V
          +
          216C
          +
          217 apola(2113) = alola(73,1)
          +
          218C
          +
          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/w3ft06v_8f.html b/w3ft06v_8f.html index 5029d238..57a903aa 100644 --- a/w3ft06v_8f.html +++ b/w3ft06v_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft06v.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft06v.f File Reference
          +
          w3ft06v.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft06v (alola, apola, interp)
           Convert a southern hemisphere 2.5 degree lat.,lon.
           

          Detailed Description

          Convert (145,37) grid to (65,65) s.

          @@ -107,8 +113,8 @@

          Definition in file w3ft06v.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft06v()

          + +

          ◆ w3ft06v()

          @@ -117,19 +123,19 @@

          subroutine w3ft06v ( real, dimension(145,37)  - ALOLA, + alola, real, dimension(4225)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

          +

          Program History Log:

          @@ -182,7 +188,7 @@

          diff --git a/w3ft06v_8f.js b/w3ft06v_8f.js index fb2d867f..4b672701 100644 --- a/w3ft06v_8f.js +++ b/w3ft06v_8f.js @@ -1,4 +1,4 @@ var w3ft06v_8f = [ - [ "w3ft06v", "w3ft06v_8f.html#a02340fb38509abdb031c638362609844", null ] + [ "w3ft06v", "w3ft06v_8f.html#aa210c5c31ea35f700b91ed8ce6ed1239", null ] ]; \ No newline at end of file diff --git a/w3ft06v_8f_source.html b/w3ft06v_8f_source.html index 6df22f53..ce69642f 100644 --- a/w3ft06v_8f_source.html +++ b/w3ft06v_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft06v.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,277 +81,285 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft06v.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (145,37) grid to (65,65) s. hemi. grid.
          +
          3C> @author Ralph Jones @date 1985-04-10
          +
          4
          +
          5C> Convert a southern hemisphere 2.5 degree lat.,lon. 145 by
          +
          6C> 37 grid to a polar stereographic 65 by 65 grid. The polar
          +
          7C> stereographic map projection is true at 60 deg. s.; The mesh
          +
          8C> length is 381 km. and the oriention is 260 deg. w.
          +
          9C>
          +
          10C> ### Program History Log:
          +
          11C> Date | Programmer | Comment
          +
          12C> -----|------------|--------
          +
          13C> 1985-04-10 | Ralph Jones | Vectorized version of w3ft05.
          +
          14C> 1989-10-21 | Ralph Jones | Changes to increase speed.
          +
          15C> 1991-07-24 | Ralph Jones | Change to cray cft77 fortran.
          +
          16C> 1993-05-31 | Ralph Jones | Recompile so linear interpolation works.
          +
          17C>
          +
          18C> @param[in] ALOLA - 145*37 gid 2.5 lat,lon grid s. hemishere. 5365 point
          +
          19C> grid is o.n.84 type 30 or 1e hex.
          +
          20C> @param[in] INTERP - 1 linear interpolation , ne.1 biquadratic.
          +
          21C> @param[out] APOLA - 65*65 grid of northern hemi. 4225 point grid is o.n. 84
          +
          22C> type 28 or 1c hex.
          +
          23C>
          +
          24C> @remark
          +
          25C> - 1. W1 and w2 are used to store sets of constants which are
          +
          26C> reusable for repeated calls to the subroutine.
          +
          27C> - 2. Wind components are not rotated to the 65*65 grid orientation
          +
          28C> after interpolation. You may use w3fc10 to do this.
          +
          29C> - 3. The grid points values on the equator have been extrapolated
          +
          30C> outward to all the grid points outside the equator on the 65*65
          +
          31C> grid (about 1100 points).
          +
          32C>
          +
          33C> @author Ralph Jones @date 1985-04-10
          +
          +
          34 SUBROUTINE w3ft06v(ALOLA,APOLA,INTERP)
          +
          35C
          +
          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)
          +
          43C
          +
          44 INTEGER IV(4225), JV(4225), JY(4225,4)
          +
          45 INTEGER IM1(4225), IP1(4225), IP2(4225)
          +
          46C
          +
          47 LOGICAL LIN
          +
          48C
          +
          49 SAVE
          +
          50C
          +
          51 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
          +
          52C
          +
          53 DATA degprd/57.2957795/
          +
          54 DATA earthr/6371.2/
          +
          55 DATA intrpo/99/
          +
          56 DATA iswt /0/
          +
          57C
          +
          58 lin = .false.
          +
          59 IF (interp.EQ.1) lin = .true.
          +
          60 IF (iswt.EQ.1) GO TO 900
          +
          61C
          +
          62 orient = 260.0
          +
          63 deg = 2.5
          +
          64 xmesh = 381.0
          +
          65 gi2 = (1.86603 * earthr) / xmesh
          +
          66 gi2 = gi2 * gi2
          +
          67C
          +
          68C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB03 IN LINE
          +
          69C
          +
          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
          +
          76C
          +
          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
          +
          82C
          +
          83 xii(2113) = 1.0
          +
          84 DO 300 kk = 1,4225
          +
          85 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
          +
          86 300 CONTINUE
          +
          87C
          +
          88 DO 400 kk = 1,4225
          +
          89 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
          +
          90 400 CONTINUE
          +
          91C
          +
          92 DO 500 kk = 1,4225
          +
          93 wlon(kk) = angle(kk) + orient - 270.0
          +
          94 500 CONTINUE
          +
          95C
          +
          96 DO 600 kk = 1,4225
          +
          97 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
          +
          98 600 CONTINUE
          +
          99C
          +
          100 DO 700 kk = 1,4225
          +
          101 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
          +
          102 700 CONTINUE
          +
          103C
          +
          104 xlat(2113) = -90.0
          +
          105 wlon(2113) = 0.0
          +
          106C
          +
          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
          +
          111C
          +
          112 iswt = 1
          +
          113 intrpo = interp
          +
          114 GO TO 1000
          +
          115C
          +
          116C AFTER THE 1ST CALL TO W3FT05 TEST INTERP, IF IT HAS
          +
          117C CHANGED RECOMPUTE SOME CONSTANTS
          +
          118C
          +
          119 900 CONTINUE
          +
          120 IF (interp.EQ.intrpo) GO TO 2100
          +
          121 intrpo = interp
          +
          122C
          +
          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
          +
          133C
          +
          134 IF (lin) GO TO 1400
          +
          135C
          +
          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
          +
          144C
          +
          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
          +
          154C
          +
          155 1400 CONTINUE
          +
          156C
          +
          157 IF (lin) GO TO 1700
          +
          158C
          +
          159 DO 1500 kk = 1,4225
          +
          160 IF (jv(kk).LT.2.OR.jv(kk).GT.35) xj2tm(kk) = 0.0
          +
          161 1500 CONTINUE
          +
          162C
          +
          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
          +
          169C
          +
          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
          +
          177C
          +
          178C LINEAR INTERPOLATION
          +
          179C
          +
          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
          +
          186C
          +
          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
          +
          195C
          +
          196 2100 CONTINUE
          +
          197 IF (lin) THEN
          +
          198C
          +
          199C LINEAR INTERPOLATION
          +
          200C
          +
          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
          +
          207C
          +
          208 DO 2300 kk = 1,4225
          +
          209 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
          +
          210 & * xdelj(kk)
          +
          211 2300 CONTINUE
          +
          212C
          +
          213 ELSE
          +
          214C
          +
          215C QUADRATIC INTERPOLATION
          +
          216C
          +
          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
          +
          239C
          +
          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
          +
          245C
          +
          246 ENDIF
          +
          247C
          +
          248C SET POLE POINT , WMO STANDARD FOR U OR V
          +
          249C
          +
          250 apola(2113) = alola(73,1)
          +
          251C
          +
          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/w3ft07_8f.html b/w3ft07_8f.html index 4568f70f..3f60712a 100644 --- a/w3ft07_8f.html +++ b/w3ft07_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft07.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft07.f File Reference
          +
          w3ft07.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          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.
           

          Detailed Description

          Transform gridpoint fld by interpolation.

          @@ -107,8 +113,8 @@

          Definition in file w3ft07.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft07()

          + +

          ◆ w3ft07()

          @@ -117,91 +123,91 @@

          subroutine w3ft07 ( real, dimension(ia,ja)  - FLDA, + flda,   - IA, + ia,   - JA, + ja, real  - AIPOLE, + aipole, real  - AJPOLE, + ajpole, real  - BIPOLE, + bipole, real  - BJPOLE, + bjpole, real  - DSCALE, + dscale, real  - ANGLE, + angle, logical  - LINEAR, + linear, logical  - LDEFQQ, + ldefqq, real  - DEFALT, + defalt, real, dimension(ib,jb)  - FLDB, + fldb,   - IB, + ib,   - JB  + jb  @@ -212,7 +218,7 @@

          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:

          @@ -226,7 +232,7 @@

          - +
          1989-03-31 Ralph Jones Change to vax-11 fortran
          1993-03-16 D. Shimomura Renamed from w3ft00() to w3ft07()
          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
          @@ -267,7 +273,7 @@

          diff --git a/w3ft07_8f.js b/w3ft07_8f.js index a137f12e..ceaa5cbb 100644 --- a/w3ft07_8f.js +++ b/w3ft07_8f.js @@ -1,4 +1,4 @@ var w3ft07_8f = [ - [ "w3ft07", "w3ft07_8f.html#a226490ee379923e202ba1f7d0d14102a", null ] + [ "w3ft07", "w3ft07_8f.html#aa7bd2293b69b72da36707f39093fb0dd", null ] ]; \ No newline at end of file diff --git a/w3ft07_8f_source.html b/w3ft07_8f_source.html index ad8fec2b..b29ccc32 100644 --- a/w3ft07_8f_source.html +++ b/w3ft07_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft07.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,246 +81,254 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft07.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Transform gridpoint fld by interpolation.
          +
          3C> @author McDonell & Howcroft @date 1974-09-01
          +
          4
          +
          5C> Transforms data contained in a given grid array
          +
          6C> by translation, rotation about a common point and dilatation
          +
          7C> in order to create a new grid array according to specs.
          +
          8C>
          +
          9C> ### Program History Log:
          +
          10C> Date | Programmer | Comment
          +
          11C> -----|------------|--------
          +
          12C> 1974-09-01 | J. McDonell, J.Howcroft | Initial.
          +
          13C> 1984-06-27 | Ralph Jones | Change to ibm vs fortran
          +
          14C> 1989-01-24 | Ralph Jones | Change to microsoft fortran 4.10
          +
          15C> 1989-03-31 | Ralph Jones | Change to vax-11 fortran
          +
          16C> 1993-03-16 | D. Shimomura | Renamed from w3ft00() to w3ft07()
          +
          17C> in order to make minor mods while doing f77. Changes to call sequence;
          +
          18C> changes to vrbl names; added comments.
          +
          19C>
          +
          20C> @param[in] FLDA Real*4 original source grid-point data field
          +
          21C> @param[in] IA (Input for FLDA)
          +
          22C> @param[in] JA (Input for FLDA)
          +
          23C> @param[in] FLDB Real*4 original source grid-point data field
          +
          24C> @param[in] IB (Input for FLDB)
          +
          25C> @param[in] JB (Input for FLDB)
          +
          26C> @param[in] AIPOLE Real*4 common point i-coordinates of the
          +
          27C> original field, assuming a right-hand cartesian
          +
          28C> coordinate system. the point need not be inside the bounds of either grid
          +
          29C> @param[in] AJPOLE Real*4 common point j-coordinates of the
          +
          30C> original field, assuming a right-hand cartesian
          +
          31C> coordinate system. the point need not be inside the bounds of either grid
          +
          32C> and can have fractional values. Common point about which to rotate the gridpoints.
          +
          33C> @param[in] BIPOLE - Real*4 common point i-coordinates for
          +
          34C> transformed destination grid
          +
          35C> @param[in] BJPOLE - Real*4 common point j-coordinates for
          +
          36C> transformed destination grid
          +
          37C> @param[in] DSCALE - Real*4 scale-change (dilation) expressed as
          +
          38C> a ratio of the transformed field to the original field
          +
          39C> dscale = grdlenkm(destination) / grdlenkm(source)
          +
          40C> @param[in] ANGLE - Real*4 degree measure of the angle required to
          +
          41C> rotate the j-row of the original grid into
          +
          42C> coincidence with the new grid. (+ counter-
          +
          43C> clockwise, - clockwise)
          +
          44C> angle = vertlonw(source) - vertlonw(destination)
          +
          45C>
          +
          46C> @param[in] LINEAR - Logical*4 interpolation-method selection switch:
          +
          47C> - .TRUE. Bi-linear interpolation.
          +
          48C> - .FALSE. Bi-quadratic interpolation.
          +
          49C> @param[in] LDEFQQ - Logical*4 default-value switch:
          +
          50C> if .true. then
          +
          51C> use default-value for destination point
          +
          52C> out-of-bounds of given grid;
          +
          53C> else
          +
          54C> extrapolate coarsely from nearby bndry point
          +
          55C> @param[in] DEFALT - Real*4 the default-value to use if ldefqq = .true.
          +
          56C>
          +
          57C> @remark List caveats, other helpful hints or information
          +
          58C> in general 'FLDA' and 'FLDB' cannot be equivalenced
          +
          59C> although there are situations in which it would be safe to do
          +
          60C> so. Care should be taken that all of the new grid points lie
          +
          61C> within the original grid, no error checks are made.
          +
          62C>
          +
          63C> @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)
          +
          66C
          +
          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
          +
          76C
          +
          77 LOGICAL LINEAR
          +
          78 LOGICAL LDEFQQ
          +
          79C
          +
          80 SAVE
          +
          81C
          +
          82 DATA tiny / 0.001 /
          +
          83C
          +
          84C ... WHERE TINY IS IN UNITS OF 1.0 = 1 GRID INTERVAL
          +
          85C
          +
          86C . . . . . S T A R T . . . . . . . . . . . . . . . . . . .
          +
          87C
          +
          88 theta = angle * (3.14159/180.)
          +
          89 sint = sin(theta)
          +
          90 cost = cos(theta)
          +
          91C
          +
          92C ... WE WILL SCAN ALONG THE J-ROW OF THE DESTINATION GRID ...
          +
          93 DO 288 jn = 1,jb
          +
          94 brelj = float(jn) - bjpole
          +
          95C
          +
          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
          +
          102C
          +
          103C ... THE PT(STI,STJ) IS THE LOCATION OF THE FLDB(IN,JN)
          +
          104C ... IN FLDA,S COORDINATE SYSTEM
          +
          105C ... IS THIS POINT LOCATED OUTSIDE FLDA?
          +
          106C ... ON THE BOUNDARY LINE OF FLDA?
          +
          107C ... ON THE FIRST INTERIOR GRIDPOINT OF FLDA?
          +
          108C ... GOOD INSIDER, AT LEAST 2 INTERIOR GRIDS INSIDE?
          +
          109 ioff = 0
          +
          110 joff = 0
          +
          111 kquad = 0
          +
          112C
          +
          113 IF (im .LT. 1) THEN
          +
          114C ... LOCATED OUTSIDE OF FLDA, OFF LEFT SIDE ...
          +
          115 ii = 1
          +
          116 ioff = 1
          +
          117 ELSE IF (im .EQ. 1) THEN
          +
          118C ... LOCATED ON BOUNDARY OF FLDA, ON LEFT EDGE ...
          +
          119 kquad = 5
          +
          120 ELSE
          +
          121C ...( IM .GT. 1) ... LOCATED TO RIGHT OF LEFT-EDGE ...
          +
          122 IF ((ia-im) .LT. 1) THEN
          +
          123C ... LOCATED OUTSIDE OF OR EXACTLY ON RIGHT EDGE OF FLDA ..
          +
          124 ii = ia
          +
          125 ioff = 1
          +
          126 ELSE IF ((ia-im) .EQ. 1) THEN
          +
          127C ... LOCATED ON FIRST INTERIOR PT WITHIN RIGHT EDGE OF FLDA
          +
          128 kquad = 5
          +
          129 ELSE
          +
          130C ... (IA-IM) IS .GT. 1) ...GOOD INTERIOR, AT LEAST 2 INSIDE
          +
          131 ENDIF
          +
          132 ENDIF
          +
          133C
          +
          134C . . . . . . . . . . . . . . .
          +
          135C
          +
          136 IF (jm .LT. 1) THEN
          +
          137C ... LOCATED OUTSIDE OF FLDA, OFF BOTTOM ...
          +
          138 jj = 1
          +
          139 joff = 1
          +
          140 ELSE IF (jm .EQ. 1) THEN
          +
          141C ... LOCATED ON BOUNDARY OF FLDA, ON BOTTOM EDGE ...
          +
          142 kquad = 5
          +
          143 ELSE
          +
          144C ...( JM .GT. 1) ... LOCATED ABOVE BOTTOM EDGE ...
          +
          145 IF ((ja-jm) .LT. 1) THEN
          +
          146C ... LOCATED OUTSIDE OF OR EXACTLY ON TOP EDGE OF FLDA ..
          +
          147 jj = ja
          +
          148 joff = 1
          +
          149 ELSE IF ((ja-jm) .EQ. 1) THEN
          +
          150C ... LOCATED ON FIRST INTERIOR PT WITHIN TOP EDGE OF FLDA
          +
          151 kquad = 5
          +
          152 ELSE
          +
          153C ... ((JA-JM) .GT. 1) ...GOOD INTERIOR, AT LEAST 2 INSIDE
          +
          154 ENDIF
          +
          155 ENDIF
          +
          156C
          +
          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
          +
          162C
          +
          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
          +
          176C
          +
          177C . . . . . . . . . . . . .
          +
          178C
          +
          179 244 CONTINUE
          +
          180 i = sti
          +
          181 j = stj
          +
          182 xdeli = sti - float(i)
          +
          183 xdelj = stj - float(j)
          +
          184C
          +
          185 IF ((abs(xdeli) .LT. tiny) .AND. (abs(xdelj) .LT. tiny)) THEN
          +
          186C ... THIS POINT IS RIGHT AT A GRIDPOINT. NO INTERP NECESSARY
          +
          187 fldb(in,jn) = flda(i,j)
          +
          188 GO TO 277
          +
          189 ENDIF
          +
          190C
          +
          191 IF ((kquad .EQ. 5) .OR. (linear)) THEN
          +
          192C ... 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
          +
          199C
          +
          200 ELSE
          +
          201C ... 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
          +
          210C
          +
          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
          +
          215C
          +
          216 266 CONTINUE
          +
          217 fldb(in,jn) = di
          +
          218 277 CONTINUE
          +
          219 288 CONTINUE
          +
          220C
          +
          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/w3ft08_8f.html b/w3ft08_8f.html index 208fcb8f..3c50daef 100644 --- a/w3ft08_8f.html +++ b/w3ft08_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft08.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft08.f File Reference
          +
          w3ft08.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft08 (fln, gn, pln, eps, fl, work, trigs)
           Computes 2.5 x 2.5 n.
           

          Detailed Description

          Computes 2.5 x 2.5 n.

          @@ -107,8 +113,8 @@

          Definition in file w3ft08.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft08()

          + +

          ◆ w3ft08()

          @@ -117,43 +123,43 @@

          subroutine w3ft08 ( complex, dimension( 31 , 31 )  - FLN, + fln, real, dimension(145,37)  - GN, + gn, real, dimension( 32 , 31 )  - PLN, + pln, real, dimension(992)  - EPS, + eps, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS  + trigs  @@ -165,7 +171,7 @@

          +

          Program History Log:

          @@ -189,13 +195,13 @@

          - - + +
          [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]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.
          +
          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
          @@ -209,7 +215,7 @@

          diff --git a/w3ft08_8f.js b/w3ft08_8f.js index 6524186b..2f7830df 100644 --- a/w3ft08_8f.js +++ b/w3ft08_8f.js @@ -1,4 +1,4 @@ var w3ft08_8f = [ - [ "w3ft08", "w3ft08_8f.html#ae48a19283d690c37fe8c3dc355e8e609", null ] + [ "w3ft08", "w3ft08_8f.html#ad0708ff0b06b672a0f6cff08ca6edba8", null ] ]; \ No newline at end of file diff --git a/w3ft08_8f_source.html b/w3ft08_8f_source.html index cdac3e00..d9860241 100644 --- a/w3ft08_8f_source.html +++ b/w3ft08_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft08.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,105 +81,114 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft08.f
          +
          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
          -
          w3ft08
          subroutine w3ft08(FLN, GN, PLN, EPS, FL, WORK, TRIGS)
          Computes 2.5 x 2.5 n.
          Definition: w3ft08.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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Computes 2.5 x 2.5 n. hemi. grid-scaler.
          +
          3C> @author Joe Sela @date 1988-06-20
          +
          4
          +
          5C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
          +
          6C> from spectral coefficients in a rhomboidal 30 resolution
          +
          7C> representing a scaler field.
          +
          8C>
          +
          9C> ### Program History Log:
          +
          10C> Date | Programmer | Comment
          +
          11C> -----|------------|--------
          +
          12C> 1988-06-20 | Joe Sela | Initial.
          +
          13C> 1988-06-20 | Ralph Jones | Change to microsoft fortran 4.10.
          +
          14C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
          +
          15C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
          +
          16C> 1993-03-29 | Ralph Jones | Add save statement.
          +
          17C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
          +
          18C>
          +
          19C> @param[in] FLN 961 complex coeff.
          +
          20C> @param[in] PLN 992 real space for legendre polynomials.
          +
          21C> @param[in] EPS 992 real space for
          +
          22C> coeffs. used in computing pln.
          +
          23C> @param[in] FL 31 complex space for fourier coeff.
          +
          24C> @param[in] WORK 144 real work space for subr. w3ft12()
          +
          25C> @param[in] TRIGS 216 precomputed trig funcs. used
          +
          26C> in w3ft12(), computed by w3fa13()
          +
          27C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or
          +
          28C> 1d hex o.n. 84
          +
          29C>
          +
          30C> @note This subroutine was optimized to run in a small amount of
          +
          31C> memory, it is not optimized for speed, 70 percent of the time is
          +
          32C> used by subroutine w3fa12 computing the legendre polynomials. since
          +
          33C> the legendre polynomials are constant they need to be computed
          +
          34C> only once in a program. By moving w3fa12() to the main program and
          +
          35C> computing pln as a (32,31,37) array and changing this subroutine
          +
          36C> to use pln as a three dimension array you can cut the running time
          +
          37C> 70 percent. w3ft38() has these improvements.
          +
          38C>
          +
          39C> @author Joe Sela @date 1988-06-20
          +
          +
          40 SUBROUTINE w3ft08(FLN,GN,PLN,EPS,FL,WORK,TRIGS)
          +
          41C
          +
          42 COMPLEX FL( 31 )
          +
          43 COMPLEX FLN( 31 , 31 )
          +
          44C
          +
          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)
          +
          51C
          +
          52 SAVE
          +
          53C
          +
          54 DATA pi /3.14159265/
          +
          55C
          +
          56 drad = 2.5 * pi / 180.0
          +
          57C
          +
          58 DO 400 lat = 1,37
          +
          59 latn = 38 - lat
          +
          60 colra = (lat - 1) * drad
          +
          61 CALL w3fa12(pln,colra, 30 ,eps)
          +
          62C
          +
          63 DO 100 l = 1, 31
          +
          64 fl(l) = (0.,0.)
          +
          65 100 CONTINUE
          +
          66C
          +
          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
          +
          72C
          +
          73 300 CONTINUE
          +
          74C
          +
          75 CALL w3ft12(fl,work,gn(1,latn),trigs)
          +
          76C
          +
          77 400 CONTINUE
          +
          78C
          +
          79 RETURN
          +
          +
          80 END
          +
          w3fa12
          subroutine w3fa12(pln, colrad, jcap, eps)
          Subroutine computes legendre polynomials at a given latitude.
          Definition w3fa12.f:21
          +
          w3ft08
          subroutine w3ft08(fln, gn, pln, eps, fl, work, trigs)
          Computes 2.5 x 2.5 n.
          Definition w3ft08.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/w3ft09_8f.html b/w3ft09_8f.html index 1859e4e3..c3343f2f 100644 --- a/w3ft09_8f.html +++ b/w3ft09_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft09.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft09.f File Reference
          +
          w3ft09.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft09 (vln, gn, pln, eps, fl, work, trigs, rcos)
           Computes 2.5 x 2.5 n.
           

          Detailed Description

          Computes 2.5x2.5 n.

          @@ -107,8 +113,8 @@

          Definition in file w3ft09.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft09()

          + +

          ◆ w3ft09()

          @@ -117,49 +123,49 @@

          subroutine w3ft09 ( complex, dimension( 32 , 31 )  - VLN, + vln, real, dimension(145,37)  - GN, + gn, real, dimension( 32 , 31 )  - PLN, + pln, real, dimension(992)  - EPS, + eps, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS, + trigs, real, dimension(37)  - RCOS  + rcos  @@ -171,7 +177,7 @@

          +

          Program History Log:

          @@ -198,13 +204,13 @@

          - - + +
          [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.
          [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.
          +
          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
          @@ -218,7 +224,7 @@

          diff --git a/w3ft09_8f.js b/w3ft09_8f.js index 447c7a21..4b9c6a11 100644 --- a/w3ft09_8f.js +++ b/w3ft09_8f.js @@ -1,4 +1,4 @@ var w3ft09_8f = [ - [ "w3ft09", "w3ft09_8f.html#ac50128472db184365bc4c2dfb1ea1a47", null ] + [ "w3ft09", "w3ft09_8f.html#a43204d3a7e4ec58530223d8561565f49", null ] ]; \ No newline at end of file diff --git a/w3ft09_8f_source.html b/w3ft09_8f_source.html index 4d6dbf11..3691b0ad 100644 --- a/w3ft09_8f_source.html +++ b/w3ft09_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft09.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,114 +81,123 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft09.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Computes 2.5x2.5 n. hemi. grid-vector
          +
          3C> @author Joe Sela @date 1980-10-21
          +
          4
          +
          5C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
          +
          6C> from spectral coefficients in a rhomboidal 30 resolution
          +
          7C> representing a vector field.
          +
          8C>
          +
          9C> ### Program History Log:
          +
          10C> Date | Programmer | Comment
          +
          11C> -----|------------|--------
          +
          12C> 1980-10-21 | JOE SELA | Initial.
          +
          13C> 1981-06-15 | Ralph Jones | Add doc block, clean up source.
          +
          14C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
          +
          15C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
          +
          16C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
          +
          17C> 1993-03-29 | Ralph Jones | Add save statement.
          +
          18C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
          +
          19C>
          +
          20C> @param[in] VLN 992 complex coeff.
          +
          21C> @param[in] PLN 992 space for legendre polynomials.
          +
          22C> @param[in] EPS 992 real space for coeffs. used in computing pln.
          +
          23C> @param[in] FL 31 complex space for fourier coeff.
          +
          24C> @param[in] WORK 144 work space for subr. w3ft12
          +
          25C> @param[in] TRIGS 216 precomputed trig funcs. Used in w3ft12(), computed by w3fa13()
          +
          26C> @param[in] RCOS 37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be
          +
          27C> computed before first call to w3ft11() using sr w3fa13.
          +
          28C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d o.n. 84
          +
          29C>
          +
          30C> @note This subroutine was optimized to run in a small amount of
          +
          31C> memory, it is not optimized for speed, 70 percent of the time is
          +
          32C> used by subroutine w3fa12() computing the legendre polynomials. since
          +
          33C> the legendre polynomials are constant they need to be computed
          +
          34C> only once in a program. By moving w3fa12() to the main program and
          +
          35C> computing pln as a (32,31,37) array and changing this subroutine
          +
          36C> to use pln as a three dimension array you can cut the running time
          +
          37C> 70 percent.
          +
          38C>
          +
          39C> @author Joe Sela @date 1980-10-21
          +
          +
          40 SUBROUTINE w3ft09(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS)
          +
          41C
          +
          42 COMPLEX FL( 31 )
          +
          43 COMPLEX VLN( 32 , 31 )
          +
          44C
          +
          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)
          +
          52C
          +
          53 SAVE
          +
          54C
          +
          55 DATA pi /3.14159265/
          +
          56C
          +
          57 drad = 2.5 * pi / 180.0
          +
          58C
          +
          59 DO 400 lat = 2,37
          +
          60 latn = 38 - lat
          +
          61 colra = (lat - 1) * drad
          +
          62 CALL w3fa12(pln,colra, 30 ,eps)
          +
          63C
          +
          64 DO 100 l = 1, 31
          +
          65 fl(l) = (0.,0.)
          +
          66 100 CONTINUE
          +
          67C
          +
          68 DO 300 l = 1, 31
          +
          69C
          +
          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
          +
          74C
          +
          75 fl(l)=cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
          +
          76 300 CONTINUE
          +
          77C
          +
          78 CALL w3ft12(fl,work,gn(1,latn),trigs)
          +
          79C
          +
          80 400 CONTINUE
          +
          81C
          +
          82C*** POLE ROW=CLOSEST LATITUDE ROW
          +
          83C
          +
          84 DO 500 i = 1,145
          +
          85 gn(i,37) = gn(i,36)
          +
          86 500 CONTINUE
          +
          87C
          +
          88 RETURN
          +
          +
          89 END
          +
          w3fa12
          subroutine w3fa12(pln, colrad, jcap, eps)
          Subroutine computes legendre polynomials at a given latitude.
          Definition w3fa12.f:21
          +
          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/w3ft10_8f.html b/w3ft10_8f.html index 6995b922..3fdf3e2c 100644 --- a/w3ft10_8f.html +++ b/w3ft10_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft10.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft10.f File Reference
          +
          w3ft10.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft10 (fln, gn, pln, eps, fl, work, trigs)
           Computes 2.5 x 2.5 s.
           

          Detailed Description

          Computes 2.5 x 2.5 s.

          @@ -107,8 +113,8 @@

          Definition in file w3ft10.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft10()

          + +

          ◆ w3ft10()

          @@ -117,43 +123,43 @@

          subroutine w3ft10 ( complex, dimension( 31 , 31 )  - FLN, + fln, real, dimension(145,37)  - GN, + gn, real, dimension( 32 , 31 )  - PLN, + pln, real, dimension( 992)  - EPS, + eps, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS  + trigs  @@ -165,7 +171,7 @@

          +

          Program History Log:

          @@ -191,13 +197,13 @@

          - - + +
          [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]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.
          +
          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
          @@ -211,7 +217,7 @@

          diff --git a/w3ft10_8f.js b/w3ft10_8f.js index 0a6f13ab..94ebe44f 100644 --- a/w3ft10_8f.js +++ b/w3ft10_8f.js @@ -1,4 +1,4 @@ var w3ft10_8f = [ - [ "w3ft10", "w3ft10_8f.html#a17871a93f588bd482470dd30d88f6b8c", null ] + [ "w3ft10", "w3ft10_8f.html#a2d7a4e0d67089df728f1011ed937e6b6", null ] ]; \ No newline at end of file diff --git a/w3ft10_8f_source.html b/w3ft10_8f_source.html index 7e28f7f5..8d2075ee 100644 --- a/w3ft10_8f_source.html +++ b/w3ft10_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft10.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,107 +81,116 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft10.f
          +
          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
          -
          w3ft10
          subroutine w3ft10(FLN, GN, PLN, EPS, FL, WORK, TRIGS)
          Computes 2.5 x 2.5 s.
          Definition: w3ft10.f:39
          -
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Computes 2.5 x 2.5 s. hemi. grid-scaler.
          +
          3C> @author Joe Sela @date 1980-10-21
          +
          4
          +
          5C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
          +
          6C> from spectral coefficients in a rhomboidal 30 resolution
          +
          7C> representing a scaler field.
          +
          8C>
          +
          9C> ### Program History Log:
          +
          10C> Date | Programmer | Comment
          +
          11C> -----|------------|--------
          +
          12C> 1980-10-21 | Joe Sela | Initial.
          +
          13C> 1984-06-28 | Ralph Jones | Change to ibm vs fortran.
          +
          14C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
          +
          15C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
          +
          16C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
          +
          17C> 1993-03-29 | Ralph Jones | Add save statement.
          +
          18C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
          +
          19C>
          +
          20C> @param[in] FLN 961 complex coeff.
          +
          21C> @param[in] PLN 992 real space for legendre polynomials.
          +
          22C> @param[in] EPS 992 real space for coeffs. used in computing pln.
          +
          23C> @param[in] FL 31 complex space for fourier coeff.
          +
          24C> @param[in] WORK 144 real work space for subr. w3ft12()
          +
          25C> @param[in] TRIGS 216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
          +
          26C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e o.n. 84
          +
          27C>
          +
          28C> @note This subroutine was optimized to run in a small amount of
          +
          29C> memory, it is not optimized for speed, 70 percent of the time is
          +
          30C> used by subroutine w3fa12() computing the legendre polynomials. Since
          +
          31C> the legendre polynomials are constant they need to be computed
          +
          32C> only once in a program. By moving w3fa12() to the main program and
          +
          33C> computing pln as a (32,31,37) array and changing this subroutine
          +
          34C> to use pln as a three dimension array you can cut the running time
          +
          35C> 70 percent.
          +
          36C>
          +
          37C> @author Joe Sela @date 1980-10-21
          +
          +
          38 SUBROUTINE w3ft10(FLN,GN,PLN,EPS,FL,WORK,TRIGS)
          +
          39C
          +
          40 COMPLEX FL( 31 )
          +
          41 COMPLEX FLN( 31 , 31 )
          +
          42C
          +
          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)
          +
          49C
          +
          50 SAVE
          +
          51C
          +
          52 DATA pi /3.14159265/
          +
          53C
          +
          54 drad = 2.5 * pi / 180.0
          +
          55C
          +
          56 DO 400 lat = 1,37
          +
          57 colra = (lat-1) * drad
          +
          58 CALL w3fa12(pln,colra, 30 ,eps)
          +
          59C
          +
          60 DO 100 l = 1, 31
          +
          61 fl(l) = (0.,0.)
          +
          62 100 CONTINUE
          +
          63C
          +
          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)) )
          +
          68C
          +
          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
          +
          75C
          +
          76 300 CONTINUE
          +
          77C
          +
          78 CALL w3ft12(fl,work,gn(1,lat ),trigs)
          +
          79 400 CONTINUE
          +
          80C
          +
          81 RETURN
          +
          +
          82 END
          +
          w3fa12
          subroutine w3fa12(pln, colrad, jcap, eps)
          Subroutine computes legendre polynomials at a given latitude.
          Definition w3fa12.f:21
          +
          w3ft10
          subroutine w3ft10(fln, gn, pln, eps, fl, work, trigs)
          Computes 2.5 x 2.5 s.
          Definition w3ft10.f:39
          +
          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/w3ft11_8f.html b/w3ft11_8f.html index ed0a23e9..57043eee 100644 --- a/w3ft11_8f.html +++ b/w3ft11_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft11.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft11.f File Reference
          +
          w3ft11.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft11 (vln, gn, pln, eps, fl, work, trigs, rcos)
           Computes 2.5 x 2.5 s.
           

          Detailed Description

          Computes 2.5x2.5 s.

          @@ -107,8 +113,8 @@

          Definition in file w3ft11.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft11()

          + +

          ◆ w3ft11()

          @@ -117,49 +123,49 @@

          subroutine w3ft11 ( complex, dimension( 32 , 31 )  - VLN, + vln, real, dimension(145,37)  - GN, + gn, real, dimension( 32 , 31 )  - PLN, + pln, real, dimension( 992 )  - EPS, + eps, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS, + trigs, real, dimension(37)  - RCOS  + rcos  @@ -171,7 +177,7 @@

          +

          Program History Log:

          @@ -197,14 +203,14 @@

          - - - + + +
          [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()
          [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.
          +
          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
          @@ -218,7 +224,7 @@

          diff --git a/w3ft11_8f.js b/w3ft11_8f.js index 5fe18e20..d85d0070 100644 --- a/w3ft11_8f.js +++ b/w3ft11_8f.js @@ -1,4 +1,4 @@ var w3ft11_8f = [ - [ "w3ft11", "w3ft11_8f.html#af60fd501521a85612c264e601718bb68", null ] + [ "w3ft11", "w3ft11_8f.html#a011258b47ddeb5935f8e1ca9dca6bc28", null ] ]; \ No newline at end of file diff --git a/w3ft11_8f_source.html b/w3ft11_8f_source.html index d140ded0..1c6878a0 100644 --- a/w3ft11_8f_source.html +++ b/w3ft11_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft11.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,115 +81,124 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft11.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Computes 2.5x2.5 s. hemi. grid vector.
          +
          3C> @author Joe Sela @date 1980-11-20
          +
          4
          +
          5C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
          +
          6C> from spectral coefficients in a rhomboidal 30 resolution
          +
          7C> representing a vector field.
          +
          8C>
          +
          9C> ### Program History Log:
          +
          10C> Date | Programmer | Comment
          +
          11C> -----|------------|--------
          +
          12C> 1980-11-20 | Joe Sela | Initial.
          +
          13C> 1984-06-15 | Ralph Jones | Change to ibm vs fortran.
          +
          14C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
          +
          15C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
          +
          16C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
          +
          17C> 1993-03-29 | Ralph Jones | Add save statement.
          +
          18C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
          +
          19C>
          +
          20C> @param[in] VLN 992 complex coeff.
          +
          21C> @param[in] PLN 992 real space for legendre polynomials.
          +
          22C> @param[in] EPS 992 real space for coeffs. used in computing pln.
          +
          23C> @param[in] FL 31 complex space for fourier coeff.
          +
          24C> @param[in] WORK 144 real work space for subr. w3ft12()
          +
          25C> @param[in] TRIGS 216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
          +
          26C> @param[in] RCOS 37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be
          +
          27C> computed before first call to w3ft11 using subr. w3fa13()
          +
          28C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e hex o.n. 84
          +
          29C>
          +
          30C> @note This subroutine was optimized to run in a small amount of
          +
          31C> memory, it is not optimized for speed, 70 percent of the time is
          +
          32C> used by subroutine w3fa12() computing the legendre polynomials. Since
          +
          33C> the legendre polynomials are constant they need to be computed
          +
          34C> only once in a program. by moving w3fa12() to the main program and
          +
          35C> computing pln as a (32,31,37) array and changing this subroutine
          +
          36C> to use pln as a three dimension array you can cut the running time
          +
          37C> 70 percent.
          +
          38C>
          +
          39C> @author Joe Sela @date 1980-11-20
          +
          +
          40 SUBROUTINE w3ft11(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS)
          +
          41C
          +
          42 COMPLEX FL( 31 )
          +
          43 COMPLEX VLN( 32 , 31 )
          +
          44C
          +
          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)
          +
          52C
          +
          53 SAVE
          +
          54C
          +
          55 DATA pi /3.14159265/
          +
          56C
          +
          57 drad = 2.5 * pi / 180.0
          +
          58C
          +
          59 DO 400 lat = 2,37
          +
          60 colra = (lat-1) * drad
          +
          61 CALL w3fa12(pln,colra, 30 ,eps)
          +
          62C
          +
          63 DO 100 l = 1, 31
          +
          64 fl(l) = (0.,0.)
          +
          65 100 CONTINUE
          +
          66C
          +
          67 DO 300 l = 1, 31
          +
          68C
          +
          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
          +
          75C
          +
          76 fl(l) = cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
          +
          77C
          +
          78 300 CONTINUE
          +
          79C
          +
          80 CALL w3ft12(fl,work,gn(1,lat ),trigs)
          +
          81C
          +
          82 400 CONTINUE
          +
          83C
          +
          84C*** POLE ROW = CLOSEST LATITUDE ROW
          +
          85C
          +
          86 DO 500 i = 1,145
          +
          87 gn(i,1) = gn(i,2)
          +
          88 500 CONTINUE
          +
          89 RETURN
          +
          +
          90 END
          +
          w3fa12
          subroutine w3fa12(pln, colrad, jcap, eps)
          Subroutine computes legendre polynomials at a given latitude.
          Definition w3fa12.f:21
          +
          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/w3ft12_8f.html b/w3ft12_8f.html index 2d3783c3..9567ca8a 100644 --- a/w3ft12_8f.html +++ b/w3ft12_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft12.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft12.f File Reference
          +
          w3ft12.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft12 (coef, work, grid, trigs)
           Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
           

          Detailed Description

          Fast fourier for 2.5 degree grid.

          @@ -107,8 +113,8 @@

          Definition in file w3ft12.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft12()

          + +

          ◆ w3ft12()

          @@ -117,25 +123,25 @@

          subroutine w3ft12 ( real, dimension( 62 )  - COEF, + coef, real, dimension(144)  - WORK, + work, real, dimension(145)  - GRID, + grid, real, dimension(216)  - TRIGS  + trigs  @@ -147,7 +153,7 @@

          +

          Program History Log:

          @@ -162,7 +168,7 @@

          Parameters

          - +
          [in]COEF31 complex fourier coefficients.
          [in]TRIGS216 trig functions assumed precomputed by w3fa13() before first call to w3ft12().
          [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)
          @@ -181,7 +187,7 @@

          diff --git a/w3ft12_8f.js b/w3ft12_8f.js index 128b9848..878e796b 100644 --- a/w3ft12_8f.js +++ b/w3ft12_8f.js @@ -1,4 +1,4 @@ var w3ft12_8f = [ - [ "w3ft12", "w3ft12_8f.html#afb994008cf891b44e3fe4a25c0b46157", null ] + [ "w3ft12", "w3ft12_8f.html#a34a66be43ef2429781f8346af0c4fbb1", null ] ]; \ No newline at end of file diff --git a/w3ft12_8f_source.html b/w3ft12_8f_source.html index 9dc522fd..5d940a11 100644 --- a/w3ft12_8f_source.html +++ b/w3ft12_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft12.f Source File @@ -23,10 +23,9 @@
          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ + +

          @@ -76,249 +81,257 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft12.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Fast fourier for 2.5 degree grid.
          +
          3C> @author Joe Sela @date 1980-11-21
          +
          4
          +
          5C> Fast fourier to compute 145 grid values at desired
          +
          6C> latitude from 31 complex fourier coefficients. This subroutine
          +
          7C> is special purpose for converting coefficients to a 2.5 degree
          +
          8C> lat,lon grid.
          +
          9C>
          +
          10C> ### Program History Log:
          +
          11C> Date | Programmer | Comment
          +
          12C> -----|------------|--------
          +
          13C> 1980-11-21 | Joe Sela | Initial.
          +
          14C> 1984-06-21 | Ralph Jones | Change to ibm vs fortran.
          +
          15C> 1993-04-12 | Ralph Jones | Change to cray cft77 fortran.
          +
          16C>
          +
          17C> @param[in] COEF 31 complex fourier coefficients.
          +
          18C> @param[in] TRIGS 216 trig functions assumed precomputed by w3fa13() before
          +
          19C> first call to w3ft12().
          +
          20C> @param[in] WORK 144 real work space
          +
          21C> @param[out] GRID 145 grid values, grid(1)=grid(145)
          +
          22C>
          +
          23C> @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)
          +
          29C
          +
          30 SAVE
          +
          31C
          +
          32 DATA sin60/0.866025403784437/
          +
          33C
          +
          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
          +
          47100 CONTINUE
          +
          48 DO 110 i= 63 , 84
          +
          49 grid(i) = 0.0
          +
          50110 CONTINUE
          +
          51C
          +
          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
          +
          108300 CONTINUE
          +
          109C
          +
          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
          +
          121440 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
          +
          135460 CONTINUE
          +
          136500 CONTINUE
          +
          137C
          +
          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
          +
          164660 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
          +
          195680 CONTINUE
          +
          196700 CONTINUE
          +
          197C
          +
          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
          +
          221900 CONTINUE
          +
          222 grid(1) = grid(145)
          +
          223C
          +
          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/w3ft16_8f.html b/w3ft16_8f.html index 850c2ab6..ea1e7094 100644 --- a/w3ft16_8f.html +++ b/w3ft16_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft16.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft16.f File Reference
          +
          w3ft16.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft16 (alola, bthin, interp)
           Convert a northern hemisphere 1.0 degree lat.,lon.
           

          Detailed Description

          Convert (95,91) grid to (3447) grid.

          @@ -107,8 +113,8 @@

          Definition in file w3ft16.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft16()

          + +

          ◆ w3ft16()

          @@ -117,19 +123,19 @@

          subroutine w3ft16 ( real, dimension(95,91)  - ALOLA, + alola, real, dimension(npts)  - BTHIN, + bthin,   - INTERP  + interp  @@ -141,7 +147,7 @@

          +

          Program History Log:

          @@ -174,7 +180,7 @@

          diff --git a/w3ft16_8f.js b/w3ft16_8f.js index 5ed303b6..52d5b866 100644 --- a/w3ft16_8f.js +++ b/w3ft16_8f.js @@ -1,4 +1,4 @@ var w3ft16_8f = [ - [ "w3ft16", "w3ft16_8f.html#a3eb1bcdeb5163086f4e319d036fa9b8f", null ] + [ "w3ft16", "w3ft16_8f.html#a4cfdf338d54decb5ebc703952f1b8258", null ] ]; \ No newline at end of file diff --git a/w3ft16_8f_source.html b/w3ft16_8f_source.html index 2f561a04..9f1ef66f 100644 --- a/w3ft16_8f_source.html +++ b/w3ft16_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft16.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,225 +81,233 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft16.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (95,91) grid to (3447) grid
          +
          3C> @author Ralph Jones @date 1994-05-03
          +
          4
          +
          5C> Convert a northern hemisphere 1.0 degree lat.,lon. 95 by
          +
          6C> 91 grid to a wafs 1.25 degree thinned 3447 point grid.
          +
          7C>
          +
          8C> ### Program History Log:
          +
          9C> Date | Programmer | Comment
          +
          10C> -----|------------|--------
          +
          11C> 1994-05-03 | Ralph Jones | Initial.
          +
          12C>
          +
          13C> @param[in] ALOLA 95 * 91 grid 1.0 deg. lat,lon grid northern hemisphere 8645 point grid.
          +
          14C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
          +
          15C> @param[out] BTHIN 3447 point thinned grid of n. hemispere 3447 grid is for grib grids 37-40.
          +
          16C>
          +
          17C> @note
          +
          18C> - W1 and w2 are used to store sets of constants which are
          +
          19C> reusable for repeated calls to the subroutine. 10 other arrays
          +
          20C> are saved and reused on the next call.
          +
          21C>
          +
          22C> @author Ralph Jones @date 1994-05-03
          +
          +
          23 SUBROUTINE w3ft16(ALOLA,BTHIN,INTERP)
          +
          24C
          +
          25 parameter(npts=3447)
          +
          26C
          +
          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)
          +
          32C
          +
          33 INTEGER NPT(73)
          +
          34 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
          +
          35 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
          +
          36C
          +
          37 LOGICAL LIN
          +
          38C
          +
          39 SAVE
          +
          40C
          +
          41 DATA intrpo/99/
          +
          42 DATA iswt /0/
          +
          43C
          +
          44C GRID POINT SEPARATION
          +
          45C
          +
          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/
          +
          59C
          +
          60C NUMBER OF POINTS ALONG LAT CIRCLE FOR ONE OCTANT
          +
          61C
          +
          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/
          +
          75C
          +
          76 lin = .false.
          +
          77 IF (interp.EQ.1) lin = .true.
          +
          78C
          +
          79 IF (iswt.EQ.1) GO TO 900
          +
          80C
          +
          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
          +
          92C
          +
          93 iswt = 1
          +
          94 intrpo = interp
          +
          95 GO TO 1000
          +
          96C
          +
          97C AFTER THE 1ST CALL TO W3FT16 TEST INTERP, IF IT HAS
          +
          98C CHANGED RECOMPUTE SOME CONSTANTS
          +
          99C
          +
          100 900 CONTINUE
          +
          101 IF (interp.EQ.intrpo) GO TO 2100
          +
          102 intrpo = interp
          +
          103C
          +
          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
          +
          114C
          +
          115 IF (lin) GO TO 1400
          +
          116C
          +
          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
          +
          125C
          +
          126 1400 CONTINUE
          +
          127C
          +
          128 IF (lin) GO TO 1700
          +
          129C
          +
          130 DO 1500 kk = 1,npts
          +
          131 IF (jv(kk).LT.2.OR.jv(kk).GE.90) xj2tm(kk) = 0.0
          +
          132 1500 CONTINUE
          +
          133C
          +
          134C LINEAR INTERPOLATION
          +
          135C
          +
          136 1700 CONTINUE
          +
          137 DO 1900 kk = 1,npts
          +
          138 IF (jy(kk,3).GT.91) jy(kk,3) = 91
          +
          139 1900 CONTINUE
          +
          140C
          +
          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
          +
          147C
          +
          148 2100 CONTINUE
          +
          149 IF (lin) THEN
          +
          150C
          +
          151C LINEAR INTERPOLATION
          +
          152C
          +
          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
          +
          159C
          +
          160 DO 2300 kk = 1,npts
          +
          161 bthin(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
          +
          162 & * xdelj(kk)
          +
          163 2300 CONTINUE
          +
          164C
          +
          165 ELSE
          +
          166C
          +
          167C QUADRATIC INTERPOLATION
          +
          168C
          +
          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
          +
          191C
          +
          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
          +
          197C
          +
          198 ENDIF
          +
          199C
          +
          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/w3ft17_8f.html b/w3ft17_8f.html index 198bb6eb..6aa1e912 100644 --- a/w3ft17_8f.html +++ b/w3ft17_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft17.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft17.f File Reference
          +
          w3ft17.f File Reference
          @@ -94,11 +100,11 @@

          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...
           
          subroutine w3ft17 (alola, bthin, interp)
           Convert a southern hemisphere 1.0 degree lat.,lon.
           

          Detailed Description

          Convert (95,91) grid to (3447) grid.

          @@ -107,8 +113,8 @@

          Definition in file w3ft17.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft17()

          + +

          ◆ w3ft17()

          @@ -117,19 +123,19 @@

          subroutine w3ft17 ( real, dimension(95,91)  - ALOLA, + alola, real, dimension(npts)  - BTHIN, + bthin,   - INTERP  + interp  @@ -141,7 +147,7 @@

          +

          Program History Log:

          @@ -174,7 +180,7 @@

          diff --git a/w3ft17_8f.js b/w3ft17_8f.js index cb2c7641..4e58c96a 100644 --- a/w3ft17_8f.js +++ b/w3ft17_8f.js @@ -1,4 +1,4 @@ var w3ft17_8f = [ - [ "w3ft17", "w3ft17_8f.html#ac26d2dfc790515275a019ab4588f0751", null ] + [ "w3ft17", "w3ft17_8f.html#ad1ef28f2b547a1d73110bfea51bd92c3", null ] ]; \ No newline at end of file diff --git a/w3ft17_8f_source.html b/w3ft17_8f_source.html index 5d93d50d..d79d23b2 100644 --- a/w3ft17_8f_source.html +++ b/w3ft17_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft17.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,226 +81,234 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft17.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (95,91) grid to (3447) grid
          +
          3C> @author Ralph Jones @date 1994-05-03
          +
          4
          +
          5C> Convert a southern hemisphere 1.0 degree lat.,lon. 95 by
          +
          6C> 91 grid to a wafs 1.25 degree thinned 3447 point grid.
          +
          7C>
          +
          8C> ### Program History Log:
          +
          9C> Date | Programmer | Comment
          +
          10C> -----|------------|--------
          +
          11C> 1994-05-03 | Ralph Jones | Initial.
          +
          12C>
          +
          13C> @param[in] ALOLA 95 * 91 grid 1.0 deg. lat,lon grid southern hemisphere 8645 point grid.
          +
          14C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
          +
          15C> @param[out] BTHIN 3447 point thinned grid of s. hemispere 3447 grid is for grib grids 41-44.
          +
          16C>
          +
          17C> @note
          +
          18C> - w1 and w2 are used to store sets of constants which are
          +
          19C> reusable for repeated calls to the subroutine. 10 other arrays
          +
          20C> are saved and reused on the next call.
          +
          21C>
          +
          22C> @author Ralph Jones @date 1994-05-03
          +
          +
          23 SUBROUTINE w3ft17(ALOLA,BTHIN,INTERP)
          +
          24C
          +
          25 parameter(npts=3447)
          +
          26C
          +
          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)
          +
          32C
          +
          33 INTEGER NPT(73)
          +
          34 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
          +
          35 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
          +
          36C
          +
          37 LOGICAL LIN
          +
          38C
          +
          39 SAVE
          +
          40C
          +
          41 DATA intrpo/99/
          +
          42 DATA iswt /0/
          +
          43C
          +
          44C GRID POINT SEPARATION
          +
          45C
          +
          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/
          +
          59C
          +
          60C NUMBER OF POINTS ALONG LAT CIRCLE FOR ONE OCTANT
          +
          61C
          +
          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/
          +
          75C
          +
          76 lin = .false.
          +
          77 IF (interp.EQ.1) lin = .true.
          +
          78C
          +
          79 IF (iswt.EQ.1) GO TO 900
          +
          80C
          +
          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
          +
          92C
          +
          93 iswt = 1
          +
          94 intrpo = interp
          +
          95 GO TO 1000
          +
          96C
          +
          97C AFTER THE 1ST CALL TO W3FT17 TEST INTERP, IF IT HAS
          +
          98C CHANGED RECOMPUTE SOME CONSTANTS
          +
          99C
          +
          100 900 CONTINUE
          +
          101 IF (interp.EQ.intrpo) GO TO 2100
          +
          102 intrpo = interp
          +
          103C
          +
          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
          +
          114C
          +
          115 IF (lin) GO TO 1400
          +
          116C
          +
          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
          +
          125C
          +
          126 1400 CONTINUE
          +
          127C
          +
          128 IF (lin) GO TO 1700
          +
          129C
          +
          130 DO 1500 kk = 1,npts
          +
          131 IF (jv(kk).LT.2.OR.jv(kk).GE.90) xj2tm(kk) = 0.0
          +
          132 1500 CONTINUE
          +
          133C
          +
          134 1700 CONTINUE
          +
          135C
          +
          136C LINEAR INTERPOLATION
          +
          137C
          +
          138 DO 1900 kk = 1,npts
          +
          139 IF (jy(kk,3).GT.91) jy(kk,3) = 91
          +
          140 1900 CONTINUE
          +
          141C
          +
          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
          +
          148C
          +
          149 2100 CONTINUE
          +
          150 IF (lin) THEN
          +
          151C
          +
          152C LINEAR INTERPOLATION
          +
          153C
          +
          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
          +
          160C
          +
          161 DO 2300 kk = 1,npts
          +
          162 bthin(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
          +
          163 & * xdelj(kk)
          +
          164 2300 CONTINUE
          +
          165C
          +
          166 ELSE
          +
          167C
          +
          168C QUADRATIC INTERPOLATION
          +
          169C
          +
          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
          +
          192C
          +
          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
          +
          198C
          +
          199 ENDIF
          +
          200C
          +
          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/w3ft201_8f.html b/w3ft201_8f.html index 05e36df5..980d4532 100644 --- a/w3ft201_8f.html +++ b/w3ft201_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft201.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@
          @@ -76,16 +76,22 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          Functions/Subroutines
          -
          -
          w3ft201.f File Reference
          +
          w3ft201.f File Reference
          @@ -94,11 +100,11 @@

          Go to the source code of this file.

          - - - - + + +

          +

          Functions/Subroutines

          subroutine w3ft201 (ALOLA, APOLA, INTERP)
           Convert a global 1.0 degree lat.,lon. More...
           
          subroutine w3ft201 (alola, apola, interp)
           Convert a global 1.0 degree lat.,lon.
           

          Detailed Description

          Convert (361,181) grid to (65,65) n.

          @@ -107,8 +113,8 @@

          Definition in file w3ft201.f.

          Function/Subroutine Documentation

          - -

          ◆ w3ft201()

          + +

          ◆ w3ft201()

          @@ -117,19 +123,19 @@

          subroutine w3ft201 ( real, dimension(361,181)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -140,8 +146,8 @@

          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.

          -

          +

          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:

          @@ -159,7 +165,7 @@

          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.
            • +
          • 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.
          @@ -176,7 +182,7 @@

          diff --git a/w3ft201_8f.js b/w3ft201_8f.js index 7215b09e..635415c2 100644 --- a/w3ft201_8f.js +++ b/w3ft201_8f.js @@ -1,4 +1,4 @@ var w3ft201_8f = [ - [ "w3ft201", "w3ft201_8f.html#adf01350dac0812280321527151e91c76", null ] + [ "w3ft201", "w3ft201_8f.html#a4579b97893470f676e00332877d14a8a", null ] ]; \ No newline at end of file diff --git a/w3ft201_8f_source.html b/w3ft201_8f_source.html index 67c222a0..dfd68042 100644 --- a/w3ft201_8f_source.html +++ b/w3ft201_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft201.f Source File @@ -23,10 +23,9 @@

          - - + @@ -34,22 +33,28 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0

          - + +/* @license-end */ + +
          @@ -76,273 +81,281 @@
          - +
          +
          +
          +
          +
          Loading...
          +
          Searching...
          +
          No Matches
          +
          +
          +
          -
          -
          w3ft201.f
          +
          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
          +Go to the documentation of this file.
          1C> @file
          +
          2C> @brief Convert (361,181) grid to (65,65) n. hemi. grid
          +
          3C> @author Ralph Jones @date 1993-03-29
          +
          4
          +
          5C> Convert a global 1.0 degree lat.,lon. 361 by
          +
          6C> 181 grid to a polar stereographic 65 by 65 grid. The polar
          +
          7C> stereographic map projection is true at 60 deg. n. , the mesh
          +
          8C> length is 381 km. and the oriention is 105 deg. w. This is the
          +
          9C> same as w3ft43v() except the oriention is 105 deg. w.
          +
          10C>
          +
          11C> ### Program History Log:
          +
          12C> Date | Programmer | Comment
          +
          13C> -----|------------|--------
          +
          14C> 1993-03-29 | Ralph Jones | Add save statement.
          +
          15C>
          +
          16C> @param[in] ALOLA 361*181 grid 1.0 deg. lat,lon grid
          +
          17C> 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
          +
          18C> to right side to make 361 * 181.
          +
          19C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
          +
          20C> @param[out] APOLA 65*65 grid of northern hemisphere. 4225 point grid is
          +
          21C> awips grid type 201
          +
          22C>
          +
          23C> @note
          +
          24C> - 1. W1 and w2 are used to store sets of constants which are
          +
          25C> reusable for repeated calls to the subroutine.
          +
          26C> - 2. Wind components are not rotated to the 65*65 grid orientation
          +
          27C> after interpolation. You may use w3fc08() to do this.
          +
          28C> - 3. All points below equator are on this grid.
          +
          29C>
          +
          30C> @author Ralph Jones @date 1993-03-29
          +
          +
          31 SUBROUTINE w3ft201(ALOLA,APOLA,INTERP)
          +
          32C
          +
          33 parameter(npts=4225,ii=65,jj=65)
          +
          34 parameter(orient=105.0,ipole=33,jpole=33)
          +
          35 parameter(xmesh=381.0)
          +
          36C
          +
          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)
          +
          44C
          +
          45 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
          +
          46 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
          +
          47C
          +
          48 LOGICAL LIN
          +
          49C
          +
          50 SAVE
          +
          51C
          +
          52 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
          +
          53C
          +
          54 DATA degprd/57.2957795/
          +
          55 DATA earthr/6371.2/
          +
          56 DATA intrpo/99/
          +
          57 DATA iswt /0/
          +
          58C
          +
          59 lin = .false.
          +
          60 IF (interp.EQ.1) lin = .true.
          +
          61C
          +
          62 IF (iswt.EQ.1) GO TO 900
          +
          63C
          +
          64 deg = 1.0
          +
          65 gi2 = (1.86603 * earthr) / xmesh
          +
          66 gi2 = gi2 * gi2
          +
          67C
          +
          68C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
          +
          69C
          +
          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
          +
          76C
          +
          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
          +
          82C
          +
          83 xii(2113) = 1.0
          +
          84 DO 300 kk = 1,npts
          +
          85 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
          +
          86 300 CONTINUE
          +
          87C
          +
          88 DO 400 kk = 1,npts
          +
          89 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
          +
          90 400 CONTINUE
          +
          91C
          +
          92 DO 500 kk = 1,npts
          +
          93 wlon(kk) = 270.0 + orient - angle(kk)
          +
          94 500 CONTINUE
          +
          95C
          +
          96 DO 600 kk = 1,npts
          +
          97 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
          +
          98 600 CONTINUE
          +
          99C
          +
          100 DO 700 kk = 1,npts
          +
          101 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
          +
          102 700 CONTINUE
          +
          103C
          +
          104 xlat(2113) = 90.0
          +
          105 wlon(2113) = 0.0
          +
          106C
          +
          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
          +
          111C
          +
          112 iswt = 1
          +
          113 intrpo = interp
          +
          114 GO TO 1000
          +
          115C
          +
          116C AFTER THE 1ST CALL TO W3FT201 TEST INTERP, IF IT HAS
          +
          117C CHANGED RECOMPUTE SOME CONSTANTS
          +
          118C
          +
          119 900 CONTINUE
          +
          120 IF (interp.EQ.intrpo) GO TO 2100
          +
          121 intrpo = interp
          +
          122C
          +
          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
          +
          133C
          +
          134 IF (lin) GO TO 1400
          +
          135C
          +
          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
          +
          144C
          +
          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
          +
          154C
          +
          155 1400 CONTINUE
          +
          156C
          +
          157 IF (lin) GO TO 1700
          +
          158C
          +
          159 DO 1500 kk = 1,npts
          +
          160 IF (jv(kk).GE.180) xj2tm(kk) = 0.0
          +
          161 1500 CONTINUE
          +
          162C
          +
          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
          +
          169C
          +
          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
          +
          177C
          +
          178C LINEAR INTERPOLATION
          +
          179C
          +
          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
          +
          184C
          +
          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
          +
          191C
          +
          192 2100 CONTINUE
          +
          193 IF (lin) THEN
          +
          194C
          +
          195C LINEAR INTERPOLATION
          +
          196C
          +
          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
          +
          203C
          +
          204 DO 2300 kk = 1,npts
          +
          205 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
          +
          206 & * xdelj(kk)
          +
          207 2300 CONTINUE
          +
          208C
          +
          209 ELSE
          +
          210C
          +
          211C QUADRATIC INTERPOLATION
          +
          212C
          +
          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
          +
          235C
          +
          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
          +
          241C
          +
          242 ENDIF
          +
          243C
          +
          244C SET POLE POINT , WMO STANDARD FOR U OR V
          +
          245C
          +
          246 apola(2113) = alola(181,181)
          +
          247C
          +
          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/w3ft202_8f.html b/w3ft202_8f.html index ee5cda8d..957e8499 100644 --- a/w3ft202_8f.html +++ b/w3ft202_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft202.f File Reference @@ -23,10 +23,9 @@
          - - + @@ -34,21 +33,22 @@
          -
          NCEPLIBS-w3emc -  2.11.0 +
          +
          NCEPLIBS-w3emc 2.11.0
          - + +/* @license-end */ +
          @@ -62,7 +62,7 @@

        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft202.f File Reference
        +
        w3ft202.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft202 (alola, apola, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (65,43) n.

        @@ -107,8 +113,8 @@

        Definition in file w3ft202.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft202()

        + +

        ◆ w3ft202()

        @@ -117,19 +123,19 @@

        subroutine w3ft202 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -159,7 +165,7 @@

        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.
          • +
        • 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).
        @@ -176,7 +182,7 @@

        diff --git a/w3ft202_8f.js b/w3ft202_8f.js index 3299147c..7ba484ce 100644 --- a/w3ft202_8f.js +++ b/w3ft202_8f.js @@ -1,4 +1,4 @@ var w3ft202_8f = [ - [ "w3ft202", "w3ft202_8f.html#a250a1c3e5855f0481b17a3bf264cb2cd", null ] + [ "w3ft202", "w3ft202_8f.html#af3cc7cf79e145b0c0b05b77f18a6bc3e", null ] ]; \ No newline at end of file diff --git a/w3ft202_8f_source.html b/w3ft202_8f_source.html index a2c4b42e..9833ba2e 100644 --- a/w3ft202_8f_source.html +++ b/w3ft202_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft202.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,218 +81,226 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft202.f
        +
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (65,43) n. hemi. grid
        +
        3C> @author Ralph Jones @date 1994-05-18
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a polar stereographic 65 by 43 grid. The polar
        +
        7C> stereographic map projection is true at 60 deg. n. , The mesh
        +
        8C> length is 190.5 km. and the oriention is 105 deg. w.
        +
        9C>
        +
        10C> ### Program History Log:
        +
        11C> Date | Programmer | Comment
        +
        12C> -----|------------|--------
        +
        13C> 1994-05-18 | Ralph Jones | Initial.
        +
        14C>
        +
        15C> @param[in] ALOLA 361*91 grid 1.0 lat,lon grid n. hemisphere 32851 point
        +
        16C> grid is o.n. 84 type ?? or ?? hex
        +
        17C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        18C> @param[out] APOLA 65*43 grid of northern hemisphere. 2795 point grid is
        +
        19C> awips grid type 202
        +
        20C>
        +
        21C> @note
        +
        22C> - 1. W1 and w2 are used to store sets of constants which are
        +
        23C> reusable for repeated calls to the subroutine.
        +
        24C> - 2. Wind components are not rotated to the 65*43 grid orientation
        +
        25C> after interpolation. You may use w3fc08() to do this.
        +
        26C> - 3. The grid points values on the equator have been extrapolated
        +
        27C> outward to all the grid points outside the equator on the 65*43
        +
        28C> grid (about 1100 points).
        +
        29C>
        +
        30C> @author Ralph Jones @date 1994-05-18
        +
        +
        31 SUBROUTINE w3ft202(ALOLA,APOLA,INTERP)
        +
        32C
        +
        33 parameter(npts=2795,ii=65,jj=43)
        +
        34 parameter(orient=105.0,ipole=33,jpole=45)
        +
        35 parameter(xmesh=190.5)
        +
        36C
        +
        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)
        +
        44C
        +
        45 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        46 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        47C
        +
        48 LOGICAL LIN
        +
        49C
        +
        50 SAVE
        +
        51C
        +
        52 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
        +
        53C
        +
        54 DATA degprd/57.2957795/
        +
        55 DATA earthr/6371.2/
        +
        56 DATA intrpo/99/
        +
        57 DATA iswt /0/
        +
        58C
        +
        59 lin = .false.
        +
        60 IF (interp.EQ.1) lin = .true.
        +
        61C
        +
        62 IF (iswt.EQ.1) GO TO 900
        +
        63C
        +
        64 deg = 1.0
        +
        65 gi2 = (1.86603 * earthr) / xmesh
        +
        66 gi2 = gi2 * gi2
        +
        67C
        +
        68C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
        +
        69C
        +
        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
        +
        76C
        +
        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
        +
        82C
        +
        83 DO 300 kk = 1,npts
        +
        84 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
        +
        85 300 CONTINUE
        +
        86C
        +
        87 DO 400 kk = 1,npts
        +
        88 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
        +
        89 400 CONTINUE
        +
        90C
        +
        91 DO 500 kk = 1,npts
        +
        92 wlon(kk) = 270.0 + orient - angle(kk)
        +
        93 500 CONTINUE
        +
        94C
        +
        95 DO 600 kk = 1,npts
        +
        96 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
        +
        97 600 CONTINUE
        +
        98C
        +
        99 DO 700 kk = 1,npts
        +
        100 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
        +
        101 700 CONTINUE
        +
        102C
        +
        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
        +
        107C
        +
        108 iswt = 1
        +
        109 intrpo = interp
        +
        110 GO TO 1000
        +
        111C
        +
        112C AFTER THE 1ST CALL TO W3FT202 TEST INTERP, IF IT HAS
        +
        113C CHANGED RECOMPUTE SOME CONSTANTS
        +
        114C
        +
        115 900 CONTINUE
        +
        116 IF (interp.EQ.intrpo) GO TO 2100
        +
        117 intrpo = interp
        +
        118C
        +
        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
        +
        129C
        +
        130 IF (lin) GO TO 2100
        +
        131C
        +
        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
        +
        140C
        +
        141 2100 CONTINUE
        +
        142 IF (lin) THEN
        +
        143C
        +
        144C LINEAR INTERPOLATION
        +
        145C
        +
        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
        +
        152C
        +
        153 DO 2300 kk = 1,npts
        +
        154 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        155 & * xdelj(kk)
        +
        156 2300 CONTINUE
        +
        157C
        +
        158 ELSE
        +
        159C
        +
        160C QUADRATIC INTERPOLATION
        +
        161C
        +
        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
        +
        184C
        +
        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
        +
        190C
        +
        191 ENDIF
        +
        192C
        +
        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/w3ft203_8f.html b/w3ft203_8f.html index fed79fd6..d64aef6e 100644 --- a/w3ft203_8f.html +++ b/w3ft203_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft203.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@
        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft203.f File Reference
        +
        w3ft203.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft203 (alola, apola, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (45,39) n.

        @@ -107,8 +113,8 @@

        Definition in file w3ft203.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft203()

        + +

        ◆ w3ft203()

        @@ -117,19 +123,19 @@

        subroutine w3ft203 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -159,7 +165,7 @@

        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.
          • +
        • 2. Wind components are not rotated to the 45*39 grid orientation after interpolation. You may use w3fc08() to do this.
        Author
        Ralph Jones
        @@ -175,7 +181,7 @@

        diff --git a/w3ft203_8f.js b/w3ft203_8f.js index 6d72b5fc..938fd2fb 100644 --- a/w3ft203_8f.js +++ b/w3ft203_8f.js @@ -1,4 +1,4 @@ var w3ft203_8f = [ - [ "w3ft203", "w3ft203_8f.html#ac0fba620647d28d2dfd0424c2d3543e8", null ] + [ "w3ft203", "w3ft203_8f.html#a33e491f31a1b02e212f2d38e938fff95", null ] ]; \ No newline at end of file diff --git a/w3ft203_8f_source.html b/w3ft203_8f_source.html index c170471a..96f42d71 100644 --- a/w3ft203_8f_source.html +++ b/w3ft203_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft203.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,274 +81,282 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft203.f
        +
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (45,39) n. hemi. grid
        +
        3C> @author Ralph Jones @date 1994-05-18
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a polar stereographic 45 by 39 grid. The polar
        +
        7C> stereographic map projection is true at 60 deg. n. , The mesh
        +
        8C> length is 190.5 km. and the oriention is 150 deg. w.
        +
        9C>
        +
        10C> ### Program History Log:
        +
        11C> Date | Programmer | Comment
        +
        12C> -----|------------|--------
        +
        13C> 1994-05-18 | Ralph Jones | Initial.
        +
        14C>
        +
        15C> @param[in] ALOLA 361*91 grid 1.0 lat,lon grid n. hemisphere
        +
        16C> 32851 point grid is o.n. 84 type ?? or ?? hex
        +
        17C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        18C> @param[out] APOLA 45*39 grid of northern hemisphere. 1755 point grid is
        +
        19C> awips grid type 203
        +
        20C>
        +
        21C> @note
        +
        22C> - 1. W1 and w2 are used to store sets of constants which are
        +
        23C> reusable for repeated calls to the subroutine.
        +
        24C> - 2. Wind components are not rotated to the 45*39 grid orientation
        +
        25C> after interpolation. You may use w3fc08() to do this.
        +
        26C>
        +
        27C> @author Ralph Jones @date 1994-05-18
        +
        +
        28 SUBROUTINE w3ft203(ALOLA,APOLA,INTERP)
        +
        29C
        +
        30 parameter(npts=1755,ii=45,jj=39)
        +
        31 parameter(orient=150.0,ipole=27,jpole=37)
        +
        32 parameter(xmesh=190.5)
        +
        33C
        +
        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)
        +
        41C
        +
        42 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        43 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        44C
        +
        45 LOGICAL LIN
        +
        46C
        +
        47 SAVE
        +
        48C
        +
        49 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
        +
        50C
        +
        51 DATA degprd/57.2957795/
        +
        52 DATA earthr/6371.2/
        +
        53 DATA intrpo/99/
        +
        54 DATA iswt /0/
        +
        55C
        +
        56 lin = .false.
        +
        57 IF (interp.EQ.1) lin = .true.
        +
        58C
        +
        59 IF (iswt.EQ.1) GO TO 900
        +
        60C
        +
        61 deg = 1.0
        +
        62 gi2 = (1.86603 * earthr) / xmesh
        +
        63 gi2 = gi2 * gi2
        +
        64C
        +
        65C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
        +
        66C
        +
        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
        +
        73C
        +
        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
        +
        79C
        +
        80 xii(1647) = 1.0
        +
        81 DO 300 kk = 1,npts
        +
        82 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
        +
        83 300 CONTINUE
        +
        84C
        +
        85 DO 400 kk = 1,npts
        +
        86 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
        +
        87 400 CONTINUE
        +
        88C
        +
        89 DO 500 kk = 1,npts
        +
        90 wlon(kk) = 270.0 + orient - angle(kk)
        +
        91 500 CONTINUE
        +
        92C
        +
        93 DO 600 kk = 1,npts
        +
        94 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
        +
        95 600 CONTINUE
        +
        96C
        +
        97 DO 700 kk = 1,npts
        +
        98 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
        +
        99 700 CONTINUE
        +
        100C
        +
        101 xlat(1647) = 90.0
        +
        102 wlon(1647) = 0.0
        +
        103C
        +
        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
        +
        108C
        +
        109 iswt = 1
        +
        110 intrpo = interp
        +
        111 GO TO 1000
        +
        112C
        +
        113C AFTER THE 1ST CALL TO W3FT203 TEST INTERP, IF IT HAS
        +
        114C CHANGED RECOMPUTE SOME CONSTANTS
        +
        115C
        +
        116 900 CONTINUE
        +
        117 IF (interp.EQ.intrpo) GO TO 2100
        +
        118 intrpo = interp
        +
        119C
        +
        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
        +
        130C
        +
        131 IF (lin) GO TO 1400
        +
        132C
        +
        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
        +
        141C
        +
        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
        +
        151C
        +
        152 1400 CONTINUE
        +
        153C
        +
        154 IF (lin) GO TO 1700
        +
        155C
        +
        156 DO 1500 kk = 1,npts
        +
        157 IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
        +
        158 1500 CONTINUE
        +
        159C
        +
        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
        +
        166C
        +
        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
        +
        174C
        +
        175C LINEAR INTERPOLATION
        +
        176C
        +
        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
        +
        183C
        +
        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
        +
        192C
        +
        193 2100 CONTINUE
        +
        194 IF (lin) THEN
        +
        195C
        +
        196C LINEAR INTERPOLATION
        +
        197C
        +
        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
        +
        204C
        +
        205 DO 2300 kk = 1,npts
        +
        206 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        207 & * xdelj(kk)
        +
        208 2300 CONTINUE
        +
        209C
        +
        210 ELSE
        +
        211C
        +
        212C QUADRATIC INTERPOLATION
        +
        213C
        +
        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
        +
        236C
        +
        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
        +
        242C
        +
        243C SET POLE POINT , WMO STANDARD FOR U OR V
        +
        244C
        +
        245 apola(1647) = alola(181,91)
        +
        246C
        +
        247 ENDIF
        +
        248C
        +
        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/w3ft204_8f.html b/w3ft204_8f.html index 10e6f2a9..0146df94 100644 --- a/w3ft204_8f.html +++ b/w3ft204_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft204.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@

        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft204.f File Reference
        +
        w3ft204.f File Reference
        @@ -94,11 +100,11 @@

        Go to the source code of this file.

        - - - - + + +

        +

        Functions/Subroutines

        subroutine w3ft204 (ALOLA, AMERC, INTERP)
         Convert a n. More...
         
        subroutine w3ft204 (alola, amerc, interp)
         Convert a n.
         

        Detailed Description

        Convert (361,181) grid to (93,68) mercator grid.

        @@ -107,8 +113,8 @@

        Definition in file w3ft204.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft204()

        + +

        ◆ w3ft204()

        @@ -117,19 +123,19 @@

        subroutine w3ft204 ( real, dimension(361,181)  - ALOLA, + alola, real, dimension(npts)  - AMERC, + amerc,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -174,7 +180,7 @@

        diff --git a/w3ft204_8f.js b/w3ft204_8f.js index f42e57fa..58f666c8 100644 --- a/w3ft204_8f.js +++ b/w3ft204_8f.js @@ -1,4 +1,4 @@ var w3ft204_8f = [ - [ "w3ft204", "w3ft204_8f.html#abb78410bc09aaf18f345e4a90c7cff9f", null ] + [ "w3ft204", "w3ft204_8f.html#a05244863fcba4deeecafd48af8f97435", null ] ]; \ No newline at end of file diff --git a/w3ft204_8f_source.html b/w3ft204_8f_source.html index 712ee6a6..d3774c58 100644 --- a/w3ft204_8f_source.html +++ b/w3ft204_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft204.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,202 +81,210 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft204.f
        +
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,181) grid to (93,68) mercator grid.
        +
        3C> @author Ralph Jones @date 1994-05-18
        +
        4
        +
        5C> Convert a n. s. hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 181 grid to a national - hawaii (mercator) 93*68 awips 204
        +
        7C> grid.
        +
        8C>
        +
        9C> ### Program History Log:
        +
        10C> Date | Programmer | Comment
        +
        11C> -----|------------|--------
        +
        12C> 1994-05-18 | Ralph Jones | Initial.
        +
        13C>
        +
        14C> @param[in] ALOLA 361*181 grid 1.0 deg. lat,lon grid n. hemi.
        +
        15C> 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
        +
        16C> to right side.
        +
        17C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        18C> @param[out] AMERC 93*68 grid national - hawaii (mercator) 6324 point grid
        +
        19C> is awips grid type 204
        +
        20C> @note
        +
        21C> - 1. W1 and w2 are used to store sets of constants which are
        +
        22C> reusable for repeated calls to the subroutine. 20 other array
        +
        23C> are saved and reused on the next call.
        +
        24C>
        +
        25C> @author Ralph Jones @date 1994-05-18
        +
        +
        26 SUBROUTINE w3ft204(ALOLA,AMERC,INTERP)
        +
        27C
        +
        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)
        +
        34C
        +
        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)
        +
        42C
        +
        43 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        44 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        45C
        +
        46 LOGICAL LIN
        +
        47C
        +
        48 SAVE
        +
        49C
        +
        50 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
        +
        51C
        +
        52C DATA DEGPR /57.2957795/
        +
        53 DATA rerth /6.3712e+6/
        +
        54 DATA intrpo/99/
        +
        55 DATA iswt /0/
        +
        56C
        +
        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
        +
        62C
        +
        63 lin = .false.
        +
        64 IF (interp.EQ.1) lin = .true.
        +
        65C
        +
        66 IF (iswt.EQ.1) GO TO 900
        +
        67C
        +
        68 deg = 1.0
        +
        69C
        +
        70C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
        +
        71C
        +
        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
        +
        77C
        +
        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
        +
        82C
        +
        83 DO 300 kk = 1,npts
        +
        84 wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
        +
        85 300 CONTINUE
        +
        86C
        +
        87 DO 400 kk = 1,npts
        +
        88 w1(kk) = wlon(kk) + 1.0
        +
        89 w2(kk) = xlat(kk) + 91.0
        +
        90 400 CONTINUE
        +
        91C
        +
        92 iswt = 1
        +
        93 intrpo = interp
        +
        94 GO TO 1000
        +
        95C
        +
        96C AFTER THE 1ST CALL TO W3FT204 TEST INTERP, IF IT HAS
        +
        97C CHANGED RECOMPUTE SOME CONSTANTS
        +
        98C
        +
        99 900 CONTINUE
        +
        100 IF (interp.EQ.intrpo) GO TO 2100
        +
        101 intrpo = interp
        +
        102C
        +
        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
        +
        113C
        +
        114 IF (lin) GO TO 2100
        +
        115C
        +
        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
        +
        124C
        +
        125 2100 CONTINUE
        +
        126 IF (lin) THEN
        +
        127C
        +
        128C LINEAR INTERPOLATION
        +
        129C
        +
        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
        +
        136C
        +
        137 DO 2300 kk = 1,npts
        +
        138 amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        139 & * xdelj(kk)
        +
        140 2300 CONTINUE
        +
        141C
        +
        142 ELSE
        +
        143C
        +
        144C QUADRATIC INTERPOLATION
        +
        145C
        +
        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
        +
        168C
        +
        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
        +
        174C
        +
        175 ENDIF
        +
        176C
        +
        177 RETURN
        +
        +
        178 END
        +
        w3ft204
        subroutine w3ft204(alola, amerc, interp)
        Convert a n.
        Definition w3ft204.f:27
        diff --git a/w3ft205_8f.html b/w3ft205_8f.html index 03fd3188..4d48163b 100644 --- a/w3ft205_8f.html +++ b/w3ft205_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft205.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@
        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft205.f File Reference
        +
        w3ft205.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft205 (alola, apola, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (45,39) n.

        @@ -107,8 +113,8 @@

        Definition in file w3ft205.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft205()

        + +

        ◆ w3ft205()

        @@ -117,19 +123,19 @@

        subroutine w3ft205 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -159,7 +165,7 @@

        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.
          • +
        • 2. Wind components are not rotated to the 45*39 grid orientation after interpolation. You may use w3fc08() to do this.
        Author
        Ralph Jones
        @@ -175,7 +181,7 @@

        diff --git a/w3ft205_8f.js b/w3ft205_8f.js index 5aa9658e..b3f835a7 100644 --- a/w3ft205_8f.js +++ b/w3ft205_8f.js @@ -1,4 +1,4 @@ var w3ft205_8f = [ - [ "w3ft205", "w3ft205_8f.html#ad9a3463156cbb99e97f7f3c2f9e0bc26", null ] + [ "w3ft205", "w3ft205_8f.html#aeecada5cbfb2d7fee1e5a24f2e7b694e", null ] ]; \ No newline at end of file diff --git a/w3ft205_8f_source.html b/w3ft205_8f_source.html index edf83610..35bb85de 100644 --- a/w3ft205_8f_source.html +++ b/w3ft205_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft205.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,236 +81,244 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft205.f
        +
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (45,39) n. hemi. grid.
        +
        3C> @author Ralph Jones @date 1993-10-19
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a polar stereographic 45 by 39 grid. The polar
        +
        7C> stereographic map projection is true at 60 deg. n. , The mesh
        +
        8C> length is 190.5 km. and the oriention is 60 deg. w. pole
        +
        9C> point is at (i,j) = (27,57). new map is awips map 205.
        +
        10C>
        +
        11C> ### Program History Log:
        +
        12C> Date | Programmer | Comment
        +
        13C> -----|------------|--------
        +
        14C> 1993-10-19 | Ralph Jones | Initial.
        +
        15C>
        +
        16C> @param[in] ALOLA 361*91 grid 1.0 lat,lon grid n. hemisphere
        +
        17C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
        +
        18C> to righ side and cut to 361 * 91.
        +
        19C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        20C> @param[out] APOLA 45*39 grid of northern hemisphere. 1755 point grid is
        +
        21C> awips grid type 205
        +
        22C>
        +
        23C> @note
        +
        24C> - 1. W1 and w2 are used to store sets of constants which are
        +
        25C> reusable for repeated calls to the subroutine.
        +
        26C> - 2. Wind components are not rotated to the 45*39 grid orientation
        +
        27C> after interpolation. You may use w3fc08() to do this.
        +
        28C>
        +
        29C> @author Ralph Jones @date 1993-10-19
        +
        +
        30 SUBROUTINE w3ft205(ALOLA,APOLA,INTERP)
        +
        31C
        +
        32 parameter(npts=1755,ii=45,jj=39)
        +
        33 parameter(orient=60.0,ipole=27,jpole=57)
        +
        34 parameter(xmesh=190.5)
        +
        35C
        +
        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)
        +
        43C
        +
        44 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        45 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        46C
        +
        47 LOGICAL LIN
        +
        48C
        +
        49 SAVE
        +
        50C
        +
        51 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
        +
        52C
        +
        53 DATA degprd/57.2957795/
        +
        54 DATA earthr/6371.2/
        +
        55 DATA intrpo/99/
        +
        56 DATA iswt /0/
        +
        57C
        +
        58 lin = .false.
        +
        59 IF (interp.EQ.1) lin = .true.
        +
        60C
        +
        61 IF (iswt.EQ.1) GO TO 900
        +
        62C
        +
        63 deg = 1.0
        +
        64 gi2 = (1.86603 * earthr) / xmesh
        +
        65 gi2 = gi2 * gi2
        +
        66C
        +
        67C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
        +
        68C
        +
        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
        +
        75C
        +
        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
        +
        81C
        +
        82 xii(1647) = 1.0
        +
        83 DO 300 kk = 1,npts
        +
        84 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
        +
        85 300 CONTINUE
        +
        86C
        +
        87 DO 400 kk = 1,npts
        +
        88 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
        +
        89 400 CONTINUE
        +
        90C
        +
        91 DO 500 kk = 1,npts
        +
        92 wlon(kk) = 270.0 + orient - angle(kk)
        +
        93 500 CONTINUE
        +
        94C
        +
        95 DO 600 kk = 1,npts
        +
        96 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
        +
        97 600 CONTINUE
        +
        98C
        +
        99 DO 700 kk = 1,npts
        +
        100 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
        +
        101 700 CONTINUE
        +
        102C
        +
        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
        +
        107C
        +
        108 iswt = 1
        +
        109 intrpo = interp
        +
        110 GO TO 1000
        +
        111C
        +
        112C AFTER THE 1ST CALL TO W3FT203 TEST INTERP, IF IT HAS
        +
        113C CHANGED RECOMPUTE SOME CONSTANTS
        +
        114C
        +
        115 900 CONTINUE
        +
        116 IF (interp.EQ.intrpo) GO TO 2100
        +
        117 intrpo = interp
        +
        118C
        +
        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
        +
        129C
        +
        130 IF (lin) GO TO 1400
        +
        131C
        +
        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
        +
        140C
        +
        141 1400 CONTINUE
        +
        142C
        +
        143 IF (lin) GO TO 1700
        +
        144C
        +
        145 DO 1500 kk = 1,npts
        +
        146 IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
        +
        147 1500 CONTINUE
        +
        148C
        +
        149 1700 CONTINUE
        +
        150C
        +
        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
        +
        156C
        +
        157 2100 CONTINUE
        +
        158 IF (lin) THEN
        +
        159C
        +
        160C LINEAR INTERPOLATION
        +
        161C
        +
        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
        +
        168C
        +
        169 DO 2300 kk = 1,npts
        +
        170 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        171 & * xdelj(kk)
        +
        172 2300 CONTINUE
        +
        173C
        +
        174 ELSE
        +
        175C
        +
        176C QUADRATIC INTERPOLATION
        +
        177C
        +
        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
        +
        200C
        +
        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
        +
        206C
        +
        207C NO POLE POINT
        +
        208C
        +
        209 ENDIF
        +
        210C
        +
        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/w3ft206_8f.html b/w3ft206_8f.html index 9f750439..ece27cda 100644 --- a/w3ft206_8f.html +++ b/w3ft206_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft206.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@

        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft206.f File Reference
        +
        w3ft206.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft206 (alola, alamb, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (51,41) lambert grid.

        @@ -107,8 +113,8 @@

        Definition in file w3ft206.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft206()

        + +

        ◆ w3ft206()

        @@ -117,19 +123,19 @@

        subroutine w3ft206 ( real, dimension(iii,jjj)  - ALOLA, + alola, real, dimension(npts)  - ALAMB, + alamb,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -159,7 +165,7 @@

        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.
          • +
        • 2. Wind components are not rotated to the 51*41 grid orientation after interpolation. You may use w3fc08() to do this.
        Author
        Ralph Jones
        @@ -175,7 +181,7 @@

        diff --git a/w3ft206_8f.js b/w3ft206_8f.js index da5f9ac8..ea2915f6 100644 --- a/w3ft206_8f.js +++ b/w3ft206_8f.js @@ -1,4 +1,4 @@ var w3ft206_8f = [ - [ "w3ft206", "w3ft206_8f.html#a8a2d9d2de5ecb622756c8138eab5377c", null ] + [ "w3ft206", "w3ft206_8f.html#a11bbf4178c5e3290da90771366c95aaa", null ] ]; \ No newline at end of file diff --git a/w3ft206_8f_source.html b/w3ft206_8f_source.html index e77ad0e7..e153ded8 100644 --- a/w3ft206_8f_source.html +++ b/w3ft206_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft206.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,184 +81,192 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft206.f
        +
        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
        -
        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
        -
        w3ft206
        subroutine w3ft206(ALOLA, ALAMB, INTERP)
        Convert a northern hemisphere 1.0 degree lat.,lon.
        Definition: w3ft206.f:29
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (51,41) lambert grid
        +
        3C> @author Ralph Jones @date 1994-05-18
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a lambert conformal 51 by 41 awips grib 206.
        +
        7C>
        +
        8C> ### Program History Log:
        +
        9C> Date | Programmer | Comment
        +
        10C> -----|------------|--------
        +
        11C> 1994-05-18 | Ralph Jones | Initial.
        +
        12C>
        +
        13C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
        +
        14C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
        +
        15C> to right side and cut to 361 * 91.
        +
        16C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        17C> @param[out] ALAMB 51*41 regional - central us mard
        +
        18C> (lambert conformal). 2091 point grid is awips grid type 206
        +
        19C>
        +
        20C> @note
        +
        21C> - 1. W1 and w2 are used to store sets of constants which are
        +
        22C> reusable for repeated calls to the subroutine. 11 other array
        +
        23C> are saved and reused on the next call.
        +
        24C> - 2. Wind components are not rotated to the 51*41 grid orientation
        +
        25C> after interpolation. You may use w3fc08() to do this.
        +
        26C>
        +
        27C> @author Ralph Jones @date 1994-05-18
        +
        +
        28 SUBROUTINE w3ft206(ALOLA,ALAMB,INTERP)
        +
        29C
        +
        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)
        +
        38C
        +
        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)
        +
        44C
        +
        45 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        46 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        47C
        +
        48 LOGICAL LIN
        +
        49C
        +
        50 SAVE
        +
        51C
        +
        52 DATA iswt /0/
        +
        53 DATA intrpo/99/
        +
        54C
        +
        55 lin = .false.
        +
        56 IF (interp.EQ.1) lin = .true.
        +
        57C
        +
        58 IF (iswt.EQ.1) GO TO 900
        +
        59c 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
        +
        72C
        +
        73 iswt = 1
        +
        74 intrpo = interp
        +
        75 GO TO 1000
        +
        76C
        +
        77C AFTER THE 1ST CALL TO W3FT206 TEST INTERP, IF IT HAS
        +
        78C CHANGED RECOMPUTE SOME CONSTANTS
        +
        79C
        +
        80 900 CONTINUE
        +
        81 IF (interp.EQ.intrpo) GO TO 2100
        +
        82 intrpo = interp
        +
        83C
        +
        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
        +
        94C
        +
        95 IF (lin) GO TO 2100
        +
        96C
        +
        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
        +
        105C
        +
        106 2100 CONTINUE
        +
        107 IF (lin) THEN
        +
        108C
        +
        109C LINEAR INTERPOLATION
        +
        110C
        +
        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
        +
        117C
        +
        118 DO 2300 kk = 1,npts
        +
        119 alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        120 & * xdelj(kk)
        +
        121 2300 CONTINUE
        +
        122C
        +
        123 ELSE
        +
        124C
        +
        125C QUADRATIC INTERPOLATION
        +
        126C
        +
        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
        +
        149C
        +
        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
        +
        155C
        +
        156 ENDIF
        +
        157C
        +
        158 RETURN
        +
        +
        159 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
        +
        w3ft206
        subroutine w3ft206(alola, alamb, interp)
        Convert a northern hemisphere 1.0 degree lat.,lon.
        Definition w3ft206.f:29
        diff --git a/w3ft207_8f.html b/w3ft207_8f.html index dd093143..2dbb1d13 100644 --- a/w3ft207_8f.html +++ b/w3ft207_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft207.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@
        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft207.f File Reference
        +
        w3ft207.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft207 (alola, apola, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (49,35) n.

        @@ -107,8 +113,8 @@

        Definition in file w3ft207.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft207()

        + +

        ◆ w3ft207()

        @@ -117,19 +123,19 @@

        subroutine w3ft207 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -159,7 +165,7 @@

        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.
          • +
        • 2. Wind components are not rotated to the 49*35 grid orientation after interpolation. You may use w3fc08() to do this.
        Author
        Ralph Jones
        @@ -175,7 +181,7 @@

        diff --git a/w3ft207_8f.js b/w3ft207_8f.js index 561bb4e2..164f5043 100644 --- a/w3ft207_8f.js +++ b/w3ft207_8f.js @@ -1,4 +1,4 @@ var w3ft207_8f = [ - [ "w3ft207", "w3ft207_8f.html#aa4de7ddd4f65373756f6cd70b3fd6fec", null ] + [ "w3ft207", "w3ft207_8f.html#a5be00916db03675c80fb3177a464f262", null ] ]; \ No newline at end of file diff --git a/w3ft207_8f_source.html b/w3ft207_8f_source.html index 3ee017f4..8ec311e7 100644 --- a/w3ft207_8f_source.html +++ b/w3ft207_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft207.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,268 +81,276 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft207.f
        +
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (49,35) n. hemi. grid
        +
        3C> @author Ralph Jones @date 1993-10-19
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a polar stereographic 49 by 35 grid. The polar
        +
        7C> stereographic map projection is true at 60 deg. n. , The mesh
        +
        8C> length is 95.25 km. and the oriention is 150 deg. w.
        +
        9C> awips grid 207 regional - alaska.
        +
        10C>
        +
        11C> ### Program History Log:
        +
        12C> Date | Programmer | Comment
        +
        13C> -----|------------|--------
        +
        14C> 1993-10-19 | Ralph Jones | Initial.
        +
        15C>
        +
        16C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
        +
        17C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
        +
        18C> to right side and cut to 361 * 91.
        +
        19C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        20C> @param[out] APOLA 49*35 grid of northern hemisphere. 1715 point grid is
        +
        21C> awips grid type 207
        +
        22C>
        +
        23C> @note
        +
        24C> - 1. W1 and w2 are used to store sets of constants which are
        +
        25C> reusable for repeated calls to the subroutine.
        +
        26C> - 2. Wind components are not rotated to the 49*35 grid orientation
        +
        27C> after interpolation. You may use w3fc08() to do this.
        +
        28C>
        +
        29C> @author Ralph Jones @date 1993-10-19
        +
        +
        30 SUBROUTINE w3ft207(ALOLA,APOLA,INTERP)
        +
        31C
        +
        32 parameter(npts=1715,ii=49,jj=35)
        +
        33 parameter(orient=150.0,ipole=25,jpole=51)
        +
        34 parameter(xmesh=95.250)
        +
        35C
        +
        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)
        +
        43C
        +
        44 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        45 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        46C
        +
        47 LOGICAL LIN
        +
        48C
        +
        49 SAVE
        +
        50C
        +
        51 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
        +
        52C
        +
        53 DATA degprd/57.2957795/
        +
        54 DATA earthr/6371.2/
        +
        55 DATA intrpo/99/
        +
        56 DATA iswt /0/
        +
        57C
        +
        58 lin = .false.
        +
        59 IF (interp.EQ.1) lin = .true.
        +
        60C
        +
        61 IF (iswt.EQ.1) GO TO 900
        +
        62C
        +
        63 deg = 1.0
        +
        64 gi2 = (1.86603 * earthr) / xmesh
        +
        65 gi2 = gi2 * gi2
        +
        66C
        +
        67C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
        +
        68C
        +
        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
        +
        75C
        +
        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
        +
        81C
        +
        82 DO 300 kk = 1,npts
        +
        83 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
        +
        84 300 CONTINUE
        +
        85C
        +
        86 DO 400 kk = 1,npts
        +
        87 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
        +
        88 400 CONTINUE
        +
        89C
        +
        90 DO 500 kk = 1,npts
        +
        91 wlon(kk) = 270.0 + orient - angle(kk)
        +
        92 500 CONTINUE
        +
        93C
        +
        94 DO 600 kk = 1,npts
        +
        95 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
        +
        96 600 CONTINUE
        +
        97C
        +
        98 DO 700 kk = 1,npts
        +
        99 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
        +
        100 700 CONTINUE
        +
        101C
        +
        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
        +
        106C
        +
        107 iswt = 1
        +
        108 intrpo = interp
        +
        109 GO TO 1000
        +
        110C
        +
        111C AFTER THE 1ST CALL TO W3FT207 TEST INTERP, IF IT HAS
        +
        112C CHANGED RECOMPUTE SOME CONSTANTS
        +
        113C
        +
        114 900 CONTINUE
        +
        115 IF (interp.EQ.intrpo) GO TO 2100
        +
        116 intrpo = interp
        +
        117C
        +
        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
        +
        128C
        +
        129 IF (lin) GO TO 1400
        +
        130C
        +
        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
        +
        139C
        +
        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
        +
        149C
        +
        150 1400 CONTINUE
        +
        151C
        +
        152 IF (lin) GO TO 1700
        +
        153C
        +
        154 DO 1500 kk = 1,npts
        +
        155 IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
        +
        156 1500 CONTINUE
        +
        157C
        +
        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
        +
        164C
        +
        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
        +
        172C
        +
        173C LINEAR INTERPOLATION
        +
        174C
        +
        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
        +
        181C
        +
        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
        +
        190C
        +
        191 2100 CONTINUE
        +
        192 IF (lin) THEN
        +
        193C
        +
        194C LINEAR INTERPOLATION
        +
        195C
        +
        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
        +
        202C
        +
        203 DO 2300 kk = 1,npts
        +
        204 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        205 & * xdelj(kk)
        +
        206 2300 CONTINUE
        +
        207C
        +
        208 ELSE
        +
        209C
        +
        210C QUADRATIC INTERPOLATION
        +
        211C
        +
        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
        +
        234C
        +
        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
        +
        240C
        +
        241 ENDIF
        +
        242C
        +
        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/w3ft208_8f.html b/w3ft208_8f.html index 1cce15e6..d2e35d51 100644 --- a/w3ft208_8f.html +++ b/w3ft208_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft208.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@

        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft208.f File Reference
        +
        w3ft208.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft208 (alola, amerc, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (29,27) mercator grid.

        @@ -107,8 +113,8 @@

        Definition in file w3ft208.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft208()

        + +

        ◆ w3ft208()

        @@ -117,19 +123,19 @@

        subroutine w3ft208 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - AMERC, + amerc,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -174,7 +180,7 @@

        diff --git a/w3ft208_8f.js b/w3ft208_8f.js index 9fff508d..a8be0b53 100644 --- a/w3ft208_8f.js +++ b/w3ft208_8f.js @@ -1,4 +1,4 @@ var w3ft208_8f = [ - [ "w3ft208", "w3ft208_8f.html#ab3380c5bf59fbd57210787bb91f5584f", null ] + [ "w3ft208", "w3ft208_8f.html#a39df24e7c5c06b8b094f9baf7a637068", null ] ]; \ No newline at end of file diff --git a/w3ft208_8f_source.html b/w3ft208_8f_source.html index 02fc106b..fca3896f 100644 --- a/w3ft208_8f_source.html +++ b/w3ft208_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft208.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,203 +81,211 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft208.f
        +
        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
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (29,27) mercator grid.
        +
        3C> @author Ralph Jones @date 1993-10-19
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a regional - hawaii (mercator) 29*27 awips 208
        +
        7C> grid.
        +
        8C>
        +
        9C> ### Program History Log:
        +
        10C> Date | Programmer | Comment
        +
        11C> -----|------------|--------
        +
        12C> 1993-10-19 | Ralph Jones | Initial
        +
        13C>
        +
        14C> @param[in] ALOLA 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI.
        +
        15C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
        +
        16C> to right side and cut to 361 * 91.
        +
        17C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        18C> @param[out] AMERC 29*27 grid of northern mercator 783 point grid is awips
        +
        19C> grid type 208
        +
        20C>
        +
        21C> @note
        +
        22C> - 1. W1 and w2 are used to store sets of constants which are
        +
        23C> reusable for repeated calls to the subroutine. 20 other array
        +
        24C> are saved and reused on the next call.
        +
        25C>
        +
        26C> @author Ralph Jones @date 1993-10-19
        +
        +
        27 SUBROUTINE w3ft208(ALOLA,AMERC,INTERP)
        +
        28C
        +
        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)
        +
        35C
        +
        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)
        +
        43C
        +
        44 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        45 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        46C
        +
        47 LOGICAL LIN
        +
        48C
        +
        49 SAVE
        +
        50C
        +
        51 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
        +
        52C
        +
        53C DATA DEGPR /57.2957795/
        +
        54 DATA rerth /6.3712e+6/
        +
        55 DATA intrpo/99/
        +
        56 DATA iswt /0/
        +
        57C
        +
        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
        +
        63C
        +
        64 lin = .false.
        +
        65 IF (interp.EQ.1) lin = .true.
        +
        66C
        +
        67 IF (iswt.EQ.1) GO TO 900
        +
        68C
        +
        69 deg = 1.0
        +
        70C
        +
        71C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
        +
        72C
        +
        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
        +
        78C
        +
        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
        +
        83C
        +
        84 DO 300 kk = 1,npts
        +
        85 wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
        +
        86 300 CONTINUE
        +
        87C
        +
        88 DO 400 kk = 1,npts
        +
        89 w1(kk) = wlon(kk) + 1.0
        +
        90 w2(kk) = xlat(kk) + 1.0
        +
        91 400 CONTINUE
        +
        92C
        +
        93 iswt = 1
        +
        94 intrpo = interp
        +
        95 GO TO 1000
        +
        96C
        +
        97C AFTER THE 1ST CALL TO W3FT208 TEST INTERP, IF IT HAS
        +
        98C CHANGED RECOMPUTE SOME CONSTANTS
        +
        99C
        +
        100 900 CONTINUE
        +
        101 IF (interp.EQ.intrpo) GO TO 2100
        +
        102 intrpo = interp
        +
        103C
        +
        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
        +
        114C
        +
        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
        +
        125C
        +
        126 2100 CONTINUE
        +
        127 IF (lin) THEN
        +
        128C
        +
        129C LINEAR INTERPOLATION
        +
        130C
        +
        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
        +
        137C
        +
        138 DO 2300 kk = 1,npts
        +
        139 amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        140 & * xdelj(kk)
        +
        141 2300 CONTINUE
        +
        142C
        +
        143 ELSE
        +
        144C
        +
        145C BI-QUADRATIC INTERPOLATION
        +
        146C
        +
        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
        +
        169C
        +
        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
        +
        175C
        +
        176 ENDIF
        +
        177C
        +
        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/w3ft209_8f.html b/w3ft209_8f.html index e53589e7..640c844c 100644 --- a/w3ft209_8f.html +++ b/w3ft209_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft209.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@
        @@ -76,16 +76,22 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        Functions/Subroutines
        -
        -
        w3ft209.f File Reference
        +
        w3ft209.f File Reference
        @@ -94,11 +100,11 @@

        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...
         
        subroutine w3ft209 (alola, alamb, interp)
         Convert a northern hemisphere 1.0 degree lat.,lon.
         

        Detailed Description

        Convert (361,91) grid to (101,81) lambert grid.

        @@ -107,8 +113,8 @@

        Definition in file w3ft209.f.

        Function/Subroutine Documentation

        - -

        ◆ w3ft209()

        + +

        ◆ w3ft209()

        @@ -117,19 +123,19 @@

        subroutine w3ft209 ( real, dimension(iii,jjj)  - ALOLA, + alola, real, dimension(npts)  - ALAMB, + alamb,   - INTERP  + interp  @@ -141,7 +147,7 @@

        +

        Program History Log:

        @@ -159,7 +165,7 @@

        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.
          • +
        • 2. Wind components are not rotated to the 101*81 grid orientation after interpolation. You may use w3fc08() to do this.
        Author
        Ralph Jones
        @@ -175,7 +181,7 @@

        diff --git a/w3ft209_8f.js b/w3ft209_8f.js index 6ecab450..80fac8ba 100644 --- a/w3ft209_8f.js +++ b/w3ft209_8f.js @@ -1,4 +1,4 @@ var w3ft209_8f = [ - [ "w3ft209", "w3ft209_8f.html#a8d2adf2c3f2603ed6555c88d77f0b51b", null ] + [ "w3ft209", "w3ft209_8f.html#a2482ea3acabfb84f5b4277e5d09c2d36", null ] ]; \ No newline at end of file diff --git a/w3ft209_8f_source.html b/w3ft209_8f_source.html index 04aaa554..5ecd2f64 100644 --- a/w3ft209_8f_source.html +++ b/w3ft209_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft209.f Source File @@ -23,10 +23,9 @@

        - - + @@ -34,22 +33,28 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0

        - + +/* @license-end */ + +
        @@ -76,186 +81,194 @@
        - +
        +
        +
        +
        +
        Loading...
        +
        Searching...
        +
        No Matches
        +
        +
        +
        -
        -
        w3ft209.f
        +
        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
        -
        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
        -
        w3ft209
        subroutine w3ft209(ALOLA, ALAMB, INTERP)
        Convert a northern hemisphere 1.0 degree lat.,lon.
        Definition: w3ft209.f:30
        +Go to the documentation of this file.
        1C> @file
        +
        2C> @brief Convert (361,91) grid to (101,81) lambert grid.
        +
        3C> @author Ralph Jones @date 1994-05-18
        +
        4
        +
        5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
        +
        6C> 91 grid to a lambert conformal 101 by 81 awips grib 209.
        +
        7C>
        +
        8C> ### Program History Log:
        +
        9C> Date | Programmer | Comment
        +
        10C> -----|------------|--------
        +
        11C> 1994-05-18 | Ralph Jones | Initial.
        +
        12C>
        +
        13C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
        +
        14C> 32851 point grid. 360 * 181 one degree
        +
        15C> grib grid 3 was flipped, greenwish added
        +
        16C> to right side and cut to 361 * 91.
        +
        17C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
        +
        18C> @param[out] ALAMB 101*81 regional - central us mard double res.
        +
        19C> (lambert conformal). 8181 point grid is awips grid type 209
        +
        20C>
        +
        21C> @note
        +
        22C> - 1. W1 and w2 are used to store sets of constants which are
        +
        23C> reusable for repeated calls to the subroutine. 11 other array
        +
        24C> are saved and reused on the next call.
        +
        25C> - 2. Wind components are not rotated to the 101*81 grid orientation
        +
        26C> after interpolation. You may use w3fc08() to do this.
        +
        27C>
        +
        28C> @author Ralph Jones @date 1994-05-18
        +
        +
        29 SUBROUTINE w3ft209(ALOLA,ALAMB,INTERP)
        +
        30C
        +
        31C
        +
        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)
        +
        40C
        +
        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)
        +
        46C
        +
        47 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
        +
        48 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
        +
        49C
        +
        50 LOGICAL LIN
        +
        51C
        +
        52 SAVE
        +
        53C
        +
        54 DATA iswt /0/
        +
        55 DATA intrpo/99/
        +
        56C
        +
        57 lin = .false.
        +
        58 IF (interp.EQ.1) lin = .true.
        +
        59C
        +
        60 IF (iswt.EQ.1) GO TO 900
        +
        61c 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
        +
        74C
        +
        75 iswt = 1
        +
        76 intrpo = interp
        +
        77 GO TO 1000
        +
        78C
        +
        79C AFTER THE 1ST CALL TO W3FT209 TEST INTERP, IF IT HAS
        +
        80C CHANGED RECOMPUTE SOME CONSTANTS
        +
        81C
        +
        82 900 CONTINUE
        +
        83 IF (interp.EQ.intrpo) GO TO 2100
        +
        84 intrpo = interp
        +
        85C
        +
        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
        +
        96C
        +
        97 IF (lin) GO TO 2100
        +
        98C
        +
        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
        +
        107C
        +
        108 2100 CONTINUE
        +
        109 IF (lin) THEN
        +
        110C
        +
        111C LINEAR INTERPOLATION
        +
        112C
        +
        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
        +
        119C
        +
        120 DO 2300 kk = 1,npts
        +
        121 alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
        +
        122 & * xdelj(kk)
        +
        123 2300 CONTINUE
        +
        124C
        +
        125 ELSE
        +
        126C
        +
        127C QUADRATIC INTERPOLATION
        +
        128C
        +
        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
        +
        151C
        +
        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
        +
        157C
        +
        158 ENDIF
        +
        159C
        +
        160 RETURN
        +
        +
        161 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
        +
        w3ft209
        subroutine w3ft209(alola, alamb, interp)
        Convert a northern hemisphere 1.0 degree lat.,lon.
        Definition w3ft209.f:30
        diff --git a/w3ft210_8f.html b/w3ft210_8f.html index c10b93f6..ce66f54d 100644 --- a/w3ft210_8f.html +++ b/w3ft210_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft210.f File Reference @@ -23,10 +23,9 @@
        - - + @@ -34,21 +33,22 @@
        -
        NCEPLIBS-w3emc -  2.11.0 +
        +
        NCEPLIBS-w3emc 2.11.0
        - + +/* @license-end */ +
        @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft210.f File Reference
    +
    w3ft210.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft210 (alola, amerc, interp)
     Convert a northern hemisphere 1.0 degree lat.,lon.
     

    Detailed Description

    Convert (361,91) grid to (25,25) mercator grid.

    @@ -107,8 +113,8 @@

    Definition in file w3ft210.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft210()

    + +

    ◆ w3ft210()

    @@ -117,19 +123,19 @@

    subroutine w3ft210 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - AMERC, + amerc,   - INTERP  + interp  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -174,7 +180,7 @@

    diff --git a/w3ft210_8f.js b/w3ft210_8f.js index 6f5f0798..ede3838e 100644 --- a/w3ft210_8f.js +++ b/w3ft210_8f.js @@ -1,4 +1,4 @@ var w3ft210_8f = [ - [ "w3ft210", "w3ft210_8f.html#a3803de9cbf2932eb2aa3b36ed8fef355", null ] + [ "w3ft210", "w3ft210_8f.html#a262a8baf12c888d64c696bc3ba05be04", null ] ]; \ No newline at end of file diff --git a/w3ft210_8f_source.html b/w3ft210_8f_source.html index 2f659115..58b32bc7 100644 --- a/w3ft210_8f_source.html +++ b/w3ft210_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft210.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,201 +81,209 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft210.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert (361,91) grid to (25,25) mercator grid.
    +
    3C> @author Ralph Jones @date 1993-10-19
    +
    4
    +
    5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6C> 91 grid to a regional - puerto rico (mercator) 25*25 awips 210
    +
    7C> grid.
    +
    8C>
    +
    9C> ### Program History Log:
    +
    10C> Date | Programmer | Comment
    +
    11C> -----|------------|--------
    +
    12C> 1993-10-19 | Ralph Jones | Initial.
    +
    13
    +
    14C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    15C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    16C> to right side and cut to 361 * 91.
    +
    17C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18C> @param[out] AMERC 25*25 grid of northern mercator 625 point grid is awips grid type 210
    +
    19C>
    +
    20C> @note
    +
    21C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22C> reusable for repeated calls to the subroutine. 20 other array
    +
    23C> are saved and reused on the next call.
    +
    24C>
    +
    25C> @author Ralph Jones @date 1993-10-19
    +
    +
    26 SUBROUTINE w3ft210(ALOLA,AMERC,INTERP)
    +
    27C
    +
    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)
    +
    34C
    +
    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)
    +
    42C
    +
    43 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    44 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    45C
    +
    46 LOGICAL LIN
    +
    47C
    +
    48 SAVE
    +
    49C
    +
    50 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    51C
    +
    52C DATA DEGPR /57.2957795/
    +
    53 DATA rerth /6.3712e+6/
    +
    54 DATA intrpo/99/
    +
    55 DATA iswt /0/
    +
    56C
    +
    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.
    +
    64C
    +
    65 IF (iswt.EQ.1) GO TO 900
    +
    66C
    +
    67 deg = 1.0
    +
    68C
    +
    69C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
    +
    70C
    +
    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
    +
    76C
    +
    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
    +
    81C
    +
    82 DO 300 kk = 1,npts
    +
    83 wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
    +
    84 300 CONTINUE
    +
    85C
    +
    86 DO 400 kk = 1,npts
    +
    87 w1(kk) = wlon(kk) + 1.0
    +
    88 w2(kk) = xlat(kk) + 1.0
    +
    89 400 CONTINUE
    +
    90C
    +
    91 iswt = 1
    +
    92 intrpo = interp
    +
    93 GO TO 1000
    +
    94C
    +
    95C AFTER THE 1ST CALL TO W3FT210 TEST INTERP, IF IT HAS
    +
    96C CHANGED RECOMPUTE SOME CONSTANTS
    +
    97C
    +
    98 900 CONTINUE
    +
    99 IF (interp.EQ.intrpo) GO TO 2100
    +
    100 intrpo = interp
    +
    101C
    +
    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
    +
    112C
    +
    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
    +
    123C
    +
    124 2100 CONTINUE
    +
    125 IF (lin) THEN
    +
    126C
    +
    127C LINEAR INTERPOLATION
    +
    128C
    +
    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
    +
    135C
    +
    136 DO 2300 kk = 1,npts
    +
    137 amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    138 & * xdelj(kk)
    +
    139 2300 CONTINUE
    +
    140C
    +
    141 ELSE
    +
    142C
    +
    143C QUADRATIC INTERPOLATION
    +
    144C
    +
    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
    +
    167C
    +
    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
    +
    173C
    +
    174 ENDIF
    +
    175C
    +
    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/w3ft211_8f.html b/w3ft211_8f.html index 00b95bed..2360fb68 100644 --- a/w3ft211_8f.html +++ b/w3ft211_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft211.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft211.f File Reference
    +
    w3ft211.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft211 (alola, alamb, interp)
     Convert a northern hemisphere 1.0 degree lat.,lon.
     

    Detailed Description

    Convert (361,91) grid to (93,65) lambert grid.

    @@ -107,8 +113,8 @@

    Definition in file w3ft211.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft211()

    + +

    ◆ w3ft211()

    @@ -117,19 +123,19 @@

    subroutine w3ft211 ( real, dimension(iii,jjj)  - ALOLA, + alola, real, dimension(npts)  - ALAMB, + alamb,   - INTERP  + interp  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -159,7 +165,7 @@

    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.
      • +
    • 2. Wind components are not rotated to the 93*65 grid orientation after interpolation. You may use w3fc08() to do this.
    @@ -173,7 +179,7 @@

    diff --git a/w3ft211_8f.js b/w3ft211_8f.js index 299f570c..6347bca2 100644 --- a/w3ft211_8f.js +++ b/w3ft211_8f.js @@ -1,4 +1,4 @@ var w3ft211_8f = [ - [ "w3ft211", "w3ft211_8f.html#a353f8903a8cbe06aa931ab815e317708", null ] + [ "w3ft211", "w3ft211_8f.html#aee78a998ceaf5a96225189c7e3be7262", null ] ]; \ No newline at end of file diff --git a/w3ft211_8f_source.html b/w3ft211_8f_source.html index 04c6464f..a67673e4 100644 --- a/w3ft211_8f_source.html +++ b/w3ft211_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft211.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,184 +81,192 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft211.f
    +
    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
    -
    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
    -
    w3ft211
    subroutine w3ft211(ALOLA, ALAMB, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft211.f:28
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert (361,91) grid to (93,65) lambert grid.
    +
    3C> @author Ralph Jones @date 1994-05-18
    +
    4
    +
    5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6C> 91 grid to a lambert conformal 93 by 65 awips grib 211.
    +
    7C>
    +
    8C> ### Program History Log:
    +
    9C> Date | Programmer | Comment
    +
    10C> -----|------------|--------
    +
    11C> 1994-05-18 | Ralph Jones | Initial.
    +
    12C>
    +
    13C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    14C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    15C> to right side and cut to 361 * 91.
    +
    16C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    17C> @param[out] ALAMB 93*65 regional - conus (lambert conformal). 6045 point grid
    +
    18C> is awips grid type 211
    +
    19C>
    +
    20C> @note
    +
    21C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22C> reusable for repeated calls to the subroutine. 11 other array
    +
    23C> are saved and reused on the next call.
    +
    24C> - 2. Wind components are not rotated to the 93*65 grid orientation
    +
    25C> after interpolation. You may use w3fc08() to do this.
    +
    26C>
    +
    +
    27 SUBROUTINE w3ft211(ALOLA,ALAMB,INTERP)
    +
    28C
    +
    29C
    +
    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)
    +
    38C
    +
    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)
    +
    44C
    +
    45 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47C
    +
    48 LOGICAL LIN
    +
    49C
    +
    50 SAVE
    +
    51C
    +
    52 DATA iswt /0/
    +
    53 DATA intrpo/99/
    +
    54C
    +
    55 lin = .false.
    +
    56 IF (interp.EQ.1) lin = .true.
    +
    57C
    +
    58 IF (iswt.EQ.1) GO TO 900
    +
    59c 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
    +
    72C
    +
    73 iswt = 1
    +
    74 intrpo = interp
    +
    75 GO TO 1000
    +
    76C
    +
    77C AFTER THE 1ST CALL TO W3FT211 TEST INTERP, IF IT HAS
    +
    78C CHANGED RECOMPUTE SOME CONSTANTS
    +
    79C
    +
    80 900 CONTINUE
    +
    81 IF (interp.EQ.intrpo) GO TO 2100
    +
    82 intrpo = interp
    +
    83C
    +
    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
    +
    94C
    +
    95 IF (lin) GO TO 2100
    +
    96C
    +
    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
    +
    105C
    +
    106 2100 CONTINUE
    +
    107 IF (lin) THEN
    +
    108C
    +
    109C LINEAR INTERPOLATION
    +
    110C
    +
    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
    +
    117C
    +
    118 DO 2300 kk = 1,npts
    +
    119 alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    120 & * xdelj(kk)
    +
    121 2300 CONTINUE
    +
    122C
    +
    123 ELSE
    +
    124C
    +
    125C QUADRATIC INTERPOLATION
    +
    126C
    +
    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
    +
    149C
    +
    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
    +
    155C
    +
    156 ENDIF
    +
    157C
    +
    158 RETURN
    +
    +
    159 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
    +
    w3ft211
    subroutine w3ft211(alola, alamb, interp)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition w3ft211.f:28
    diff --git a/w3ft212_8f.html b/w3ft212_8f.html index 031bf617..947db2af 100644 --- a/w3ft212_8f.html +++ b/w3ft212_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft212.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft212.f File Reference
    +
    w3ft212.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft212 (alola, alamb, interp)
     Convert a northern hemisphere 1.0 degree lat.,lon.
     

    Detailed Description

    Convert (361,91) grid to (185,129) lambert grid.

    @@ -107,8 +113,8 @@

    Definition in file w3ft212.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft212()

    + +

    ◆ w3ft212()

    @@ -117,19 +123,19 @@

    subroutine w3ft212 ( real, dimension(iii,jjj)  - ALOLA, + alola, real, dimension(npts)  - ALAMB, + alamb,   - INTERP  + interp  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -159,7 +165,7 @@

    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.
      • +
    • 2. Wind components are not rotated to the 185*129 grid orientation after interpolation. You may use w3fc08() to do this.
    Author
    Ralph Jones
    @@ -175,7 +181,7 @@

    diff --git a/w3ft212_8f.js b/w3ft212_8f.js index 81a9bacf..7a5b46ec 100644 --- a/w3ft212_8f.js +++ b/w3ft212_8f.js @@ -1,4 +1,4 @@ var w3ft212_8f = [ - [ "w3ft212", "w3ft212_8f.html#a80630575cad8c3e8743fb7b161d2b18e", null ] + [ "w3ft212", "w3ft212_8f.html#af275f1336203bfcbb465545daaa39fe5", null ] ]; \ No newline at end of file diff --git a/w3ft212_8f_source.html b/w3ft212_8f_source.html index 26e169da..a2da36d2 100644 --- a/w3ft212_8f_source.html +++ b/w3ft212_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft212.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,185 +81,193 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft212.f
    +
    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
    -
    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
    -
    w3ft212
    subroutine w3ft212(ALOLA, ALAMB, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft212.f:29
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert (361,91) grid to (185,129) lambert grid
    +
    3C> @author Ralph Jones @date 1994-05-18
    +
    4
    +
    5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6C> 91 grid to a lambert conformal 185 by 129 awips grib 212.
    +
    7C>
    +
    8C> ### Program History Log:
    +
    9C> Date | Programmer | Comment
    +
    10C> -----|------------|--------
    +
    11C> 1994-05-18 | Ralph Jones | Initial.
    +
    12C>
    +
    13C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    14C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    15C> to right side and cut to 361 * 91.
    +
    16C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    17C> @param[out] ALAMB 185*129 regional - conus double resolution
    +
    18C> (lambert conformal). 23865 point grid is awips grid type 212
    +
    19C>
    +
    20C> @note
    +
    21C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22C> reusable for repeated calls to the subroutine. 11 other array
    +
    23C> are saved and reused on the next call.
    +
    24C> - 2. Wind components are not rotated to the 185*129 grid orientation
    +
    25C> after interpolation. You may use w3fc08() to do this.
    +
    26C>
    +
    27C> @author Ralph Jones @date 1994-05-18
    +
    +
    28 SUBROUTINE w3ft212(ALOLA,ALAMB,INTERP)
    +
    29C
    +
    30C
    +
    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)
    +
    39C
    +
    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)
    +
    45C
    +
    46 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    47 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    48C
    +
    49 LOGICAL LIN
    +
    50C
    +
    51 SAVE
    +
    52C
    +
    53 DATA iswt /0/
    +
    54 DATA intrpo/99/
    +
    55C
    +
    56 lin = .false.
    +
    57 IF (interp.EQ.1) lin = .true.
    +
    58C
    +
    59 IF (iswt.EQ.1) GO TO 900
    +
    60c 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
    +
    73C
    +
    74 iswt = 1
    +
    75 intrpo = interp
    +
    76 GO TO 1000
    +
    77C
    +
    78C AFTER THE 1ST CALL TO W3FT212 TEST INTERP, IF IT HAS
    +
    79C CHANGED RECOMPUTE SOME CONSTANTS
    +
    80C
    +
    81 900 CONTINUE
    +
    82 IF (interp.EQ.intrpo) GO TO 2100
    +
    83 intrpo = interp
    +
    84C
    +
    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
    +
    95C
    +
    96 IF (lin) GO TO 2100
    +
    97C
    +
    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
    +
    106C
    +
    107 2100 CONTINUE
    +
    108 IF (lin) THEN
    +
    109C
    +
    110C LINEAR INTERPOLATION
    +
    111C
    +
    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
    +
    118C
    +
    119 DO 2300 kk = 1,npts
    +
    120 alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    121 & * xdelj(kk)
    +
    122 2300 CONTINUE
    +
    123C
    +
    124 ELSE
    +
    125C
    +
    126C QUADRATIC INTERPOLATION
    +
    127C
    +
    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
    +
    150C
    +
    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
    +
    156C
    +
    157 ENDIF
    +
    158C
    +
    159 RETURN
    +
    +
    160 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
    +
    w3ft212
    subroutine w3ft212(alola, alamb, interp)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition w3ft212.f:29
    diff --git a/w3ft213_8f.html b/w3ft213_8f.html index 831d4877..3183f002 100644 --- a/w3ft213_8f.html +++ b/w3ft213_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft213.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft213.f File Reference
    +
    w3ft213.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft213 (alola, apola, interp)
     Convert a northern hemisphere 1.0 degree lat.,lon.
     

    Detailed Description

    Convert (361,91) grid to (129,85) n.

    @@ -107,8 +113,8 @@

    Definition in file w3ft213.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft213()

    + +

    ◆ w3ft213()

    @@ -117,19 +123,19 @@

    subroutine w3ft213 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -159,7 +165,7 @@

    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.
      • +
    • 2. Wind components are not rotated to the 129*85 grid orientation after interpolation. You may use w3fc08() to do this.
    Author
    Ralph Jones
    @@ -175,7 +181,7 @@

    diff --git a/w3ft213_8f.js b/w3ft213_8f.js index b504601d..6130328f 100644 --- a/w3ft213_8f.js +++ b/w3ft213_8f.js @@ -1,4 +1,4 @@ var w3ft213_8f = [ - [ "w3ft213", "w3ft213_8f.html#a1de78ace88fde1b28429425c20838344", null ] + [ "w3ft213", "w3ft213_8f.html#afd9acc707a0050ee144f922d2fd7f561", null ] ]; \ No newline at end of file diff --git a/w3ft213_8f_source.html b/w3ft213_8f_source.html index cb144b45..d4cf0e20 100644 --- a/w3ft213_8f_source.html +++ b/w3ft213_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft213.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,267 +81,275 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft213.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert (361,91) grid to (129,85) n. hemi. grid
    +
    3C> @author Ralph Jones @date 1993-10-23
    +
    4
    +
    5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6C> 91 grid to a polar stereographic 129 by 85 grid. The polar
    +
    7C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8C> length is 95.25 km. and the oriention is 105 deg. w.
    +
    9C> awips grid 213 national - conus - double resolution
    +
    10C>
    +
    11C> ### Program History Log:
    +
    12C> Date | Programmer | Comment
    +
    13C> -----|------------|--------
    +
    14C> 1993-10-23 | Ralph Jones | Initial.
    +
    15C>
    +
    16C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    17C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18C> to right side and cut to 361 * 91.
    +
    19C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20C> @param[out] APOLA 129*85 grid of northern hemisphere. 10965 point grid is
    +
    21C> awips grid type 213
    +
    22C> @note
    +
    23C> - 1. W1 and w2 are used to store sets of constants which are
    +
    24C> reusable for repeated calls to the subroutine.
    +
    25C> - 2. Wind components are not rotated to the 129*85 grid orientation
    +
    26C> after interpolation. You may use w3fc08() to do this.
    +
    27C>
    +
    28C> @author Ralph Jones @date 1993-10-23
    +
    +
    29 SUBROUTINE w3ft213(ALOLA,APOLA,INTERP)
    +
    30C
    +
    31 parameter(npts=10965,ii=129,jj=85)
    +
    32 parameter(orient=105.0,ipole=65,jpole=89)
    +
    33 parameter(xmesh=95.250)
    +
    34C
    +
    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)
    +
    42C
    +
    43 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    44 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    45C
    +
    46 LOGICAL LIN
    +
    47C
    +
    48 SAVE
    +
    49C
    +
    50 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    51C
    +
    52 DATA degprd/57.2957795/
    +
    53 DATA earthr/6371.2/
    +
    54 DATA intrpo/99/
    +
    55 DATA iswt /0/
    +
    56C
    +
    57 lin = .false.
    +
    58 IF (interp.EQ.1) lin = .true.
    +
    59C
    +
    60 IF (iswt.EQ.1) GO TO 900
    +
    61C
    +
    62 deg = 1.0
    +
    63 gi2 = (1.86603 * earthr) / xmesh
    +
    64 gi2 = gi2 * gi2
    +
    65C
    +
    66C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    67C
    +
    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
    +
    74C
    +
    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
    +
    80C
    +
    81 DO 300 kk = 1,npts
    +
    82 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    83 300 CONTINUE
    +
    84C
    +
    85 DO 400 kk = 1,npts
    +
    86 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    87 400 CONTINUE
    +
    88C
    +
    89 DO 500 kk = 1,npts
    +
    90 wlon(kk) = 270.0 + orient - angle(kk)
    +
    91 500 CONTINUE
    +
    92C
    +
    93 DO 600 kk = 1,npts
    +
    94 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    95 600 CONTINUE
    +
    96C
    +
    97 DO 700 kk = 1,npts
    +
    98 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    99 700 CONTINUE
    +
    100C
    +
    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
    +
    105C
    +
    106 iswt = 1
    +
    107 intrpo = interp
    +
    108 GO TO 1000
    +
    109C
    +
    110C AFTER THE 1ST CALL TO W3FT213 TEST INTERP, IF IT HAS
    +
    111C CHANGED RECOMPUTE SOME CONSTANTS
    +
    112C
    +
    113 900 CONTINUE
    +
    114 IF (interp.EQ.intrpo) GO TO 2100
    +
    115 intrpo = interp
    +
    116C
    +
    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
    +
    127C
    +
    128 IF (lin) GO TO 1400
    +
    129C
    +
    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
    +
    138C
    +
    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
    +
    148C
    +
    149 1400 CONTINUE
    +
    150C
    +
    151 IF (lin) GO TO 1700
    +
    152C
    +
    153 DO 1500 kk = 1,npts
    +
    154 IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    155 1500 CONTINUE
    +
    156C
    +
    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
    +
    163C
    +
    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
    +
    171C
    +
    172C LINEAR INTERPOLATION
    +
    173C
    +
    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
    +
    180C
    +
    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
    +
    189C
    +
    190 2100 CONTINUE
    +
    191 IF (lin) THEN
    +
    192C
    +
    193C LINEAR INTERPOLATION
    +
    194C
    +
    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
    +
    201C
    +
    202 DO 2300 kk = 1,npts
    +
    203 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    204 & * xdelj(kk)
    +
    205 2300 CONTINUE
    +
    206C
    +
    207 ELSE
    +
    208C
    +
    209C QUADRATIC INTERPOLATION
    +
    210C
    +
    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
    +
    233C
    +
    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
    +
    239C
    +
    240 ENDIF
    +
    241C
    +
    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/w3ft214_8f.html b/w3ft214_8f.html index f9f1a3d3..a09ecadd 100644 --- a/w3ft214_8f.html +++ b/w3ft214_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft214.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft214.f File Reference
    +
    w3ft214.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft214 (alola, apola, interp)
     Convert a northern hemisphere 1.0 degree lat.,lon.
     

    Detailed Description

    Convert (361,91) grid to (97,69) n.

    @@ -107,8 +113,8 @@

    Definition in file w3ft214.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft214()

    + +

    ◆ w3ft214()

    @@ -117,19 +123,19 @@

    subroutine w3ft214 ( real, dimension(361,91)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -175,7 +181,7 @@

    diff --git a/w3ft214_8f.js b/w3ft214_8f.js index 463bc1d8..06afeefa 100644 --- a/w3ft214_8f.js +++ b/w3ft214_8f.js @@ -1,4 +1,4 @@ var w3ft214_8f = [ - [ "w3ft214", "w3ft214_8f.html#a87c1f4b3ef6dccfe37b0a288d2143848", null ] + [ "w3ft214", "w3ft214_8f.html#a6f956d8742bb119f8ebf3e1eeb95d78b", null ] ]; \ No newline at end of file diff --git a/w3ft214_8f_source.html b/w3ft214_8f_source.html index abe0ffc0..739bbf50 100644 --- a/w3ft214_8f_source.html +++ b/w3ft214_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft214.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,268 +81,276 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft214.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert (361,91) grid to (97,69) n. hemi. grid
    +
    3C> @author Ralph Jones @date 1993-10-19
    +
    4
    +
    5C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6C> 91 grid to a polar stereographic 97 by 69 grid. The polar
    +
    7C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8C> length is 47.625 km. and the oriention is 150 deg. w.
    +
    9C> awips grid 214 regional - alaska - double resolution
    +
    10C>
    +
    11C> ### Program History Log:
    +
    12C> Date | Programmer | Comment
    +
    13C> -----|------------|--------
    +
    14C> 1993-10-19 | Ralph Jones | Initial.
    +
    15C>
    +
    16C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    17C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18C> to right side and cut to 361 * 91.
    +
    19C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20C> @param[out] APOLA 97*69 grid of northern hemisphere. 6693 point grid is
    +
    21C> awips grid type 214
    +
    22C>
    +
    23C> @note
    +
    24C> - 1. W1 and w2 are used to store sets of constants which are
    +
    25C> reusable for repeated calls to the subroutine.
    +
    26C> - 2. Wind components are not rotated to the 97*69 grid orientation
    +
    27C> after interpolation. you may use w3fc08 to do this.
    +
    28C>
    +
    29C> @author Ralph Jones @date 1993-10-19
    +
    +
    30 SUBROUTINE w3ft214(ALOLA,APOLA,INTERP)
    +
    31C
    +
    32 parameter(npts=6693,ii=97,jj=69)
    +
    33 parameter(orient=150.0,ipole=49,jpole=101)
    +
    34 parameter(xmesh=47.625)
    +
    35C
    +
    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)
    +
    43C
    +
    44 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    45 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    46C
    +
    47 LOGICAL LIN
    +
    48C
    +
    49 SAVE
    +
    50C
    +
    51 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    52C
    +
    53 DATA degprd/57.2957795/
    +
    54 DATA earthr/6371.2/
    +
    55 DATA intrpo/99/
    +
    56 DATA iswt /0/
    +
    57C
    +
    58 lin = .false.
    +
    59 IF (interp.EQ.1) lin = .true.
    +
    60C
    +
    61 IF (iswt.EQ.1) GO TO 900
    +
    62C
    +
    63 deg = 1.0
    +
    64 gi2 = (1.86603 * earthr) / xmesh
    +
    65 gi2 = gi2 * gi2
    +
    66C
    +
    67C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    68C
    +
    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
    +
    75C
    +
    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
    +
    81C
    +
    82 DO 300 kk = 1,npts
    +
    83 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    84 300 CONTINUE
    +
    85C
    +
    86 DO 400 kk = 1,npts
    +
    87 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    88 400 CONTINUE
    +
    89C
    +
    90 DO 500 kk = 1,npts
    +
    91 wlon(kk) = 270.0 + orient - angle(kk)
    +
    92 500 CONTINUE
    +
    93C
    +
    94 DO 600 kk = 1,npts
    +
    95 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    96 600 CONTINUE
    +
    97C
    +
    98 DO 700 kk = 1,npts
    +
    99 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    100 700 CONTINUE
    +
    101C
    +
    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
    +
    106C
    +
    107 iswt = 1
    +
    108 intrpo = interp
    +
    109 GO TO 1000
    +
    110C
    +
    111C AFTER THE 1ST CALL TO W3FT214 TEST INTERP, IF IT HAS
    +
    112C CHANGED RECOMPUTE SOME CONSTANTS
    +
    113C
    +
    114 900 CONTINUE
    +
    115 IF (interp.EQ.intrpo) GO TO 2100
    +
    116 intrpo = interp
    +
    117C
    +
    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
    +
    128C
    +
    129 IF (lin) GO TO 1400
    +
    130C
    +
    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
    +
    139C
    +
    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
    +
    149C
    +
    150 1400 CONTINUE
    +
    151C
    +
    152 IF (lin) GO TO 1700
    +
    153C
    +
    154 DO 1500 kk = 1,npts
    +
    155 IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    156 1500 CONTINUE
    +
    157C
    +
    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
    +
    164C
    +
    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
    +
    172C
    +
    173C LINEAR INTERPOLATION
    +
    174C
    +
    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
    +
    181C
    +
    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
    +
    190C
    +
    191 2100 CONTINUE
    +
    192 IF (lin) THEN
    +
    193C
    +
    194C LINEAR INTERPOLATION
    +
    195C
    +
    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
    +
    202C
    +
    203 DO 2300 kk = 1,npts
    +
    204 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    205 & * xdelj(kk)
    +
    206 2300 CONTINUE
    +
    207C
    +
    208 ELSE
    +
    209C
    +
    210C QUADRATIC INTERPOLATION
    +
    211C
    +
    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
    +
    234C
    +
    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
    +
    240C
    +
    241 ENDIF
    +
    242C
    +
    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/w3ft21_8f.html b/w3ft21_8f.html index 0c8cd1a8..95c901a3 100644 --- a/w3ft21_8f.html +++ b/w3ft21_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft21.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft21.f File Reference
    +
    w3ft21.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft21 (fln, gn, pln, eps, fl, work, trigs, l1, l2, i2)
     Computes 2.5 x 2.5 n.
     

    Detailed Description

    Computes 2.5 x 2.5 n.

    @@ -107,8 +113,8 @@

    Definition in file w3ft21.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft21()

    + +

    ◆ w3ft21()

    @@ -117,61 +123,61 @@

    subroutine w3ft21 ( complex, dimension (31,31)  - FLN, + fln, real, dimension (145,37)  - GN, + gn, real, dimension (32,31)  - PLN, + pln, real, dimension (992)  - EPS, + eps, complex, dimension (31)  - FL, + fl, real, dimension (144)  - WORK, + work, real, dimension (216)  - TRIGS, + trigs,   - L1, + l1,   - L2, + l2,   - I2  + i2  @@ -182,8 +188,8 @@

    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.

    -

    +

    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:

    @@ -199,8 +205,8 @@

    - - + + @@ -208,7 +214,7 @@

    [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]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
    -
    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.
    +
    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
    @@ -222,7 +228,7 @@

    diff --git a/w3ft21_8f.js b/w3ft21_8f.js index 02b066a4..a9cdcf51 100644 --- a/w3ft21_8f.js +++ b/w3ft21_8f.js @@ -1,4 +1,4 @@ var w3ft21_8f = [ - [ "w3ft21", "w3ft21_8f.html#a681f756a8ebbb0bed83c216be180c4ae", null ] + [ "w3ft21", "w3ft21_8f.html#a918182b6d42437b6657cf5d23d7d9240", null ] ]; \ No newline at end of file diff --git a/w3ft21_8f_source.html b/w3ft21_8f_source.html index 74a847e2..b96e00c2 100644 --- a/w3ft21_8f_source.html +++ b/w3ft21_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft21.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,110 +81,119 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft21.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes 2.5 x 2.5 n. hemi. grid-scaler.
    +
    3C> @author Ralph Jones @date 1981-11-19
    +
    4
    +
    5C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7C> representing a scalar field. Special version of w3ft08() which
    +
    8C> gives programmer more control of how many waves are summed
    +
    9C> and how many points in each wave. A programmer can simulate
    +
    10C> 24-mode, 12-mode, etc.
    +
    11C>
    +
    12C> ### Program History Log:
    +
    13C> Date | Programmer | Comment
    +
    14C> -----|------------|--------
    +
    15C> 1981-11-19 | Ralph Jones | Initial.
    +
    16C> 1984-06-01 | Ralph Jones | Change to ibm vs fortran.
    +
    17C>
    +
    18C> @param[in] FLN 961 complex coeff.
    +
    19C> @param[in] PLN 992 real space for legendre polynomials
    +
    20C> @param[in] EPS 992 real space for coeffs. used in computing pln.
    +
    21C> @param[in] FL 31 complex space for fourier coeff.
    +
    22C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    23C> @param[in] TRIGS 216 precomputed trig funcs, used in w3ft12(), computed by
    +
    24C> w3fa13()
    +
    25C> @param[in] L1 Starting wave number
    +
    26C> @param[in] L2 Ending wave number
    +
    27C> @param[in] I2 Mode of spectral coefficients
    +
    28C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    29C>
    +
    30C> @note This subroutine was optimized to run in a small amount of
    +
    31C> memory, it is not optimized for speed, 70 percent of the time is
    +
    32C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    33C> the legendre polynomials are constant they need to be computed
    +
    34C> only once in a program. By moving w3fa12() to the main program and
    +
    35C> computing pln as a (32,31,37) array and changing this subroutine
    +
    36C> to use pln as a three dimension array you can cut the running time
    +
    37C> 70 percent.
    +
    38C>
    +
    39C> @author Ralph Jones @date 1981-11-19
    +
    +
    40 SUBROUTINE w3ft21(FLN,GN,PLN,EPS,FL,WORK,TRIGS,L1,L2,I2)
    +
    41C
    +
    42 COMPLEX FL (31)
    +
    43 COMPLEX FLN (31,31)
    +
    44C
    +
    45 REAL COLRA
    +
    46 REAL EPS (992)
    +
    47C
    +
    48 REAL GN (145,37)
    +
    49 REAL PLN (32,31)
    +
    50 REAL TRIGS (216)
    +
    51 REAL WORK (144)
    +
    52C
    +
    53 SAVE
    +
    54C
    +
    55 DATA pi /3.14159265/
    +
    56C
    +
    57 drad = 2.5 * pi / 180.0
    +
    58C
    +
    59 k1 = l1 + 1
    +
    60 k2 = l2 + 1
    +
    61 m2 = i2 + 1
    +
    62C
    +
    63 DO 400 lat = 1,37
    +
    64 latn = 38 - lat
    +
    65 colra = (lat-1) * drad
    +
    66 CALL w3fa12 (pln, colra, 30 ,eps)
    +
    67C
    +
    68 DO 100 l = 1, 31
    +
    69 fl(l) = (0.,0.)
    +
    70 100 CONTINUE
    +
    71C
    +
    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
    +
    77C
    +
    78 300 CONTINUE
    +
    79C
    +
    80 CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    81C
    +
    82 400 CONTINUE
    +
    83C
    +
    84 RETURN
    +
    +
    85 END
    +
    w3fa12
    subroutine w3fa12(pln, colrad, jcap, eps)
    Subroutine computes legendre polynomials at a given latitude.
    Definition w3fa12.f:21
    +
    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/w3ft26_8f.html b/w3ft26_8f.html index 324e6f20..61d742b1 100644 --- a/w3ft26_8f.html +++ b/w3ft26_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft26.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft26.f File Reference
    +
    w3ft26.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft26 (mapnum, fld, hi, igpts, nstop)
     Converts a 360x181 1-degree grid into a nh or sh 360x91 1-degree grid.
     

    Detailed Description

    Creates wafs 1.25x1.25 thinned grids.

    @@ -107,8 +113,8 @@

    Definition in file w3ft26.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft26()

    + +

    ◆ w3ft26()

    @@ -117,31 +123,31 @@

    subroutine w3ft26 ( integer  - MAPNUM, + mapnum, real, dimension (360,181)  - FLD, + fld, real, dimension (3447)  - HI, + hi, integer  - IGPTS, + igpts, integer  - NSTOP  + nstop  @@ -153,7 +159,7 @@

    +

    Program History Log:

    @@ -163,7 +169,7 @@

    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().

    +

    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
    @@ -187,7 +193,7 @@

    diff --git a/w3ft26_8f.js b/w3ft26_8f.js index 531fa1c5..be18b182 100644 --- a/w3ft26_8f.js +++ b/w3ft26_8f.js @@ -1,4 +1,4 @@ var w3ft26_8f = [ - [ "w3ft26", "w3ft26_8f.html#a584757389b1cf4707abb4cadb47850ab", null ] + [ "w3ft26", "w3ft26_8f.html#a225e7f8bb24f8c2878453792a88cee97", null ] ]; \ No newline at end of file diff --git a/w3ft26_8f_source.html b/w3ft26_8f_source.html index 986c8a8e..f7b40324 100644 --- a/w3ft26_8f_source.html +++ b/w3ft26_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft26.f Source File @@ -23,10 +23,9 @@

    [in]MAPNUMNumber of grid, 37 to 44.
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,143 +81,151 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft26.f
    +
    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
    -
    w3ft16
    subroutine w3ft16(ALOLA, BTHIN, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft16.f:24
    -
    w3ft17
    subroutine w3ft17(ALOLA, BTHIN, INTERP)
    Convert a southern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft17.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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Creates wafs 1.25x1.25 thinned grids.
    +
    3C> @author Farley @date 1993-04-28
    +
    4
    +
    5C> Converts a 360x181 1-degree grid into a nh or sh
    +
    6C> 360x91 1-degree grid. This nh/sh grid is flipped for grib
    +
    7C> purposes and then converted to the desired 1.25 degree
    +
    8C> wafs (quadrant) thinned grid.
    +
    9C>
    +
    10C> ### Program History Log:
    +
    11C> Date | Programmer | Comment
    +
    12C> -----|------------|--------
    +
    13C> 1993-04-28 | FARLEY | Original author.
    +
    14C> 1994-04-01 | Ralph Jones | Corrections for 1 deg. displacement of grids and
    +
    15C> error in flipping of southern hemisphere.
    +
    16C> 1994-05-05 | Ralph Jones | Replace subr. w3ft01() with w3ft16() and w3ft17().
    +
    17C> 1994-06-04 | Ralph Jones | Change subroutine name from wfstrp to w3ft26().
    +
    18C>
    +
    19C> @param[in] MAPNUM Number of grid, 37 to 44.
    +
    20C> @param[in] FLD Northern or southern hem. spectral field.
    +
    21C> @param[in] HI Interpolated wafs field (3447 points)
    +
    22C> @param[in] IGPTS Number of points in interpolated field
    +
    23C> @param[in] NSTOP 24, when mapnum .ne. 37 thru 44
    +
    24C>
    +
    25C> @author Farley @date 1993-04-28
    +
    +
    26 SUBROUTINE w3ft26 (MAPNUM,FLD,HI,IGPTS,NSTOP)
    +
    27C
    +
    28 REAL FLD (360,181)
    +
    29 REAL HALF (360,91)
    +
    30 REAL HI (3447)
    +
    31 REAL QUAD (95,91)
    +
    32C
    +
    33 INTEGER IGPTS
    +
    34 INTEGER MAPNUM
    +
    35 INTEGER NSTOP
    +
    36C
    +
    37 SAVE
    +
    38C
    +
    39C PRINT *,' MADE IT TO W3FT26'
    +
    40 nstop = 0
    +
    41C
    +
    42C 1.0 CUT FULL GRID TO DESIRED HEMISPHERE.
    +
    43C
    +
    44C 1.1 EXTRACT THE NORTHERN HEMISPHERE AND FLIP IT.
    +
    45C
    +
    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
    +
    53C
    +
    54C 1.2 EXTRACT THE SOUTHERN HEMISPHERE AND FLIP IT.
    +
    55C
    +
    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
    +
    64C
    +
    65C 2.0 SELECT THE QUADRANT DESIRED.
    +
    66C
    +
    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
    +
    76C
    +
    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
    +
    83C
    +
    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
    +
    90C
    +
    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
    +
    97C
    +
    98 ELSE
    +
    99 print *,' W3FT26 - MAP NOT TYPE 37-44'
    +
    100 igpts = 0
    +
    101 nstop = 24
    +
    102 RETURN
    +
    103 ENDIF
    +
    104C
    +
    105 interp = 0
    +
    106C
    +
    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
    +
    113C
    +
    114 igpts = 3447
    +
    115C
    +
    116 RETURN
    +
    +
    117 END
    +
    w3ft16
    subroutine w3ft16(alola, bthin, interp)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition w3ft16.f:24
    +
    w3ft17
    subroutine w3ft17(alola, bthin, interp)
    Convert a southern hemisphere 1.0 degree lat.,lon.
    Definition w3ft17.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/w3ft32_8f.html b/w3ft32_8f.html index 656a8571..93d1884a 100644 --- a/w3ft32_8f.html +++ b/w3ft32_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft32.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft32.f File Reference
    +
    w3ft32.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft32 (field, mapin, data, mapout, interp, ier)
     Interpolate scalar quantity from any given nmc field (in office note 84) to any other field.
     

    Detailed Description

    General interpolator between nmc flds.

    @@ -107,8 +113,8 @@

    Definition in file w3ft32.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft32()

    + +

    ◆ w3ft32()

    @@ -117,37 +123,37 @@

    subroutine w3ft32 ( real, dimension(*)  - FIELD, + field,   - MAPIN, + mapin, real, dimension(*)  - DATA, + data,   - MAPOUT, + mapout,   - INTERP, + interp,   - IER  + ier  @@ -159,7 +165,7 @@

    +

    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
    @@ -205,7 +211,7 @@

    diff --git a/w3ft32_8f.js b/w3ft32_8f.js index 0241891e..6cfd2358 100644 --- a/w3ft32_8f.js +++ b/w3ft32_8f.js @@ -1,4 +1,4 @@ var w3ft32_8f = [ - [ "w3ft32", "w3ft32_8f.html#acfaec65cdd9e813295e8e83626c176cd", null ] + [ "w3ft32", "w3ft32_8f.html#a505bbee044cd5b9c1484ef45ded77d52", null ] ]; \ No newline at end of file diff --git a/w3ft32_8f_source.html b/w3ft32_8f_source.html index 7bb004fd..3783fc7f 100644 --- a/w3ft32_8f_source.html +++ b/w3ft32_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft32.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,1251 +81,1259 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft32.f
    +
    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
    -
    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
    -
    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
    -
    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
    -
    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
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief General interpolator between nmc flds.
    +
    3C> @author John Stackpole @date 1974-06-15
    +
    4
    +
    5C> Interpolate scalar quantity from any given nmc
    +
    6C> field (in office note 84) to any other field. Can do bilinearly
    +
    7C> or biquadratically. Will not rotate wind components.
    +
    8C> Input and output fields are real*4 unpacked
    +
    9C>
    +
    10C> ### Program History Log:
    +
    11C> Date | Programmer | Comment
    +
    12C> -----|------------|--------
    +
    13C> 1974-06-15 | John Stackpole |
    +
    14C> 1987-07-15 | Bill Cavanaugh | Add grid type 100, 101 to tables.
    +
    15C> 1990-08-08 | John. Stackpole | Correct rotation error wrt 100, 101
    +
    16C> 1990-08-31 | Ralph Jones | Change name from polate to w3ft32
    +
    17C> 1993-01-26 | Dennis Keyser | Added grid types 87, 105, 106, 107 to
    +
    18C> tables (as both input and output).
    +
    19C>
    +
    20C> @param[in] FIELD REAL*4 Two dimensional array.
    +
    21C> @param[in] MAPIN INTEGER*4 Nmc map number (k) for given input field.
    +
    22C> @param[in] MAPOUT INTEGER*4 Nmc map number (k) for wanted output field.
    +
    23C> @param[in] INTERP INTEGER*4 Set interpolation method:
    +
    24C> - eq 1 - linear
    +
    25C> - ne 1 - biquadratic
    +
    26C> @param[out] DATA REAL*4 Array to hold output map (unpacked).
    +
    27C> @param[out] IER INTEGER*4 Completion condition flag
    +
    28C>
    +
    29C> Return conditions:
    +
    30C> - IER:
    +
    31C> - 0 No difficulties
    +
    32C> - 1 Mapin not recognized
    +
    33C> - 2 Mapout not recognized
    +
    34C> - 3 Particular pola mapout not recognized
    +
    35C> - 4 Particular lola mapout not recognized
    +
    36C> - 5 Particular lola mapin not recognized
    +
    37C> - 6 Particular pola mapout not recognized
    +
    38C> - 7 Particular lola mapin not recognized
    +
    39C> - 8 Particular lola mapout not recognized
    +
    40C> these flags are set at various test locations
    +
    41C> please refer to the code listing for details
    +
    42C>
    +
    43C> @note See comment cards following for more detail
    +
    44C> including recipes for adding more input and
    +
    45C> output maps as the need arises.
    +
    46C>
    +
    47C> @author John Stackpole @date 1974-06-15
    +
    +
    48 SUBROUTINE w3ft32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER)
    +
    49C
    +
    50C INTERPOLATE INFORMATION FROM FIELD (MAP TYPE K = MAPIN)
    +
    51C TO DATA (MAP TYPE K = MAPOUT)
    +
    52C INTERP SETS INTERPOLATION METHOD
    +
    53C = 1 BILINEAR, OTHERWISE BIQUADRATIC
    +
    54C
    +
    55 REAL DATA(*), FIELD(*)
    +
    56C
    +
    57C RESTRICTION AND RULES:
    +
    58C
    +
    59C AT PRESENT W3FT32 WILL ACCEPT ONLY THE FOLLOWING TYPES
    +
    60C POLAR STEREOGRAPHIC
    +
    61C K = 5 & 26 (LFM ANL & FCST RESPECTIVELY)
    +
    62C 27 & 28 (65X65)
    +
    63C 25 (53X57 SOUTHERN HEMISPHERE)
    +
    64C 49 (129X129 NH; 190.5 KM)
    +
    65C 50 (129X129 SH; 190.5 KM)
    +
    66C 55 (87X71 NH; LFM ORIENT; 254 KM)
    +
    67C 56 (87X71 NA; LFM ORIENT; 174 KM)
    +
    68C 60 (57X57 ENLARGED LFM 'VLFM')
    +
    69C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM)
    +
    70C 100 (83X83 NGM C-GRID; 91.452)
    +
    71C 101 (113X91 NGM BIG C-GRID; 91.452)
    +
    72C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM)
    +
    73C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM)
    +
    74C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM)
    +
    75C
    +
    76C LONGITUDE/LATITUDE: ('LOLA')
    +
    77C K = 29 & 30 (145X37)
    +
    78C 33 & 34 (181X46)
    +
    79C 45 & 46 (97X25 - 3.75 DEG LOLA)
    +
    80C 21 & 22 (73X19 - 5 DEG LOLA)
    +
    81C 21 & 22 (73X19 - 5 DEG LOLA)
    +
    82C
    +
    83C WILL OUTPUT:
    +
    84C POLAR STEREO:
    +
    85C K = 5 (53X57) LFM
    +
    86C 25 (53X57 SOUTH HEMISPHERE)
    +
    87C 26 (53X45) LFM
    +
    88C 27 & 28 (65X65)
    +
    89C 49 (129X129 NH POLA) (1/2 BEDIENT MESH;ORIENTED 80W)
    +
    90C 50 (129X129 SH POLA) (1/2 BEDIENT MESH;ORINETED 80W)
    +
    91C 51 (129X129 NH POLA) (SAME MESHL; ORIENTED AT 105W)
    +
    92C 55 (NH 87X71 254 KM, LFM ORIENT)
    +
    93C 56 (NA 87X71 127 KM, LFM ORIENT)
    +
    94C 60 (57X57 ENLARGED LFM 'VLFM')
    +
    95C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM)
    +
    96C 100 (83X83 NGM C-GRID)
    +
    97C 101 (113X91 NGM BIG C-GRID)
    +
    98C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM)
    +
    99C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM)
    +
    100C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM)
    +
    101C 400 (39X39 1:40MIL 80 DEG VERTICAL POLA)
    +
    102C 401 (25X35 1:20MIL U.S. SECTION ROTATED)
    +
    103C 402 (97X97 1-20MIL N.H. POLA ROTATED TO 105W VERT)
    +
    104C 403 (97X97 1-20MIL S.H. POLA UNROTATED 80W TOP VERT)
    +
    105C LOLA:
    +
    106C K = 29 & 30 (145X37)
    +
    107C 33 & 34 (181X46)
    +
    108C 45 & 46 (97X25 - 3.75 DEG LOLA)
    +
    109C 500 & 501 US SECTIONAL NEP 36 & 45
    +
    110C
    +
    111C FEEL FREE, GENTLE READER, TO AUGMENT THE LIST AS YOU WISH
    +
    112C AND HERE IS A RECIPE FOR ADDING A NEW OUTPUT GRID
    +
    113C (POLA IN THIS CASE, BUT I AM SURE YOU CAN DRAW THE ANALOGY)
    +
    114C STEP1
    +
    115C PUT NEW NUMBER IN COMMENT ABOVE
    +
    116C STEP 2
    +
    117C ADD IT TO MAPOUT LIST NEAR STMT 30
    +
    118C STEP 3
    +
    119C ADD SET OF PARAMETERS AT STMT 2000 (FOR POLA)
    +
    120C STEP4
    +
    121C ADD SET OF PARAMETERS AT STMT 6000 (FOR POLA)
    +
    122C
    +
    123C HERE TOO IS A RECIPE FOR ADDING A NEW (POLA) INPUT GRID
    +
    124C
    +
    125C STEP 1:
    +
    126C PUT NEW NUMBER IN COMMENT ABOVE
    +
    127C STEP2:
    +
    128C ADD NUMBER TO IF(MAPIN.. ) TEST BELOW
    +
    129C STEP 3:
    +
    130C ADD INPUT MAP CHARACTERISTICS AT STMT 1000
    +
    131C STEP 4:
    +
    132C DITTO AT STMT 3000
    +
    133C
    +
    134 LOGICAL LOLAIN, POLAIN, LOLAOU, POLAOU
    +
    135C
    +
    136 SAVE
    +
    137C
    +
    138C BEGIN HERE - SET ERROR RETURN TO O.K.
    +
    139C
    +
    140 ier = 0
    +
    141C
    +
    142C DETERMINE WHETHER INPUT GRID IS LOLA OR POLA
    +
    143C
    +
    144C THIS LIST CAN BE AUGMENTED ONLY AT THE COST OF A LOT OF
    +
    145C WORK ELSEWHERE IN THE PROGRAM
    +
    146C HAVE AT IT IF YOU WANT OTHER MAPS
    +
    147C
    +
    148C POLA MAPS
    +
    149C
    +
    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
    +
    167C
    +
    168C LOLA MAPS
    +
    169C
    +
    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
    +
    178C
    +
    179C IF NO MATCH - ERROR
    +
    180C
    +
    181 ier = 1
    +
    182 RETURN
    +
    183C
    +
    184C SET LOGICAL FLAGS
    +
    185C
    +
    186 10 lolain = .false.
    +
    187 polain = .true.
    +
    188 GO TO 30
    +
    189C
    +
    190 20 lolain = .true.
    +
    191 polain = .false.
    +
    192C
    +
    193C DITTO FOR OUTPUT MAP TYPE
    +
    194C
    +
    195C POLA MAPS
    +
    196C
    +
    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
    +
    218C
    +
    219C LOLA MAPS
    +
    220C
    +
    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
    +
    231C
    +
    232C NO MATCH - ERROR
    +
    233C
    +
    234 ier = 2
    +
    235 RETURN
    +
    236C
    +
    237C SET LOGICAL FLAGS
    +
    238C
    +
    239 40 lolaou = .false.
    +
    240 polaou = .true.
    +
    241 GO TO 60
    +
    242C
    +
    243 50 lolaou = .true.
    +
    244 polaou = .false.
    +
    245C
    +
    246C GO TO DIFFERENT SECTIONS FOR IN/OUT OPTIONS
    +
    247C
    +
    248 60 IF (polain) GO TO 1000
    +
    249 IF (lolain) GO TO 5000
    +
    250C
    +
    251C ##################################################################
    +
    252C ##################################################################
    +
    253C
    +
    254C THIS SECTION FOR POLAR STEREOGRAPHIC INPUT MAPS
    +
    255C
    +
    256C SUBDIVIDED FOR OUTPUT TYPE
    +
    257C
    +
    258 1000 IF (lolaou) GO TO 3000
    +
    259C
    +
    260C POLAR STEREO TO POLAR STEREO
    +
    261C USE HOWCROFTS FIELD TRANSFORMER
    +
    262C ORIENT IS DEGREES OF ROTATION FROM NMC STANDARD
    +
    263C (80 DEG CENTER VERTIVAL) TO INPUT GRID (POSITIVE ANTICLOCKWISE)
    +
    264C
    +
    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
    +
    284C
    +
    285 1005 imaxin =53
    +
    286 jmaxin = 57
    +
    287 comiin = 27.
    +
    288 comjin = 49.
    +
    289 orient = -25.
    +
    290 xmesh = 190.5
    +
    291 GO TO 2000
    +
    292C
    +
    293 1025 imaxin = 53
    +
    294 jmaxin = 57
    +
    295 comiin = 27.
    +
    296 comjin = 29.
    +
    297 orient = 0.
    +
    298 xmesh = 381.
    +
    299 GO TO 2000
    +
    300C
    +
    301 1026 imaxin = 53
    +
    302 jmaxin = 45
    +
    303 comiin = 27.
    +
    304 comjin = 49.
    +
    305 orient = -25.
    +
    306 xmesh = 190.5
    +
    307 GO TO 2000
    +
    308C
    +
    309 1027 imaxin = 65
    +
    310 jmaxin = 65
    +
    311 comiin = 33.
    +
    312 comjin = 33.
    +
    313 orient = 0.
    +
    314 xmesh = 381.
    +
    315 GO TO 2000
    +
    316C
    +
    317 1049 imaxin = 129
    +
    318 jmaxin = 129
    +
    319 comiin = 65.
    +
    320 comjin = 65.
    +
    321 orient = 0.
    +
    322 xmesh = 190.5
    +
    323 GOTO 2000
    +
    324C
    +
    325 1051 imaxin = 129
    +
    326 jmaxin = 129
    +
    327 comiin = 65.
    +
    328 comjin = 65.
    +
    329 orient = -25.
    +
    330 xmesh = 190.5
    +
    331 GOTO 2000
    +
    332C
    +
    333 1055 imaxin = 87
    +
    334 jmaxin = 71
    +
    335 comiin = 44.
    +
    336 comjin = 38.
    +
    337 orient = -25.
    +
    338 xmesh = 254.
    +
    339 GOTO 2000
    +
    340C
    +
    341 1056 imaxin = 87
    +
    342 jmaxin = 71
    +
    343 comiin = 40.
    +
    344 comjin = 73.
    +
    345 orient = -25.
    +
    346 xmesh = 127.
    +
    347 GOTO 2000
    +
    348C
    +
    349 1060 imaxin= 57
    +
    350 jmaxin = 57
    +
    351 comiin = 29.
    +
    352 comjin = 49.
    +
    353 orient = -25.
    +
    354 xmesh = 190.5
    +
    355 GO TO 2000
    +
    356C
    +
    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
    +
    364C
    +
    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
    +
    372C
    +
    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
    +
    380C
    +
    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
    +
    388C
    +
    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
    +
    396C
    +
    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
    +
    404C
    +
    405C SELECT I, J, DILATION, ROTATION, AND COMMON POINT (POLE) OUTPUT
    +
    406C DILATE = XMESHOUT / XMESHIN
    +
    407C IN THE FOLLOWING, ROT IS THE ROTATION FROM THE INPUT TO
    +
    408C THE OUTPUT GRID - NOT THE ORIENTATION OF THE OUT-GRID
    +
    409C
    +
    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
    +
    433C
    +
    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
    +
    441C
    +
    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
    +
    449C
    +
    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
    +
    457C
    +
    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
    +
    465C
    +
    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
    +
    473C
    +
    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
    +
    481C
    +
    482 2055 imaxou = 87
    +
    483 jmaxou = 71
    +
    484 dilat = 254./xmesh
    +
    485 rot = -25. - orient
    +
    486 comiou = 44.
    +
    487 comjou = 38.
    +
    488 GOTO 2700
    +
    489C
    +
    490 2056 imaxou = 87
    +
    491 jmaxou = 71
    +
    492 dilat = 127./xmesh
    +
    493 rot = -25. - orient
    +
    494 comiou = 40.
    +
    495 comjou = 73.
    +
    496 GOTO 2700
    +
    497C
    +
    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
    +
    505C
    +
    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
    +
    513C
    +
    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
    +
    521C
    +
    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
    +
    529C
    +
    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
    +
    537C
    +
    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
    +
    545C
    +
    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
    +
    553C
    +
    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
    +
    561C
    +
    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
    +
    569C
    +
    570 2402 imaxou = 97
    +
    571 jmaxou = 97
    +
    572 dilat = 254./xmesh
    +
    573 rot = -25. - orient
    +
    574 comiou = 49.
    +
    575 comjou = 49.
    +
    576 GOTO 2700
    +
    577C
    +
    578 2403 imaxou = 97
    +
    579 jmaxou = 97
    +
    580 dilat = 254./xmesh
    +
    581 rot = 0. - orient
    +
    582 comiou = 49.
    +
    583 comjou = 49.
    +
    584 GOTO 2700
    +
    585C
    +
    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
    +
    591C
    +
    592C ##################################################################
    +
    593C
    +
    594C HERE FOR POLAR STEREO TO LO/LA
    +
    595C
    +
    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
    +
    613C
    +
    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
    +
    622C
    +
    623 3025 xmesh = 381.
    +
    624 imaxin = 53
    +
    625 jmaxin = 57
    +
    626 nthsth = 2
    +
    627 polei = 27.
    +
    628 polej = 29.
    +
    629 GO TO 4000
    +
    630C
    +
    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
    +
    639C
    +
    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
    +
    649C
    +
    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
    +
    659C
    +
    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
    +
    668C
    +
    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
    +
    677C
    +
    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
    +
    686C
    +
    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
    +
    695C
    +
    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
    +
    704C
    +
    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
    +
    713C
    +
    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
    +
    722C
    +
    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
    +
    731C
    +
    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
    +
    740C
    +
    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
    +
    749C
    +
    750C SELECT OUTPUT LO/LA VARIATIONS
    +
    751C
    +
    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
    +
    764C
    +
    765 4021 iminou = 1
    +
    766 jminou = 1
    +
    767 imaxou = 73
    +
    768 jmaxou = 19
    +
    769 deg = 5.0
    +
    770 GO TO 4700
    +
    771C
    +
    772 4029 iminou = 1
    +
    773 imaxou = 145
    +
    774 jminou = 1
    +
    775 jmaxou = 37
    +
    776 deg = 2.5
    +
    777 GO TO 4700
    +
    778C
    +
    779 4033 iminou = 1
    +
    780 imaxou = 181
    +
    781 jminou = 1
    +
    782 jmaxou = 46
    +
    783 deg = 2.0
    +
    784 GO TO 4700
    +
    785C
    +
    786 4045 iminou = 1
    +
    787 imaxou = 97
    +
    788 jminou = 1
    +
    789 jmaxou = 25
    +
    790 deg = 3.75
    +
    791 GOTO 4700
    +
    792C
    +
    793 4500 iminou = 93
    +
    794 imaxou = 117
    +
    795 jminou = 1
    +
    796 jmaxou = 37
    +
    797 deg = 2.5
    +
    798 GO TO 4700
    +
    799C
    +
    800 4501 iminou = 116
    +
    801 imaxou = 140
    +
    802 jminou = 1
    +
    803 jmaxou = 46
    +
    804 deg = 2.0
    +
    805 GO TO 4700
    +
    806C
    +
    807C FIND INPUT POLA I,J FOR DESIRED LOLA OUTPUT POINTS
    +
    808C
    +
    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
    +
    822C
    +
    823C MACDONALDS SUPER GENERAL INTERPOLATOR
    +
    824C IN WHICH D = FIELD(XIIN, XJIN)
    +
    825C
    +
    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
    +
    832C
    +
    833C ##################################################################
    +
    834C ##################################################################
    +
    835C
    +
    836C THIS SECTION FOR LOLA INPUT MAP
    +
    837C
    +
    838C SELCT OUTPUT TYPE
    +
    839C
    +
    840 5000 IF (lolaou) GO TO 7000
    +
    841C
    +
    842C LOLA TO POLA
    +
    843C SELECT INPUT INFO
    +
    844C (THIS PATTERN CAN BE USED WITH POLA INPUT, TOO - TRY IT
    +
    845C
    +
    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
    +
    856C
    +
    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
    +
    863C
    +
    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
    +
    870C
    +
    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
    +
    877C
    +
    878 5045 imaxin = 97
    +
    879 jmaxin = 25
    +
    880 deg = 3.75
    +
    881 nthsth = 1
    +
    882 IF (mapin.EQ.46) nthsth = 2
    +
    883 GOTO 6000
    +
    884C
    +
    885C SELECT OUTPUT POLA VARIETY
    +
    886C ROT INDICATES HOW MANY DEGREES THE POLA GRID IS TO BE ROTATED
    +
    887C (POSITIVE COUNTER-CLOCKWISE) FROM THE NMC 'STANDARD'
    +
    888C OF 80 DEG WEST AT THE BOTTOM (OR TOP IF SOUTHERN HEMISPHERE)
    +
    889C
    +
    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
    +
    913C
    +
    914 6005 imaxou = 53
    +
    915 jmaxou = 57
    +
    916 xmesh = 190.5
    +
    917 rot = -25.
    +
    918 polei = 27.
    +
    919 polej = 49.
    +
    920 GO TO 6700
    +
    921C
    +
    922 6025 imaxou = 53
    +
    923 jmaxou = 57
    +
    924 xmesh = 381.
    +
    925 rot = 0.
    +
    926 polei = 27.
    +
    927 polej = 29.
    +
    928 GO TO 6700
    +
    929C
    +
    930 6026 imaxou = 53
    +
    931 jmaxou = 45
    +
    932 xmesh = 190.5
    +
    933 rot = -25.
    +
    934 polei = 27.
    +
    935 polej = 49.
    +
    936 GO TO 6700
    +
    937C
    +
    938 6027 imaxou = 65
    +
    939 jmaxou = 65
    +
    940 xmesh = 381.
    +
    941 rot = 0.
    +
    942 polei = 33.
    +
    943 polej = 33.
    +
    944 GO TO 6700
    +
    945C
    +
    946 6049 imaxou = 129
    +
    947 jmaxou = 129
    +
    948 xmesh = 190.5
    +
    949 rot = 0.
    +
    950 polei = 65.
    +
    951 polej = 65.
    +
    952 GOTO 6700
    +
    953C
    +
    954 6051 imaxou = 129
    +
    955 jmaxou = 129
    +
    956 xmesh = 190.5
    +
    957 rot = -25.
    +
    958 polei = 65.
    +
    959 polej = 65.
    +
    960 GOTO 6700
    +
    961C
    +
    962 6055 imaxou = 87
    +
    963 jmaxou = 71
    +
    964 xmesh = 254.
    +
    965 rot = -25.
    +
    966 polei = 44.
    +
    967 polej = 38.
    +
    968 GOTO 6700
    +
    969C
    +
    970 6056 imaxou = 87
    +
    971 jmaxou = 71
    +
    972 xmesh = 127.
    +
    973 rot = -25.
    +
    974 polei = 40.
    +
    975 polej = 73.
    +
    976 GOTO 6700
    +
    977C
    +
    978 6060 imaxou = 57
    +
    979 jmaxou = 57
    +
    980 xmesh = 190.5
    +
    981 rot = -25.
    +
    982 polei = 29.
    +
    983 polej = 49.
    +
    984 GO TO 6700
    +
    985C
    +
    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
    +
    993C
    +
    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
    +
    1001C
    +
    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
    +
    1009C
    +
    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
    +
    1017C
    +
    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
    +
    1025C
    +
    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
    +
    1033C
    +
    1034 6400 imaxou = 39
    +
    1035 jmaxou = 39
    +
    1036 xmesh = 508.
    +
    1037 rot = 0.
    +
    1038 polei = 20.
    +
    1039 polej = 20.
    +
    1040 GO TO 6700
    +
    1041C
    +
    1042C THIS ONE GETS SPECIAL TREATMENT BECAUSE WE ARE
    +
    1043C INTERCHANGING ROWS AND COLUMNS FOR GRIDPRINT AFTER INTERPOLATION
    +
    1044C (ACTUALLY IT IS DONE ALL AT ONCE)
    +
    1045C
    +
    1046 6401 imaxou = 25
    +
    1047 jmaxou = 35
    +
    1048 xmesh = 254.
    +
    1049 rot = -25.
    +
    1050 polei = 18.
    +
    1051 polej = 31.75
    +
    1052C
    +
    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
    +
    107064011 CONTINUE
    +
    1071 RETURN
    +
    1072C
    +
    1073 6402 imaxou = 97
    +
    1074 jmaxou = 97
    +
    1075 xmesh = 254.
    +
    1076 rot = -25.
    +
    1077 polei = 49.
    +
    1078 polej = 49.
    +
    1079 GOTO 6700
    +
    1080C
    +
    1081 6403 imaxou = 97
    +
    1082 jmaxou = 97
    +
    1083 xmesh = 254.
    +
    1084 rot = 0.
    +
    1085 polei = 49.
    +
    1086 polej = 49.
    +
    1087 GOTO 6700
    +
    1088C
    +
    1089C FIND INPUT LOLA I,J FOR DESIRED POLA OUTPUT POINTS
    +
    1090C
    +
    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
    +
    1113C
    +
    1114C ##################################################################
    +
    1115C
    +
    1116C LOLA TO LOLA
    +
    1117C
    +
    1118C SELECT INPUT GRID INFO
    +
    1119C
    +
    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
    +
    1130C
    +
    1131 7021 imaxin = 73
    +
    1132 jmaxin = 19
    +
    1133 degin = 5.0
    +
    1134 GO TO 8000
    +
    1135C
    +
    1136 7029 imaxin = 145
    +
    1137 jmaxin = 37
    +
    1138 degin = 2.5
    +
    1139 GO TO 8000
    +
    1140C
    +
    1141 7033 imaxin = 181
    +
    1142 jmaxin = 46
    +
    1143 degin = 2.0
    +
    1144 GO TO 8000
    +
    1145C
    +
    1146 7045 imaxin = 97
    +
    1147 jmaxin = 25
    +
    1148 degin = 3.75
    +
    1149 GOTO 8000
    +
    1150C
    +
    1151C SELECT OUTPUT LOLA GRID
    +
    1152C
    +
    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
    +
    1165C
    +
    1166 8021 iminou = 1
    +
    1167 imaxou = 73
    +
    1168 jminou = 1
    +
    1169 jmaxou = 19
    +
    1170 degou = 5.
    +
    1171 GO TO 8700
    +
    1172C
    +
    1173 8029 iminou = 1
    +
    1174 imaxou = 145
    +
    1175 jminou = 1
    +
    1176 jmaxou = 37
    +
    1177 degou = 2.5
    +
    1178 GO TO 8700
    +
    1179C
    +
    1180 8033 iminou = 1
    +
    1181 imaxou = 181
    +
    1182 jminou = 1
    +
    1183 jmaxou = 46
    +
    1184 degou = 2.0
    +
    1185 GO TO 8700
    +
    1186C
    +
    1187 8045 iminou = 1
    +
    1188 imaxou = 97
    +
    1189 jminou = 1
    +
    1190 jmaxou = 25
    +
    1191 degou = 3.75
    +
    1192 GOTO 8700
    +
    1193C
    +
    1194 8500 iminou = 93
    +
    1195 imaxou = 117
    +
    1196 jminou = 1
    +
    1197 jmaxou = 37
    +
    1198 degou = 2.5
    +
    1199 GO TO 8700
    +
    1200C
    +
    1201 8501 iminou = 116
    +
    1202 imaxou = 140
    +
    1203 jminou = 1
    +
    1204 jmaxou = 46
    +
    1205 degou = 2.0
    +
    1206 GO TO 8700
    +
    1207C
    +
    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
    +
    1220C
    +
    +
    1221 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
    +
    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
    +
    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
    +
    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
    +
    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
    +
    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
    diff --git a/w3ft33_8f.html b/w3ft33_8f.html index 10beb010..bf452a00 100644 --- a/w3ft33_8f.html +++ b/w3ft33_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft33.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft33.f File Reference
    +
    w3ft33.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Thicken thinned wafs grib grid 37-44.

    @@ -107,8 +113,8 @@

    Definition in file w3ft33.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft33()

    + +

    ◆ w3ft33()

    @@ -117,19 +123,19 @@

    subroutine w3ft33 ( real, dimension(*)  - AIN, + ain, real, dimension(nx,ny)  - OUT, + out,   - NSFLAG  + nsflag  @@ -140,7 +146,7 @@

    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
    @@ -165,7 +171,7 @@

    diff --git a/w3ft33_8f.js b/w3ft33_8f.js index 68d71545..3981077a 100644 --- a/w3ft33_8f.js +++ b/w3ft33_8f.js @@ -1,4 +1,4 @@ var w3ft33_8f = [ - [ "w3ft33", "w3ft33_8f.html#aa788035129e6f04923f7f351fb343ff0", null ] + [ "w3ft33", "w3ft33_8f.html#a7c1d44437b786040567e37bcbc44765f", null ] ]; \ No newline at end of file diff --git a/w3ft33_8f_source.html b/w3ft33_8f_source.html index 1cd068f2..a0edff05 100644 --- a/w3ft33_8f_source.html +++ b/w3ft33_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft33.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,161 +81,169 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft33.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Thicken thinned wafs grib grid 37-44
    +
    3C> @author Ralph Peterson @date 1994
    +
    4
    +
    5C> Subroutine thickens one thinned wafs grib grid to a
    +
    6C> real array of 5329 numbers (73,73) 1.25 degree grid.
    +
    7C>
    +
    8C> ### Program History Log:
    +
    9C> Date | Programmer | Comment
    +
    10C> -----|------------|--------
    +
    11C> 1994-??-?? | Ralph Peterson
    +
    12C> 1994-11-07 | Ralph Jones | Add doc block, change call to 3 parameters.
    +
    13C> Replace cos with table lookup.
    +
    14C> 1995-06-02 | Ralph Peterson | Changes to correct miss-position
    +
    15C> between + or - 8.75 n/s.
    +
    16C> 1995-06-03 | Ralph Jones | Changes so 8 rows with 73 values
    +
    17C> are not thickened, 10% faster.
    +
    18C>
    +
    19C> @param[in] AIN Real 3447 word array with unpacked thinned wafs
    +
    20C> grib type 37-44.
    +
    21C> @param[in] NSFLAG Integer = 1 AIN is wafs grib grid 37-40 n. hemi.
    +
    22C> = -1 AIN is wafs grib grid 41-44 s. hemi.
    +
    23C> @param[out] OUT Real (73,73) word array with thickened wafs grib grid 37-44.
    +
    24C>
    +
    25C> @remark The pole point for u and v wind components will have only
    +
    26C> one point. If you need the pole row corrected see page 9 section
    +
    27C> 1 in office note 388. You need both u and v to make the
    +
    28C> correction.
    +
    29C>
    +
    30C> @author Ralph Peterson @date 1994
    +
    +
    31 SUBROUTINE w3ft33(AIN,OUT,NSFLAG)
    +
    32C
    +
    33 parameter(nx=73,ny=73)
    +
    34 parameter(nin=3447)
    +
    35C
    +
    36 REAL AIN(*)
    +
    37 REAL OUT(NX,NY)
    +
    38C
    +
    39 INTEGER IPOINT(NX)
    +
    40C
    +
    41 SAVE
    +
    42C
    +
    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/
    +
    49C
    +
    50 nxm = nx - 1
    +
    51 fnxm = float(nxm)
    +
    52C
    +
    53C TEST FOR GRIDS (37-40)
    +
    54C
    +
    55 IF (nsflag.GT.0) THEN
    +
    56C
    +
    57C DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA
    +
    58C TO OUT ARRAY. GRIDS (37-40) N.
    +
    59C
    +
    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
    +
    67C
    +
    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
    +
    94C
    +
    95 ELSE
    +
    96C
    +
    97C DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA
    +
    98C TO OUT ARRAY. GRIDS (41-44) S.
    +
    99C
    +
    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
    +
    107C
    +
    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
    +
    135C
    +
    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/w3ft38_8f.html b/w3ft38_8f.html index 3d0a6b17..ae7acb2e 100644 --- a/w3ft38_8f.html +++ b/w3ft38_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft38.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft38.f File Reference
    +
    w3ft38.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft38 (fln, gn, pln, fl, work, trigs)
     Computes 2.5 x 2.5 n.
     

    Detailed Description

    Computes 2.5 x 2.5 n.

    @@ -107,8 +113,8 @@

    Definition in file w3ft38.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft38()

    + +

    ◆ w3ft38()

    @@ -117,37 +123,37 @@

    subroutine w3ft38 ( complex, dimension( 31 , 31 )  - FLN, + fln, real, dimension(145,37)  - GN, + gn, real, dimension( 32, 31, 37 )  - PLN, + pln, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS  + trigs  @@ -159,27 +165,27 @@

    +

    Program History Log:

    - +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft08(), takes out w3fa12()
    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.

    +

    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]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]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)
    +
    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 )
    @@ -189,14 +195,15 @@

    DATA pi /3.14159265/
    drad = 2.5 * pi / 180.0
    -
    CALL w3fa11(eps,30)
    -
    CALL w3fa13(trigs,rcos)
    +
    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)
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    END DO
    -
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    -
    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
    +
    w3fa12
    subroutine w3fa12(pln, colrad, jcap, eps)
    Subroutine computes legendre polynomials at a given latitude.
    Definition w3fa12.f:21
    +
    w3fa13
    subroutine w3fa13(trigs, rcos)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition w3fa13.f:18

    Definition at line 53 of file w3ft38.f.

    @@ -209,7 +216,7 @@

    diff --git a/w3ft38_8f.js b/w3ft38_8f.js index 85523d44..f7bfd341 100644 --- a/w3ft38_8f.js +++ b/w3ft38_8f.js @@ -1,4 +1,4 @@ var w3ft38_8f = [ - [ "w3ft38", "w3ft38_8f.html#a1826351145421b3de7f51f5b798ae391", null ] + [ "w3ft38", "w3ft38_8f.html#a650ca7b1763805ead1c270d68d9a12c4", null ] ]; \ No newline at end of file diff --git a/w3ft38_8f_source.html b/w3ft38_8f_source.html index d8532c5a..51047321 100644 --- a/w3ft38_8f_source.html +++ b/w3ft38_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft38.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,110 +81,118 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft38.f
    +
    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
    -
    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
    -
    w3ft38
    subroutine w3ft38(FLN, GN, PLN, FL, WORK, TRIGS)
    Computes 2.5 x 2.5 n.
    Definition: w3ft38.f:54
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes 2.5 x 2.5 n. hemi. grid-scaler
    +
    3C> @author Ralph Jones @date 1993-07-23
    +
    4
    +
    5C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7C> representing a scaler field.
    +
    8C>
    +
    9C> ### Program History Log:
    +
    10C> Date | Programmer | Comment
    +
    11C> -----|------------|--------
    +
    12C> 1993-07-23 | Ralph Jones | New version of w3ft08(), takes out w3fa12()
    +
    13C> makes pln 3 dimensions, pln is computed one time in main program, trades\
    +
    14C> memory for more speed. w3fa12() used 70% of cpu time.
    +
    15C>
    +
    16C> @param[in] FLN 961 complex coeff.
    +
    17C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18C> computed by w3fa12().
    +
    19C> @param[in] FL 31 complex space for fourier coeff.
    +
    20C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    21C> @param[in] TRIGS 216 precomputed trig funcs. Used
    +
    22C> in w3ft12(), computed by w3fa13()
    +
    23C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    24C>
    +
    25C> @note w3ft08() was optimized to run in a small amount of
    +
    26C> memory, it was not optimized for speed, 70 percent of the time was
    +
    27C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    28C> the legendre polynomials are constant they need to be computed
    +
    29C> only once in a program. By moving w3fa12() to the main program and
    +
    30C> computing pln as a (32,31,37) array and changing this subroutine
    +
    31C> to use pln as a three dimension array the running time was cut
    +
    32C> 70 percent. Add following code to main program to compute eps, pln,
    +
    33C> trigs, and rcos one time in program.
    +
    34C> @code
    +
    35C> DOUBLE PRECISION EPS(992) (REAL ON CRAY)
    +
    36C> DOUBLE PRECISION COLRA (REAL ON CRAY)
    +
    37C>
    +
    38C> REAL PLN( 32, 31, 37 )
    +
    39C> REAL RCOS(37)
    +
    40C> REAL TRIGS(216)
    +
    41C>
    +
    42C> DATA PI /3.14159265/
    +
    43C>
    +
    44C> DRAD = 2.5 * PI / 180.0
    +
    45C> CALL W3FA11(EPS,30)
    +
    46C> CALL W3FA13(TRIGS,RCOS)
    +
    47C> DO LAT = 1,37
    +
    48C> COLRA = (LAT - 1) * DRAD
    +
    49C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    50C> END DO
    +
    51C> @endcode
    +
    52C>
    +
    +
    53 SUBROUTINE w3ft38(FLN,GN,PLN,FL,WORK,TRIGS)
    +
    54C
    +
    55 COMPLEX FL( 31 )
    +
    56 COMPLEX FLN( 31 , 31 )
    +
    57C
    +
    58 REAL GN(145,37)
    +
    59 REAL PLN( 32, 31, 37 )
    +
    60 REAL TRIGS(216)
    +
    61 REAL WORK(144)
    +
    62C
    +
    63 SAVE
    +
    64C
    +
    65 DO 400 lat = 1,37
    +
    66 latn = 38 - lat
    +
    67C
    +
    68 DO 100 l = 1, 31
    +
    69 fl(l) = (0.,0.)
    +
    70 100 CONTINUE
    +
    71C
    +
    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
    +
    77C
    +
    78 300 CONTINUE
    +
    79C
    +
    80 CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    81C
    +
    82 400 CONTINUE
    +
    83C
    +
    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
    +
    w3ft38
    subroutine w3ft38(fln, gn, pln, fl, work, trigs)
    Computes 2.5 x 2.5 n.
    Definition w3ft38.f:54
    diff --git a/w3ft39_8f.html b/w3ft39_8f.html index 4f3ead30..92147ee9 100644 --- a/w3ft39_8f.html +++ b/w3ft39_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft39.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft39.f File Reference
    +
    w3ft39.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft39 (vln, gn, pln, fl, work, trigs, rcos)
     Computes 2.5 x 2.5 n.
     

    Detailed Description

    Computes 2.5x2.5 n.

    @@ -107,8 +113,8 @@

    Definition in file w3ft39.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft39()

    + +

    ◆ w3ft39()

    @@ -117,43 +123,43 @@

    subroutine w3ft39 ( complex, dimension( 32 , 31 )  - VLN, + vln, real, dimension(145,37)  - GN, + gn, real, dimension( 32, 31, 37 )  - PLN, + pln, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS, + trigs, real, dimension(37)  - RCOS  + rcos  @@ -165,28 +171,28 @@

    +

    Program History Log:

    - +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft09(), takes out w3fa12()
    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.

    +

    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]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().
    [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)
    +
    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 )
    @@ -196,14 +202,15 @@

    DATA pi /3.14159265/
    drad = 2.5 * pi / 180.0
    -
    CALL w3fa11(eps,30)
    -
    CALL w3fa13(trigs,rcos)
    +
    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)
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    END DO
    -
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    -
    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
    +
    w3fa12
    subroutine w3fa12(pln, colrad, jcap, eps)
    Subroutine computes legendre polynomials at a given latitude.
    Definition w3fa12.f:21
    +
    w3fa13
    subroutine w3fa13(trigs, rcos)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition w3fa13.f:18

    Author
    Ralph Jones
    Date
    1993-07-23
    @@ -218,7 +225,7 @@

    diff --git a/w3ft39_8f.js b/w3ft39_8f.js index 0cf9c445..2331892f 100644 --- a/w3ft39_8f.js +++ b/w3ft39_8f.js @@ -1,4 +1,4 @@ var w3ft39_8f = [ - [ "w3ft39", "w3ft39_8f.html#a858e5d96caaef7d2d5882420f7bc3556", null ] + [ "w3ft39", "w3ft39_8f.html#aacebb1724c4f1396a70221ce78ed2fd5", null ] ]; \ No newline at end of file diff --git a/w3ft39_8f_source.html b/w3ft39_8f_source.html index fa411755..13684373 100644 --- a/w3ft39_8f_source.html +++ b/w3ft39_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft39.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,123 +81,131 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft39.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes 2.5x2.5 n. hemi. grid-vector.
    +
    3C> @author Ralph Jones @date 1993-07-23
    +
    4
    +
    5C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7C> representing a vector field.
    +
    8C>
    +
    9C> ### Program History Log:
    +
    10C> Date | Programmer | Comment
    +
    11C> -----|------------|--------
    +
    12C> 1993-07-23 | Ralph Jones | New version of w3ft09(), takes out w3fa12()
    +
    13C> makes pln 3 dimensions, pln is computed one time in main program, trades memory
    +
    14C> for more speed. w3fa12() used 70% of cpu time.
    +
    15C>
    +
    16C> @param[in] VLN 992 complex coeff.
    +
    17C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18C> computed by w3fa12().
    +
    19C> @param[in] FL 31 complex space for fourier coeff.
    +
    20C> @param[in] WORK 144 work space for subr. w3ft12()
    +
    21C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    22C> in w3ft12, computed by w3fa13().
    +
    23C> @param[in] RCOS 37 reciprocal cosine latitudes of
    +
    24C> 2.5 x 2.5 grid must be computed before
    +
    25C> first call to w3ft11 using sr w3fa13().
    +
    26C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d o.n. 84
    +
    27C>
    +
    28C> @note w3ft09() was optimized to run in a small amount of
    +
    29C> memory, it was not optimized for speed, 70 percent of the time was
    +
    30C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    31C> the legendre polynomials are constant they need to be computed
    +
    32C> only once in a program. By moving w3fa12() to the main program and
    +
    33C> computing pln as a (32,31,37) array and changing this subroutine
    +
    34C> to use pln as a three dimension array the running time was cut
    +
    35C> 70 percent. Add following code to main program to compute eps, pln,
    +
    36C> trigs, and rcos one time in program.
    +
    37C> @code
    +
    38C> DOUBLE PRECISION EPS(992)
    +
    39C> DOUBLE PRECISION COLRA
    +
    40C>
    +
    41C> REAL PLN( 32, 31, 37 )
    +
    42C> REAL RCOS(37)
    +
    43C> REAL TRIGS(216)
    +
    44C>
    +
    45C> DATA PI /3.14159265/
    +
    46C>
    +
    47C> DRAD = 2.5 * PI / 180.0
    +
    48C> CALL W3FA11(EPS,30)
    +
    49C> CALL W3FA13(TRIGS,RCOS)
    +
    50C> DO LAT = 1,37
    +
    51C> COLRA = (LAT - 1) * DRAD
    +
    52C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    53C> END DO
    +
    54C> @endcode
    +
    55C>
    +
    56C> @author Ralph Jones @date 1993-07-23
    +
    +
    57 SUBROUTINE w3ft39(VLN,GN,PLN,FL,WORK,TRIGS,RCOS)
    +
    58C
    +
    59 COMPLEX FL( 31 )
    +
    60 COMPLEX VLN( 32 , 31 )
    +
    61C
    +
    62 REAL GN(145,37)
    +
    63 REAL PLN( 32, 31, 37 )
    +
    64 REAL RCOS(37)
    +
    65 REAL TRIGS(216)
    +
    66 REAL WORK(144)
    +
    67C
    +
    68 SAVE
    +
    69C
    +
    70 DO 400 lat = 2,37
    +
    71 latn = 38 - lat
    +
    72C
    +
    73 DO 100 l = 1, 31
    +
    74 fl(l) = (0.,0.)
    +
    75 100 CONTINUE
    +
    76C
    +
    77 DO 300 l = 1, 31
    +
    78C
    +
    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
    +
    83C
    +
    84 fl(l)=cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
    +
    85 300 CONTINUE
    +
    86C
    +
    87 CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    88C
    +
    89 400 CONTINUE
    +
    90C
    +
    91C*** POLE ROW=CLOSEST LATITUDE ROW
    +
    92C
    +
    93 DO 500 i = 1,145
    +
    94 gn(i,37) = gn(i,36)
    +
    95 500 CONTINUE
    +
    96C
    +
    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/w3ft40_8f.html b/w3ft40_8f.html index 47d19852..de68cb36 100644 --- a/w3ft40_8f.html +++ b/w3ft40_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft40.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft40.f File Reference
    +
    w3ft40.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft40 (fln, gn, pln, fl, work, trigs)
     Computes 2.5 x 2.5 s.
     

    Detailed Description

    Computes 2.5 x 2.5 s.

    @@ -107,8 +113,8 @@

    Definition in file w3ft40.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft40()

    + +

    ◆ w3ft40()

    @@ -117,37 +123,37 @@

    subroutine w3ft40 ( complex, dimension( 31 , 31 )  - FLN, + fln, real, dimension(145,37)  - GN, + gn, real, dimension( 32, 31, 37 )  - PLN, + pln, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS  + trigs  @@ -159,27 +165,27 @@

    +

    Program History Log:

    - +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft10(), takes out w3fa12()
    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.

    +

    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]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]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]
    +
    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 )
    @@ -189,14 +195,15 @@

    DATA pi /3.14159265/
    drad = 2.5 * pi / 180.0
    -
    CALL w3fa11(eps,30)
    -
    CALL w3fa13(trigs,rcos)
    +
    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)
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    END DOC
    -
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    -
    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
    +
    w3fa12
    subroutine w3fa12(pln, colrad, jcap, eps)
    Subroutine computes legendre polynomials at a given latitude.
    Definition w3fa12.f:21
    +
    w3fa13
    subroutine w3fa13(trigs, rcos)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition w3fa13.f:18

    Author
    Ralph Jones
    Date
    1993-07-23
    @@ -211,7 +218,7 @@

    diff --git a/w3ft40_8f.js b/w3ft40_8f.js index ac074128..642e6764 100644 --- a/w3ft40_8f.js +++ b/w3ft40_8f.js @@ -1,4 +1,4 @@ var w3ft40_8f = [ - [ "w3ft40", "w3ft40_8f.html#a3bc42dc396a768eb87167924c73c65d6", null ] + [ "w3ft40", "w3ft40_8f.html#ac08e699870c05a14afcf7f90d27d8094", null ] ]; \ No newline at end of file diff --git a/w3ft40_8f_source.html b/w3ft40_8f_source.html index bf170519..fa3e6ead 100644 --- a/w3ft40_8f_source.html +++ b/w3ft40_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft40.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,115 +81,123 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft40.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes 2.5 x 2.5 s. hemi. grid-scaler
    +
    3C> @author Ralph Jones @date 1993-07-23
    +
    4
    +
    5C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
    +
    6C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7C> representing a scaler field.
    +
    8C>
    +
    9C> ### Program History Log:
    +
    10C> Date | Programmer | Comment
    +
    11C> -----|------------|--------
    +
    12C> 1993-07-23 | Ralph Jones | New version of w3ft10(), takes out w3fa12()
    +
    13C> makes pln 3 dimensions, pln is computed one time in main program, trades memory
    +
    14C> for more speed. w3fa12() used 70% of cpu time.
    +
    15C>
    +
    16C> @param[in] FLN 961 complex coeff.
    +
    17C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18C> computed by w3fa12().
    +
    19C> @param[in] FL 31 complex space for fourier coeff.
    +
    20C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    21C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    22C> in w3ft12, computed by w3fa13().
    +
    23C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e o.n. 84
    +
    24C>
    +
    25C> @note w3ft10() was optimized to run in a small amount of
    +
    26C> memory, it was not optimized for speed, 70 percent of the time was
    +
    27C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    28C> the legendre polynomials are constant they need to be computed
    +
    29C> only once in a program. By moving w3fa12() to the main program and
    +
    30C> computing pln as a (32,31,37) array and changing this subroutine
    +
    31C> to use pln as a three dimension array the running time was cut
    +
    32C> 70 percent. Add following code to main program to compute eps, pln,
    +
    33C> trigs, and rcos one time in program.
    +
    34C> @code
    +
    35C> DOUBLE PRECISION EPS(992) [CHANGE TO REAL ON CRAY]
    +
    36C> DOUBLE PRECISION COLRA [CHANGE TO REAL ON CRAY]
    +
    37C>
    +
    38C> REAL PLN( 32, 31, 37 )
    +
    39C> REAL RCOS(37)
    +
    40C> REAL TRIGS(216)
    +
    41C>
    +
    42C> DATA PI /3.14159265/
    +
    43C>
    +
    44C> DRAD = 2.5 * PI / 180.0
    +
    45C> CALL W3FA11(EPS,30)
    +
    46C> CALL W3FA13(TRIGS,RCOS)
    +
    47C> DO LAT = 1,37
    +
    48C> COLRA = (LAT - 1) * DRAD
    +
    49C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    50C> END DOC
    +
    51C> @endcode
    +
    52C>
    +
    53C> @author Ralph Jones @date 1993-07-23
    +
    +
    54 SUBROUTINE w3ft40(FLN,GN,PLN,FL,WORK,TRIGS)
    +
    55C
    +
    56 COMPLEX FL( 31 )
    +
    57 COMPLEX FLN( 31 , 31 )
    +
    58C
    +
    59 REAL GN(145,37)
    +
    60 REAL PLN( 32, 31, 37 )
    +
    61 REAL TRIGS(216)
    +
    62 REAL WORK(144)
    +
    63C
    +
    64 SAVE
    +
    65C
    +
    66 DO 400 lat = 1,37
    +
    67C
    +
    68 DO 100 l = 1, 31
    +
    69 fl(l) = (0.,0.)
    +
    70 100 CONTINUE
    +
    71C
    +
    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)) )
    +
    76C
    +
    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
    +
    83C
    +
    84 300 CONTINUE
    +
    85C
    +
    86 CALL w3ft12(fl,work,gn(1,lat ),trigs)
    +
    87 400 CONTINUE
    +
    88C
    +
    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/w3ft41_8f.html b/w3ft41_8f.html index 73a3a577..e32d5743 100644 --- a/w3ft41_8f.html +++ b/w3ft41_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft41.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft41.f File Reference
    +
    w3ft41.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine w3ft41 (vln, gn, pln, fl, work, trigs, rcos)
     Computes 2.5 x 2.5 s.
     

    Detailed Description

    Computes 2.5x2.5 s.

    @@ -107,8 +113,8 @@

    Definition in file w3ft41.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft41()

    + +

    ◆ w3ft41()

    @@ -117,43 +123,43 @@

    subroutine w3ft41 ( complex, dimension( 32 , 31 )  - VLN, + vln, real, dimension(145,37)  - GN, + gn, real, dimension( 32, 31, 37 )  - PLN, + pln, complex, dimension( 31 )  - FL, + fl, real, dimension(144)  - WORK, + work, real, dimension(216)  - TRIGS, + trigs, real, dimension(37)  - RCOS  + rcos  @@ -165,28 +171,28 @@

    +

    Program History Log:

    - +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft11(), takes out w3fa12()
    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.

    +

    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]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().
    [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)
    +
    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 )
    @@ -196,14 +202,15 @@

    DATA pi /3.14159265/
    drad = 2.5 * pi / 180.0
    -
    CALL w3fa11(eps,30)
    -
    CALL w3fa13(trigs,rcos)
    +
    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)
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    END DO
    -
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    -
    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
    +
    w3fa12
    subroutine w3fa12(pln, colrad, jcap, eps)
    Subroutine computes legendre polynomials at a given latitude.
    Definition w3fa12.f:21
    +
    w3fa13
    subroutine w3fa13(trigs, rcos)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition w3fa13.f:18

    Author
    Ralph Jones
    Date
    1992-07-23
    @@ -218,7 +225,7 @@

    diff --git a/w3ft41_8f.js b/w3ft41_8f.js index 567e013f..6a6df7e4 100644 --- a/w3ft41_8f.js +++ b/w3ft41_8f.js @@ -1,4 +1,4 @@ var w3ft41_8f = [ - [ "w3ft41", "w3ft41_8f.html#a261b10911c4a789b882deef2c1f312ca", null ] + [ "w3ft41", "w3ft41_8f.html#a6f67ac7895427653fd746467ce92a2ad", null ] ]; \ No newline at end of file diff --git a/w3ft41_8f_source.html b/w3ft41_8f_source.html index aa95fdda..38ae2c85 100644 --- a/w3ft41_8f_source.html +++ b/w3ft41_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft41.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,124 +81,132 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft41.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Computes 2.5x2.5 s. hemi. grid vector.
    +
    3C> @author Ralph Jones @date 1992-07-23
    +
    4
    +
    5C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
    +
    6C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7C> representing a vector field.
    +
    8C>
    +
    9C> ### Program History Log:
    +
    10C> Date | Programmer | Comment
    +
    11C> -----|------------|--------
    +
    12C> 1993-07-23 | Ralph Jones | New version of w3ft11(), takes out w3fa12()
    +
    13C> makes pln 3 dimensions, pln is computed one time in main program, trades memory
    +
    14C> for more speed. w3fa12() used 70% of cpu time.
    +
    15C>
    +
    16C> @param[in] VLN 992 complex coeff.
    +
    17C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18C> computed by w3fa12().
    +
    19C> @param[in] FL 31 complex space for fourier coeff.
    +
    20C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    21C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    22C> in w3ft12(), computed by w3fa13()
    +
    23C> @param[in] RCOS 37 reciprocal cosine latitudes of
    +
    24C> 2.5 x 2.5 grid must be computed before
    +
    25C> first call to w3ft11 using subr. w3fa13().
    +
    26C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e hex o.n. 84
    +
    27C>
    +
    28C> @note w3ft11() was optimized to run in a small amount of
    +
    29C> memory, it was not optimized for speed, 70 percent of the time was
    +
    30C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    31C> the legendre polynomials are constant they need to be computed
    +
    32C> only once in a program. By moving w3fa12() to the main program and
    +
    33C> computing pln as a (32,31,37) array and changing this subroutine
    +
    34C> to use pln as a three dimension array the running time was cut
    +
    35C> 70 percent. Add following code to main program to compute eps, pln,
    +
    36C> trigs, and rcos one time in program.
    +
    37C> @code
    +
    38C> DOUBLE PRECISION EPS(992)
    +
    39C> DOUBLE PRECISION COLRA
    +
    40C>
    +
    41C> REAL PLN( 32, 31, 37 )
    +
    42C> REAL RCOS(37)
    +
    43C> REAL TRIGS(216)
    +
    44C>
    +
    45C> DATA PI /3.14159265/
    +
    46C>
    +
    47C> DRAD = 2.5 * PI / 180.0
    +
    48C> CALL W3FA11(EPS,30)
    +
    49C> CALL W3FA13(TRIGS,RCOS)
    +
    50C> DO LAT = 1,37
    +
    51C> COLRA = (LAT - 1) * DRAD
    +
    52C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    53C> END DO
    +
    54C> @endcode
    +
    55C>
    +
    56C> @author Ralph Jones @date 1992-07-23
    +
    +
    57 SUBROUTINE w3ft41(VLN,GN,PLN,FL,WORK,TRIGS,RCOS)
    +
    58C
    +
    59 COMPLEX FL( 31 )
    +
    60 COMPLEX VLN( 32 , 31 )
    +
    61C
    +
    62 REAL GN(145,37)
    +
    63 REAL PLN( 32, 31, 37 )
    +
    64 REAL RCOS(37)
    +
    65 REAL TRIGS(216)
    +
    66 REAL WORK(144)
    +
    67C
    +
    68 SAVE
    +
    69C
    +
    70 DO 400 lat = 2,37
    +
    71C
    +
    72 DO 100 l = 1, 31
    +
    73 fl(l) = (0.,0.)
    +
    74 100 CONTINUE
    +
    75C
    +
    76 DO 300 l = 1, 31
    +
    77C
    +
    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
    +
    84C
    +
    85 fl(l) = cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
    +
    86C
    +
    87 300 CONTINUE
    +
    88C
    +
    89 CALL w3ft12(fl,work,gn(1,lat ),trigs)
    +
    90C
    +
    91 400 CONTINUE
    +
    92C
    +
    93C*** POLE ROW = CLOSEST LATITUDE ROW
    +
    94C
    +
    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/w3ft43v_8f.html b/w3ft43v_8f.html index 93faa6fb..0d5693e2 100644 --- a/w3ft43v_8f.html +++ b/w3ft43v_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft43v.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ft43v.f File Reference
    +
    w3ft43v.f File Reference
    @@ -94,11 +100,11 @@

    Go to the source code of this file.

    - - - - + + +

    +

    Functions/Subroutines

    subroutine w3ft43v (ALOLA, APOLA, INTERP)
     Convert a global 1.0 degree lat.,lon. More...
     
    subroutine w3ft43v (alola, apola, interp)
     Convert a global 1.0 degree lat.,lon.
     

    Detailed Description

    Convert (361,181) grid to (65,65) n.

    @@ -107,8 +113,8 @@

    Definition in file w3ft43v.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ft43v()

    + +

    ◆ w3ft43v()

    @@ -117,19 +123,19 @@

    subroutine w3ft43v ( real, dimension(361,181)  - ALOLA, + alola, real, dimension(npts)  - APOLA, + apola,   - INTERP  + interp  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -176,7 +182,7 @@

    diff --git a/w3ft43v_8f.js b/w3ft43v_8f.js index 2b294ba4..9e804817 100644 --- a/w3ft43v_8f.js +++ b/w3ft43v_8f.js @@ -1,4 +1,4 @@ var w3ft43v_8f = [ - [ "w3ft43v", "w3ft43v_8f.html#a2296d6ab6d8638d5d0d59468cc6402d5", null ] + [ "w3ft43v", "w3ft43v_8f.html#a77e63a518c43c75ba9538080631c60fc", null ] ]; \ No newline at end of file diff --git a/w3ft43v_8f_source.html b/w3ft43v_8f_source.html index 486ec28e..689f9f67 100644 --- a/w3ft43v_8f_source.html +++ b/w3ft43v_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ft43v.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,273 +81,281 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ft43v.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Convert (361,181) grid to (65,65) n. hemi. grid.
    +
    3C> @author Ralph Jones @date 1993-03-29
    +
    4
    +
    5C> Convert a global 1.0 degree lat.,lon. 361 by
    +
    6C> 181 grid to a polar stereographic 65 by 65 grid. the polar
    +
    7C> stereographic map projection is true at 60 deg. n. , the mesh
    +
    8C> length is 381 km. and the oriention is 80 deg. w.
    +
    9C>
    +
    10C> ### Program History Log:
    +
    11C> Date | Programmer | Comment
    +
    12C> -----|------------|--------
    +
    13C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    14C>
    +
    15C> @param[in] ALOLA 361*181 grid 1.0 deg. lat,lon grid n. hemi.
    +
    16C> 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish
    +
    17C> added to right side to make 361 * 181.
    +
    18C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    19C> @param[out] APOLA 65*65 grid of northern hemisphere. 4225 point grid is
    +
    20C> o.n.84 type 27 or 1b hex
    +
    21C>
    +
    22C> @note
    +
    23C> - 1. W1 and w2 are used to store sets of constants which are
    +
    24C> reusable for repeated calls to the subroutine. 20 other arrays
    +
    25C> are saved and reused on the next calls to the subroutine.
    +
    26C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    27C> after interpolation. You may use w3fc08 to do this.
    +
    28C> - 3. The about 1100 points below the equator will be in this map.
    +
    29C>
    +
    30C> @author Ralph Jones @date 1993-03-29
    +
    +
    31 SUBROUTINE w3ft43v(ALOLA,APOLA,INTERP)
    +
    32C
    +
    33 parameter(npts=4225,ii=65,jj=65)
    +
    34 parameter(orient=80.0,ipole=33,jpole=33)
    +
    35 parameter(xmesh=381.0)
    +
    36C
    +
    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)
    +
    44C
    +
    45 INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46 INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47C
    +
    48 LOGICAL LIN
    +
    49C
    +
    50 SAVE
    +
    51C
    +
    52 equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    53C
    +
    54 DATA degprd/57.2957795/
    +
    55 DATA earthr/6371.2/
    +
    56 DATA intrpo/99/
    +
    57 DATA iswt /0/
    +
    58C
    +
    59 lin = .false.
    +
    60 IF (interp.EQ.1) lin = .true.
    +
    61C
    +
    62 IF (iswt.EQ.1) GO TO 900
    +
    63C
    +
    64 deg = 1.0
    +
    65 gi2 = (1.86603 * earthr) / xmesh
    +
    66 gi2 = gi2 * gi2
    +
    67C
    +
    68C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    69C
    +
    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
    +
    76C
    +
    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
    +
    82C
    +
    83 xii(2113) = 1.0
    +
    84 DO 300 kk = 1,npts
    +
    85 angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    86 300 CONTINUE
    +
    87C
    +
    88 DO 400 kk = 1,npts
    +
    89 IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    90 400 CONTINUE
    +
    91C
    +
    92 DO 500 kk = 1,npts
    +
    93 wlon(kk) = 270.0 + orient - angle(kk)
    +
    94 500 CONTINUE
    +
    95C
    +
    96 DO 600 kk = 1,npts
    +
    97 IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    98 600 CONTINUE
    +
    99C
    +
    100 DO 700 kk = 1,npts
    +
    101 IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    102 700 CONTINUE
    +
    103C
    +
    104 xlat(2113) = 90.0
    +
    105 wlon(2113) = 0.0
    +
    106C
    +
    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
    +
    111C
    +
    112 iswt = 1
    +
    113 intrpo = interp
    +
    114 GO TO 1000
    +
    115C
    +
    116C AFTER THE 1ST CALL TO W3FT43V TEST INTERP, IF IT HAS
    +
    117C CHANGED RECOMPUTE SOME CONSTANTS
    +
    118C
    +
    119 900 CONTINUE
    +
    120 IF (interp.EQ.intrpo) GO TO 2100
    +
    121 intrpo = interp
    +
    122C
    +
    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
    +
    133C
    +
    134 IF (lin) GO TO 1400
    +
    135C
    +
    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
    +
    144C
    +
    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
    +
    154C
    +
    155 1400 CONTINUE
    +
    156C
    +
    157 IF (lin) GO TO 1700
    +
    158C
    +
    159 DO 1500 kk = 1,npts
    +
    160 IF (jv(kk).GE.180) xj2tm(kk) = 0.0
    +
    161 1500 CONTINUE
    +
    162C
    +
    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
    +
    169C
    +
    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
    +
    177C
    +
    178C LINEAR INTERPOLATION
    +
    179C
    +
    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
    +
    184C
    +
    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
    +
    191C
    +
    192 2100 CONTINUE
    +
    193 IF (lin) THEN
    +
    194C
    +
    195C LINEAR INTERPOLATION
    +
    196C
    +
    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
    +
    203C
    +
    204 DO 2300 kk = 1,npts
    +
    205 apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    206 & * xdelj(kk)
    +
    207 2300 CONTINUE
    +
    208C
    +
    209 ELSE
    +
    210C
    +
    211C QUADRATIC INTERPOLATION
    +
    212C
    +
    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
    +
    235C
    +
    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
    +
    241C
    +
    242 ENDIF
    +
    243C
    +
    244C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    245C
    +
    246 apola(2113) = alola(181,181)
    +
    247C
    +
    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/w3kind_8f.html b/w3kind_8f.html index 2d699e25..eecb7a7e 100644 --- a/w3kind_8f.html +++ b/w3kind_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3kind.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3kind.f File Reference
    +
    w3kind.f File Reference
    @@ -94,10 +100,10 @@

    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...
    subroutine w3kind (kindreal, kindint)
     This subprogram returns the real kind and the integer kind that the w3 lib is compiled with.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3kind.f.

    Function/Subroutine Documentation

    - -

    ◆ w3kind()

    + +

    ◆ w3kind()

    @@ -134,7 +140,7 @@

    This subprogram returns the real kind and the integer kind that the w3 lib is compiled with.

    -

    +

    Program History Log:

    @@ -162,7 +168,7 @@

    diff --git a/w3kind_8f_source.html b/w3kind_8f_source.html index 794403c7..a01caace 100644 --- a/w3kind_8f_source.html +++ b/w3kind_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3kind.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,36 +81,44 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3kind.f
    +
    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
    +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/w3locdat_8f.html b/w3locdat_8f.html index 33155100..a78f2c09 100644 --- a/w3locdat_8f.html +++ b/w3locdat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3locdat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3locdat.f File Reference
    +
    w3locdat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    subroutine w3locdat (idat)
     This subprogram returns the local date and time in the ncep absolute date and time data structure.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3locdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3locdat()

    + +

    ◆ w3locdat()

    @@ -124,7 +130,7 @@

    This subprogram returns the local date and time in the ncep absolute date and time data structure.

    -

    +

    Program History Log:

    @@ -154,7 +160,7 @@

    diff --git a/w3locdat_8f_source.html b/w3locdat_8f_source.html index cd689948..16c74e89 100644 --- a/w3locdat_8f_source.html +++ b/w3locdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3locdat.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,35 +81,43 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3locdat.f
    +
    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
    +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/w3log_8f_source.html b/w3log_8f_source.html index 7e023f15..d9adf41a 100644 --- a/w3log_8f_source.html +++ b/w3log_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3log.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +
    @@ -76,25 +81,31 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3log.f
    +
    w3log.f
    -
    1  subroutine w3log
    -
    2  end
    +
    1 subroutine w3log
    +
    2 end
    diff --git a/w3miscan_8f.html b/w3miscan_8f.html index 1c43bd92..7026cfaf 100644 --- a/w3miscan_8f.html +++ b/w3miscan_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3miscan.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3miscan.f File Reference
    +
    w3miscan.f File Reference
    @@ -94,35 +100,35 @@

    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...
     
    subroutine misc01 (nnalg, gbalg, kdata, swnn, tpwnn, swgb, nrfgb)
     Prepares for in-line caluclation of prods.
     
    subroutine misc04 (inlsf, blat, blng, lstag)
     Returns land/sea tag for given lat/lon.
     
    subroutine misc05 (inlsf, numrgn,)
     Reads 2 records from land/sea tag database.
     
    subroutine misc06 (ingbi, ingbd, idat1, idat2,,,,)
     Reads in nh and sh 1-deg.
     
    subroutine misc10 (x, y)
     Calc.
     
    function risc02 (xt, v, l, sst, jerr)
     Calc.
     
    function risc02xx (x)
     Calc.
     
    function risc03 (x)
     Calc.
     
    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.
     

    Detailed Description

    Reads 1 ssm/i scan line from bufr d-set.

    @@ -131,8 +137,8 @@

    Definition in file w3miscan.f.

    Function/Subroutine Documentation

    - -

    ◆ misc01()

    + +

    ◆ misc01()

    @@ -141,43 +147,43 @@

    subroutine misc01 ( logical  - NNALG, + nnalg, logical  - GBALG, + gbalg, integer, dimension(7)  - KDATA, + kdata,   - SWNN, + swnn,   - TPWNN, + tpwnn,   - SWGB, + swgb,   - NRFGB  + nrfgb  @@ -190,7 +196,7 @@

    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:

    @@ -213,7 +219,7 @@

    -
    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().
    +
    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
    @@ -221,8 +227,8 @@

    - -

    ◆ misc04()

    + +

    ◆ misc04()

    @@ -231,25 +237,25 @@

    subroutine misc04 (   - INLSF, + inlsf,   - BLAT, + blat,   - BLNG, + blng,   - LSTAG  + lstag  @@ -262,7 +268,7 @@

    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:

    @@ -293,8 +299,8 @@

    - -

    ◆ misc05()

    + +

    ◆ misc05()

    @@ -303,13 +309,13 @@

    subroutine misc05

    - + - + @@ -322,7 +328,7 @@

    Author
    Dennis Keyser
    Date
    195-01-04 Reads two records from a low resolution land/sea database and stores into common.
    -

    +

    Program History Log:

    (  INLSF, inlsf,
     NUMRGN numrgn 
    @@ -348,8 +354,8 @@

    - -

    ◆ misc06()

    + +

    ◆ misc06()

    @@ -358,25 +364,25 @@

    subroutine misc06

    - + - + - + - + @@ -389,7 +395,7 @@

    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:

    (  INGBI, ingbi,
     INGBD, ingbd,
    integer, dimension(5) IDAT1, idat1,
    integer, dimension(5) IDAT2 idat2 
    @@ -417,8 +423,8 @@

    - -

    ◆ misc10()

    + +

    ◆ misc10()

    @@ -427,13 +433,13 @@

    subroutine misc10

    - + - + @@ -446,7 +452,7 @@

    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:

    ( dimension(in) X, x,
    dimension(out) Y y 
    @@ -461,7 +467,7 @@

    -
    Remarks
    Called by subroutine risc02().
    +
    Remarks
    Called by subroutine risc02().
    Author
    V. Krasnopolsky
    Date
    1996-07-15
    @@ -469,8 +475,8 @@

    - -

    ◆ risc02()

    + +

    ◆ risc02()

    @@ -479,31 +485,31 @@

    function risc02 ( real, dimension(7)  - XT, + xt, real  - V, + v, real  - L, + l, real  - SST, + sst,   - JERR  + jerr  @@ -516,7 +522,7 @@

    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:

    @@ -543,7 +549,7 @@

    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.
      • @@ -551,7 +557,7 @@

    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:

    - +
    ( dimension(in) X)x)
    @@ -586,7 +592,7 @@

    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:

    @@ -611,8 +617,8 @@

    - -

    ◆ risc03()

    + +

    ◆ risc03()

    @@ -621,7 +627,7 @@

    function risc03

    - +
    ( dimension(4) X)x)
    @@ -630,7 +636,7 @@

    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:

    @@ -653,8 +659,8 @@

    - -

    ◆ w3miscan()

    + +

    ◆ w3miscan()

    @@ -663,91 +669,91 @@

    subroutine w3miscan

    - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + @@ -759,7 +765,7 @@

    +

    Program History Log:

    (  INDTA, indta,
     INLSF, inlsf,
     INGBI, ingbi,
     INGBD, ingbd,
    logical, dimension(240:249) LSAT, lsat,
    logical LPROD, lprod,
    logical LBRIT, lbrit,
    logical NNALG, nnalg,
    logical GBALG, gbalg,
    integer, dimension(5) KDATE, kdate,
    integer, dimension(5) LDATE, ldate,
     IGNRTM, ignrtm,
    integer, dimension(1737) IBUFTN, ibuftn,
     IBDATE, ibdate,
     IER ier 
    @@ -838,7 +844,7 @@

    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:

    @@ -870,7 +876,7 @@

    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)}:

    @@ -902,7 +908,7 @@

    25 Retrieval #1 calculated surface type (code figure)
    -

    +

    For LBRIT = TRUE (Input brightness temperature file):

    @@ -922,7 +928,7 @@

    32 Retrieval #1 85 ghz h brightness temp (*100 deg. k)
    -

    +

    For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):

    @@ -932,7 +938,7 @@

    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):

    @@ -958,7 +964,7 @@

    diff --git a/w3miscan_8f.js b/w3miscan_8f.js index 00fcdccc..843f995c 100644 --- a/w3miscan_8f.js +++ b/w3miscan_8f.js @@ -1,12 +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 ] + [ "misc01", "w3miscan_8f.html#a77f06920ef1ce938ca29cc1ea7a18b56", null ], + [ "misc04", "w3miscan_8f.html#af225a39ea11be14a9d8ae53744bd70b1", null ], + [ "misc05", "w3miscan_8f.html#a6ebad02513c61fc41c51db9cf3bbaf7f", null ], + [ "misc06", "w3miscan_8f.html#a2fbfd745aaa9ecb372ff2524a682ccae", null ], + [ "misc10", "w3miscan_8f.html#ae39c3c17acb9b8b9e8865dce77e99179", null ], + [ "risc02", "w3miscan_8f.html#aae1710f52170633399d23802b4ad8b51", null ], + [ "risc02xx", "w3miscan_8f.html#aa99de7615b5b2a0f60a385c3be1ba9da", null ], + [ "risc03", "w3miscan_8f.html#ab194d2809f49e869082d6ae6b3b977c9", null ], + [ "w3miscan", "w3miscan_8f.html#aeeda29d4c214b97b0f8b9eb7f847f0db", null ] ]; \ No newline at end of file diff --git a/w3miscan_8f_source.html b/w3miscan_8f_source.html index 3dbb4859..945b15bb 100644 --- a/w3miscan_8f_source.html +++ b/w3miscan_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3miscan.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,1699 +81,1723 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3miscan.f
    +
    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
    -
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    -
    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
    -
    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
    -
    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
    -
    risc02xx
    function risc02xx(X)
    Calc.
    Definition: w3miscan.f:1352
    -
    risc02
    function risc02(XT, V, L, SST, JERR)
    Calc.
    Definition: w3miscan.f:1139
    -
    misc05
    subroutine misc05(INLSF, NUMRGN,)
    Reads 2 records from land/sea tag database.
    Definition: w3miscan.f:1518
    -
    risc03
    function risc03(X)
    Calc.
    Definition: w3miscan.f:1413
    -
    misc04
    subroutine misc04(INLSF, BLAT, BLNG, LSTAG)
    Returns land/sea tag for given lat/lon.
    Definition: w3miscan.f:1449
    -
    misc10
    subroutine misc10(X, Y)
    Calc.
    Definition: w3miscan.f:1238
    -
    misc06
    subroutine misc06(INGBI, INGBD, IDAT1, IDAT2,,,,)
    Reads in nh and sh 1-deg.
    Definition: w3miscan.f:1569
    -
    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
    -
    misc01
    subroutine misc01(NNALG, GBALG, KDATA, SWNN, TPWNN, SWGB, NRFGB)
    Prepares for in-line caluclation of prods.
    Definition: w3miscan.f:1007
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Reads 1 ssm/i scan line from bufr d-set
    +
    3C> @author Dennis Keyser @date 1996-07-30
    +
    4
    +
    5C> Reads one ssm/i scan line (64 retrievals) from the NCEP
    +
    6C> bufr ssm/i dump file. Each scan is time checked against the
    +
    7C> user-requested time window and satellite id combinations. When a
    +
    8C> valid scan is read the program returns to the calling program.
    +
    9C> the user must pass in the type of the input ssm/i dump file,
    +
    10C> either derived products (regardless of source) or brightness
    +
    11C> temperatures (7-channels). If the latter is chosen, the user
    +
    12C> has the further option of processing, in addition to the
    +
    13C> brightness temperatures, in-line calculation of wind speed
    +
    14C> product via the goodberlet algorithm, and/or in-line calculation
    +
    15C> of both wind speed and total column precipitable water (tpw)
    +
    16C> products using the neural net 3 algorithm. If the wind speed
    +
    17C> or tpw is calculated here (either algorithm), this subroutine
    +
    18C> will check for brightness temperatures outside of a preset range
    +
    19C> and will return a missing wind speed/tpw if any b. temp is
    +
    20C> unreasonable. Also, for calculated wind speeds and tpw, this
    +
    21C> program will check to see if the b. temps are over land or ice,
    +
    22C> and if they are it will also return missing values since these
    +
    23C> data are valid only over ocean.
    +
    24C>
    +
    25C> ### Program History Log:
    +
    26C> Date | Programmer | Comment
    +
    27C> -----|------------|--------
    +
    28C> 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
    +
    29C> 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
    +
    30C> 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)
    +
    31C> 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
    +
    32C> 1998-10-23 | Dennis Keyser | Subroutine now y2k and fortran 90 compliant
    +
    33C> 1999-02-18 | Dennis Keyser | Modified to compile and run properly on ibm-sp
    +
    34C> 2000-06-08 | Dennis Keyser | Corrected mnemonic for rain rate to "reqv" (was "prer" for some unknown reason)
    +
    35C> 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)
    +
    36C> 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}
    +
    37C> 2011-08-04 | Dennis Keyser | Add ibdate (input bufr message date) to output argument list (now used by calling program prepobs_prepssmi)
    +
    38C>
    +
    39C> @param[in] INDTA Unit number of ncep bufr ssm/i dump data set
    +
    40C> @param[in] INLSF Unit number of direct access nesdis land/sea file
    +
    41C> (valid only if lbrit and either nnalg or gbalg true).
    +
    42C> @param[in] INGBI Unit number of grib index file for grib file
    +
    43C> Containing global 1-degree sea-surface temp field.
    +
    44C> (valid only if lbrit and either nnalg or gbalg true).
    +
    45C> @param[in] INGBD Unit number of grib file containing global 1-degree
    +
    46C> Sea-surface temp field (valid only if lbrit and either.
    +
    47C> Nnalg or gbalg true).
    +
    48C> @param[in] LSAT 10-word logical array (240:249) indicating which
    +
    49C> Satellite ids should be processed (see remarks)
    +
    50C> @param[in] LPROD Logical indicating if the input bufr file contains
    +
    51C> Products (regardless of source) - in this case one or.
    +
    52C> More available products can be processed and returned.
    +
    53C> @param[in] LBRIT Logical indicating if the input bufr file contains
    +
    54C> Brightness temperatures - in this case b. temps are.
    +
    55C> Processed and returned along with, if requested, in-.
    +
    56C> Line generated products from one or both algorithms.
    +
    57C> (see next two switches).
    +
    58C> - The following two switches apply only if lbrit is true -----
    +
    59C> @param[in] NNALG Indicating if the subroutine should
    +
    60C> calculate and return ssm/i wind speed and tpw
    +
    61C> via the neural net 3 algorithm (note: b o t h
    +
    62C> wind speed and tpw are returned here)
    +
    63C> @param[in] GBALG Indicating if the subroutine should
    +
    64C> calculate and return ssm/i wind speed via the
    +
    65C> goodberlet algorithm
    +
    66C> @param[in] KDATE Requested earliest year(yyyy), month, day, hour,
    +
    67C> Min for accepting scans.
    +
    68C> @param[in] LDATE Requested latest year(yyyy), month, day, hour,
    +
    69C> Min for accepting scans.
    +
    70C> @param[in] IGNRTM Switch to indicate whether scans should be time-
    +
    71C> Checked (= 0) or not time checked (=1) {if =1, all.
    +
    72C> Scans read in are processed regardless of their time..
    +
    73C> The input arguments "kdate" and "ldate" (earliest and.
    +
    74C> Latest date for processing data) are ignored in the.
    +
    75C> Time checking for scans. (note: the earliest and.
    +
    76C> Latest dates should still be specified to the.
    +
    77C> "expected" time range, but they will not be used for.
    +
    78C> Time checking in this case)}.
    +
    79C> @param[out] IBUFTN Output buffer holding data for a scan (1737 words -
    +
    80C> See remarks for format. some words may be missing
    +
    81C> Depending upon lprod, lbrit, nnalg and gbalg
    +
    82C> @param[out] IBDATE Input bufr message section 1 date (yyyymmddhh)
    +
    83C> @param[out] IER Error return code (see remarks)
    +
    84C>
    +
    85C> @remark
    +
    86C> Return code ier can have the following values:
    +
    87C> - IER = 0 Successful return of scan
    +
    88C> - IER = 1 All scans have been read, all done
    +
    89C> - IER = 2 Abnormal return - input bufr file in unit
    +
    90C> 'indta' is either empty (null) or is not bufr
    +
    91C> - IER = 3 Abnormal return - requested earliest and
    +
    92C> latest dates are backwards
    +
    93C> - IER = 4 Abnormal return - error opening random
    +
    94C> access file holding land/sea tags
    +
    95C> - IER = 5 Abnormal return - the number of decoded
    +
    96C> "levels" is not what is expected
    +
    97C> - IER = 6 Abnormal return - sea-surface temperature
    +
    98C> not found in grib index file - error returned
    +
    99C> from grib decoder getgb is 96
    +
    100C> - IER = 7 Abnormal return - sea-surface temperature
    +
    101C> grib message has a date that is either:
    +
    102C> 1) more than 7-days prior to the earliest
    +
    103C> requested date or 2) more than 7-days after
    +
    104C> the latest requested date
    +
    105C> - IER = 8 Abnormal return - byte-addressable read error
    +
    106C> for grib file containing sea-surface
    +
    107C> temperature field - error returned from grib
    +
    108C> decoder getgb is 97-99
    +
    109C> - IER = 9 Abnormal return - error returned from grib
    +
    110C> decoder - getgb - for sea-surface
    +
    111C> temperature field - > 0 but not 96-99
    +
    112C>
    +
    113C> Input argument lsat is set-up as follows:
    +
    114C> - LSAT(X) = TRUE -- Process scans from satellite id x (where x is code figure from bufr code table 0-01-007)
    +
    115C> - LSAT(X) = FALSE - Do not process scans from satellite id x
    +
    116C> - X = 240 is f-7 dmsp satellite (this satellite is no longer available)
    +
    117C> - X = 241 is f-8 dmsp satellite (this satellite is no longer available)
    +
    118C> - X = 242 is f-9 dmsp satellite (this satellite is no longer available)
    +
    119C> - X = 243 is f-10 dmsp satellite (this satellite is no longer available)
    +
    120C> - 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)
    +
    121C> - X = 245 is f-12 dmsp satellite (this satellite is no longer available)
    +
    122C> - 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)
    +
    123C> - 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)
    +
    124C> - 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)
    +
    125C> - X = 249 is reserved for a future dmsp satellite
    +
    126C>
    +
    127C> @note Here "even" means value in ibuftn(1) is an odd number while "odd" means value in ibuftn(1) is an even number
    +
    128C> Contents of array 'ibuftn' holding one complete scan (64 individual retrievlas (1737 words)
    +
    129C>
    +
    130C> #### Always returned:
    +
    131C> WORD | CONTENTS
    +
    132C> ---- | --------
    +
    133C> 1 | Satellite id (244 is f-11; 246 is f-13; 247 is f-14; 248 is f-15)
    +
    134C> 2 | 4-digit year for scan
    +
    135C> 3 | 2-digit month of year for scan
    +
    136C> 4 | 2-digit day of month for scan
    +
    137C> 5 | 2-digit hour of day for scan
    +
    138C> 6 | 2-digit minute of hour for scan
    +
    139C> 7 | 2-digit second of minute for scan
    +
    140C> 8 | Scan number in orbit
    +
    141C> 9 | Orbit number for scan
    +
    142C> 10 | Retrieval #1 latitude (*100 degrees: + n, - s)
    +
    143C> 11 | Retrieval #1 longitude (*100 degrees east)
    +
    144C> 12 | Retrieval #1 position number
    +
    145C> 13 | Retrieval #1 surface tag (code figure)
    +
    146C>
    +
    147C> #### 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)}:
    +
    148C> WORD | CONTENTS
    +
    149C> ---- | --------
    +
    150C> 14 | Retrieval #1 cloud water (*100 kilogram/meter**2)
    +
    151C> 15 | Retrieval #1 rain rate (*1000000 millimeters/second)
    +
    152C> 16 | Retrieval #1 wind speed (*10 meters/second)
    +
    153C> 17 | Retrieval #1 soil moisture (millimeters)
    +
    154C> 18 | Retrieval #1 sea-ice concentration (per cent)
    +
    155C> 19 | Retrieval #1 sea-ice age (code figure)
    +
    156C> 20 | Retrieval #1 ice edge (code figure)
    +
    157C> 21 | Retrieval #1 total precip. water (*10 millimeters)
    +
    158C> 22 | Retrieval #1 surface temp (*100 k) if not over ocean -OR-
    +
    159C> 22 | Retrieval #1 sea-surface temp (*100 k) if over ocean
    +
    160C> 23 | Retrieval #1 snow depth (millimeters)
    +
    161C> 24 | Retrieval #1 rain flag (code figure)
    +
    162C> 25 | Retrieval #1 calculated surface type (code figure)
    +
    163C>
    +
    164C> #### For LBRIT = TRUE (Input brightness temperature file):
    +
    165C> WORD | CONTENTS
    +
    166C> ---- | --------
    +
    167C> 26 | Retrieval #1 19 ghz v brightness temp (*100 deg. k)
    +
    168C> 27 | Retrieval #1 19 ghz h brightness temp (*100 deg. k)
    +
    169C> 28 | Retrieval #1 22 ghz v brightness temp (*100 deg. k)
    +
    170C> 29 | Retrieval #1 37 ghz v brightness temp (*100 deg. k)
    +
    171C> 30 | Retrieval #1 37 ghz h brightness temp (*100 deg. k)
    +
    172C> 31 | Retrieval #1 85 ghz v brightness temp (*100 deg. k)
    +
    173C> 32 | Retrieval #1 85 ghz h brightness temp (*100 deg. k)
    +
    174C>
    +
    175C> #### For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):
    +
    176C> WORD | CONTENTS
    +
    177C> ---- | --------
    +
    178C> 33 | Retrieval #1 Neural net 3 algorithm wind speed (generated in-line) (*10 meters/second)
    +
    179C> 34 | Retrieval #1 Neural net 3 algorithm total precip. water (generated in-line) (*10 millimeters)
    +
    180C>
    +
    181C> #### For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):
    +
    182C> WORD | CONTENTS
    +
    183C> ---- | --------
    +
    184C> 35 | Retrieval #1 goodberlet algorithm wind speed (generated in-line) (*10 meters/second)
    +
    185C> 36 | Retrieval #1 goodberlet algorithm rain flag (code figure)
    +
    186C> 37-1737 | Repeat 10-36 for 63 more retrievals
    +
    187C>
    +
    188C> @note All missing data or data not selected by calling program are set to 99999
    +
    189C>
    +
    190C> @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
    +
    230C***********************************************************************
    +
    231C 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
    +
    272C DO REQUESTED EARLIEST AND LATEST DATES MAKE SENSE?
    +
    273
    +
    274 CALL w3difdat(ldat,kdat,3,rinc)
    +
    275 IF(rinc(3).LT.0) THEN
    +
    276C.......................................................................
    +
    277 print 103
    +
    278 103 FORMAT(' ##W3MISCAN: REQUESTED EARLIEST AND LATEST DATES ',
    +
    279 $ 'ARE BACKWARDS!! - IER = 3'/)
    +
    280 ier = 3
    +
    281 RETURN
    +
    282C.......................................................................
    +
    283 END IF
    +
    284
    +
    285C DETERMINE MACHINE WORD LENGTH IN BYTES AND TYPE OF CHARACTER SET
    +
    286C {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)
    +
    296cppppp
    +
    297 print *,'CENTER DATE (ICDATE) = ',icdate
    +
    298 print *,'DUMP DATE (IDDATE) = ',iddate
    +
    299cppppp
    +
    300
    +
    301C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
    +
    302C - RETURN WITH IRET = 2
    +
    303
    +
    304 IF(icdate(1).LE.0) GO TO 998
    +
    305
    +
    306C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
    +
    307C - RETURN WITH IRET = 2
    +
    308
    +
    309 IF(iddate(1).LE.0) GO TO 998
    +
    310 IF(icdate(1).LT.100) THEN
    +
    311
    +
    312C IF 2-DIGIT YEAR RETURNED IN ICDATE(1), MUST USE "WINDOWING" TECHNIQUE
    +
    313C TO CREATE A 4-DIGIT YEAR
    +
    314
    +
    315C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    316C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    317C 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
    +
    335C IF 2-DIGIT YEAR RETURNED IN IDDATE(1), MUST USE "WINDOWING" TECHNIQUE
    +
    336C TO CREATE A 4-DIGIT YEAR
    +
    337
    +
    338C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    339C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    340C 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
    +
    356C 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
    +
    364C Check to see if the old (pre 9/2004) version of the mnemonic
    +
    365C table is being used here (had "PH2O" instead of "TPWT",
    +
    366C "SNDP" instead of "TOSD", "WSOS" instead of "WSPD")
    +
    367C ------------------------------------------------------------
    +
    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
    +
    377C-----------------------------------------------------------------------
    +
    378C IF IN-LINE CALC. OF WIND SPEED FROM GOODBERLET ALG. OR
    +
    379C IN-LINE CALCULATION OF WIND SPEED AND TPW FROM NEURAL NET 3 ALG.
    +
    380C FIRST CALL TO THIS SUBROUTINE WILL READ IN SEA-SURFACE TEMPERATURE
    +
    381C FIELD AS A CHECK FOR ICE LIMITS
    +
    382C WILL ALSO OPEN DIRECT ACCESS NESDIS LAND SEA FILE
    +
    383C-----------------------------------------------------------------------
    +
    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
    +
    392C 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
    +
    401C***********************************************************************
    +
    402
    +
    403 END IF
    +
    404
    +
    405 30 CONTINUE
    +
    406
    +
    407C 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
    +
    413C 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
    +
    421c.......................................................................
    +
    422
    +
    423C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ
    +
    424C - ALL FINISHED, NO OTHER SCANS W/I DESIRED TIME RANGE -- SET IER TO 1
    +
    425C 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
    +
    477C.......................................................................
    +
    478 END IF
    +
    479
    +
    480 GO TO 30
    +
    481 END IF
    +
    482
    +
    483C***********************************************************************
    +
    484C COME HERE FOR BOTH PRODUCTS AND BRIGHTNESS TEMPERATURES
    +
    485C***********************************************************************
    +
    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
    +
    491C STORE THE SCAN'S SATELLITE ID IN WORD 1
    +
    492C STORE SCAN'S YEAR (YYYY), MONTH, DAY, HOUR, MIN, SEC INTO WORDS 2-7
    +
    493C STORE THE SCAN NUMBER IN WORD 8
    +
    494C STORE THE SCAN'S ORBIT NUMBER IN WORD 9
    +
    495
    +
    496 ibuftn(1:9) = min(imsg,nint(shdr(1:9)))
    +
    497
    +
    498C 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
    +
    506CDAK 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
    +
    515C 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
    +
    526C TIME CHECK FOR SCAN FAILED: GO ON TO NEXT SCAN
    +
    527
    +
    528CDAK 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
    +
    542C THIS ROUTINE EXPECTS LONGITUDE TO BE 0-360 E; BUFR NOW RETURNS -180-0
    +
    543C FOR WEST AND 0-180 FOR EAST
    +
    544
    +
    545 IF(rhdr(2,irt).LT.0.0) rhdr(2,irt) = rhdr(2,irt) + 360.
    +
    546C-----------------------------------------------------------------------
    +
    547C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
    +
    548C-----------------------------------------------------------------------
    +
    549C 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
    +
    555C.......................................................................
    +
    556
    +
    557C 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
    +
    565C.......................................................................
    +
    566
    +
    567 END IF
    +
    568
    +
    569C 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
    +
    577C.......................................................................
    +
    578
    +
    579C 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
    +
    587C.......................................................................
    +
    588
    +
    589 END IF
    +
    590 IF(iflag(irt).NE.0) GO TO 110
    +
    591
    +
    592C STORE THE POSITION NUMBER
    +
    593
    +
    594 ibuftn((27*irt)-15) = min(imsg,nint(rhdr(3,irt)))
    +
    595
    +
    596C STORE THE SURFACE TAG (0-6)
    +
    597
    +
    598 ibuftn((27*irt)-14) = min(imsg,nint(rhdr(4,irt)))
    +
    599 110 CONTINUE
    +
    600C-----------------------------------------------------------------------
    +
    601 END DO
    +
    602
    +
    603 IF(lprod) THEN
    +
    604C***********************************************************************
    +
    605C COME HERE TO PROCESS PRODUCTS FROM INPUT SSM/I PRODUCTS FILE
    +
    606C***********************************************************************
    +
    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
    +
    649C-----------------------------------------------------------------------
    +
    650C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
    +
    651C-----------------------------------------------------------------------
    +
    652 IF(iflag(irt).NE.0) GO TO 111
    +
    653
    +
    654C 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
    +
    659C STORE THE RAIN RATE (*1000000 KG/((M**2)*SEC)) IF AVAILABLE
    +
    660C (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
    +
    665C STORE THE WIND SPEED (*10 M/SEC) IF AVAILABLE
    +
    666
    +
    667 ibuftn((27*irt)-11) = min(imsg,nint(prod(03,irt)*10.))
    +
    668
    +
    669C 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
    +
    674C STORE THE SEA ICE CONCENTRATION (PERCENT) IF AVAILABLE
    +
    675
    +
    676 ibuftn((27*irt)-09) = min(imsg,nint(prod(05,irt)))
    +
    677
    +
    678C STORE THE SEA ICE AGE (0,1) IF AVAILABLE
    +
    679
    +
    680 ibuftn((27*irt)-08) = min(imsg,nint(prod(06,irt)))
    +
    681
    +
    682C STORE THE ICE EDGE (0,1) IF AVAILABLE
    +
    683
    +
    684 ibuftn((27*irt)-07) = min(imsg,nint(prod(07,irt)))
    +
    685
    +
    686C STORE THE WATER VAPOR (*10 KG/M**2) IF AVAILABLE
    +
    687C (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
    +
    693C STORE THE SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE
    +
    694C (NOTE: SURFACE TAG MUST NOT BE 5)
    +
    695
    +
    696 ibuftn((27*irt)-05) = min(imsg,nint(prod(09,irt)*100.))
    +
    697
    +
    698 ELSE
    +
    699
    +
    700C STORE THE SEA-SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE
    +
    701C (NOTE: SURFACE TAG MUST BE 5)
    +
    702
    +
    703 ibuftn((27*irt)-05) = min(imsg,nint(prod(13,irt)*100.))
    +
    704
    +
    705 END IF
    +
    706
    +
    707C 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
    +
    712C STORE THE RAIN FLAG (0-3) IF AVAILABLE
    +
    713
    +
    714 ibuftn((27*irt)-03) = min(imsg,nint(prod(11,irt)))
    +
    715
    +
    716C STORE THE CALCULATED SURFACE TYPE (1-20) IF AVAILABLE
    +
    717
    +
    718 ibuftn((27*irt)-02) = min(imsg,nint(prod(12,irt)))
    +
    719 111 CONTINUE
    +
    720C-----------------------------------------------------------------------
    +
    721 END DO
    +
    722 END IF
    +
    723 900 CONTINUE
    +
    724
    +
    725 IF(lbrit) THEN
    +
    726C***********************************************************************
    +
    727C COME HERE TO PROCESS BRIGHTNESS TEMPERATURES FROM INPUT SSM/I
    +
    728C BRIGHTNESS TEMPERATURE FILE
    +
    729C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG.
    +
    730C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA N. NET 3 ALG.
    +
    731C***********************************************************************
    +
    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
    +
    746C-----------------------------------------------------------------------
    +
    747C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
    +
    748C-----------------------------------------------------------------------
    +
    749 IF(iflag(irt).NE.0) GO TO 112
    +
    750
    +
    751C STORE THE 7 BRIGHTNESS TEMPS (*100 DEGREES KELVIN)
    +
    752C -- CHANNELS ARE IN THIS ORDER FOR A PARTICULAR RETRIEVAL:
    +
    753C 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
    +
    770C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    771C COME HERE FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. AND/OR
    +
    772C FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA NEURAL NET 3 ALG.
    +
    773C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    774
    +
    775C 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
    +
    785C ..... 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
    +
    792C ..... 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
    +
    811C 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
    +
    816CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 6021, ATXT(1),SWNN,
    +
    817CDAK $ TPWNN,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100.,
    +
    818CDAK $ 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
    +
    822C STORE THE CALCULATED NEURAL NET 3 WIND SPEED (*10 M/SEC)
    +
    823
    +
    824 ibuftn((27*irt)+6) = min(imsg,nint(swnn*10.))
    +
    825
    +
    826C 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
    +
    832CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 602, ATXT(2),NRFGB,
    +
    833CDAK $ SWGB,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100.,
    +
    834CDAK $ 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
    +
    838C STORE THE CALCULATED GOODBERLET WIND SPEED (*10 M/SEC)
    +
    839
    +
    840 ibuftn((27*irt)+8) = min(imsg,nint(swgb*10.))
    +
    841
    +
    842C STORE THE GOODBERLET RAIN FLAG (0-3)
    +
    843
    +
    844 ibuftn((27*irt)+9) = min(imsg,nrfgb)
    +
    845 END IF
    +
    846
    +
    847C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    848 ELSE
    +
    849
    +
    850C......................................................................
    +
    851
    +
    852C 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.')
    +
    857C......................................................................
    +
    858
    +
    859 END IF
    +
    860 END IF
    +
    861
    +
    862 112 CONTINUE
    +
    863C-----------------------------------------------------------------------
    +
    864 END DO
    +
    865 END IF
    +
    866C***********************************************************************
    +
    867 901 CONTINUE
    +
    868
    +
    869C 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
    +
    876C.......................................................................
    +
    877 993 CONTINUE
    +
    878
    +
    879C PROBLEM: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB INDEX FILE - ERROR
    +
    880C 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
    +
    888C.......................................................................
    +
    889 994 CONTINUE
    +
    890
    +
    891C PROBLEM: SEA-SURFACE TEMPERATURE GRIB MESSAGE HAS A DATE THAT IS
    +
    892C EITHER: 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST REQ. DATE
    +
    893C (INPUT ARG. "KDATE") OR 2) MORE THAN 7-DAYS AFTER THE LATEST
    +
    894C 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
    +
    903C.......................................................................
    +
    904 995 CONTINUE
    +
    905
    +
    906C PROBLEM: BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE CONTAINING SEA-
    +
    907C SURFACE TEMPERATURE FIELD - ERROR RETURNED FROM GRIB DECODER
    +
    908C 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
    +
    916C.......................................................................
    +
    917 996 CONTINUE
    +
    918
    +
    919C PROBLEM: ERROR RETURNED FROM GRIB DECODER - GETGB - FOR SEA-SURFACE
    +
    920C 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
    +
    927C.......................................................................
    +
    928 997 CONTINUE
    +
    929
    +
    930C PROBLEM: ERROR OPENING R. ACCESS FILE HOLDING LAND/SEA TAGS - SET IER
    +
    931C = 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
    +
    939C.......................................................................
    +
    940 998 CONTINUE
    +
    941
    +
    942C PROBLEM: THE INPUT DATA SET IS EITHER EMPTY (NULL), NOT BUFR, OR
    +
    943C 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
    +
    951C.......................................................................
    +
    952 999 CONTINUE
    +
    953
    +
    954C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED - SET
    +
    955C 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
    +
    963C.......................................................................
    +
    +
    964 END
    +
    965C> @brief Prepares for in-line caluclation of prods.
    +
    966C> @author Dennis Keyser @date 1995-01-04
    +
    967
    +
    968C> Based on input 7-channel ssm/i brightness temperatures,
    +
    969C> determines the rain flag category for wind speed product for the
    +
    970C> goodberlet algorithm. Then calls the appropriate function to
    +
    971C> calculate either the wind speed product for the goodberlet
    +
    972C> algorithm (if requested) or the wind speed and tpw products for
    +
    973C> the neural net 3 algorithm (if requested).
    +
    974C>
    +
    975C> ### Program History Log:
    +
    976C> Date | Programmer | Comment
    +
    977C> -----|------------|--------
    +
    978C> ????-??-?? | W. Gemmill | (w/nmc21) -- original author
    +
    979C> 1995-01-04 | Dennis Keyser | -- incorporated into w3miscan and
    +
    980C> streamlined code
    +
    981C> 1996-05-07 | Dennis Keyser | (np22) -- in-line neural network 1 algoritm
    +
    982C> replaced by neural network 2 algorithm
    +
    983C> 1996-07-30 | Dennis Keyser | (np22) -- can now process wind speed from
    +
    984C> both algorithms if desired
    +
    985C> 1998-01-28 | Dennis Keyser | (np22) -- replaced neural net 2 algorithm
    +
    986C> which calculated only wind speed product with neural net 3
    +
    987C> algorithm which calculates both wind speed and total
    +
    988C> precipitable water products (among others) but, unlike nn2,
    +
    989C> does not return a rain flag value (it does set all retrievals
    +
    990C> to missing that fail rain flag and ice contamination tests)
    +
    991C>
    +
    992C> @param[in] NNALG Process wind speed and tpw via neural net 3 algorithm if true
    +
    993C> @param[in] GBALG Process wind speed via goodberlet algorithm if true
    +
    994C> @param[in] KDATA 7-word array containing 7 channels of brightness temperature (kelvin x 100)
    +
    995C> @param[out] SWNN alculated wind speed based on neural net 3 algorithm (meters/second)
    +
    996C> @param[out] TPWNN Calculated total column precipitable water based on neural net 3 algorithm (millimeters)
    +
    997C> @param[out] SWGB Calculated wind speed based on goodberlet algorith (meters/second)
    +
    998C> @param[out] NRFGB Rain flag category for calculated wind speed from goodberlet algorithm
    +
    999C>
    +
    1000C> @remark If an algorithm is not chosen, the output products are set
    +
    1001C> to values of 99999. for that algorithm and, for the goodberlet
    +
    1002C> algorithm only, the rain flag is set to 99999. Called by
    +
    1003C> subroutine w3miscan().
    +
    1004C>
    +
    1005C> @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
    +
    1030C COMPUTE WIND SPEED FROM NEURAL NET 2 ALGORITHM (1995)
    +
    1031C (no longer a possibility - subr. expects dim. of 5 on BTAA)
    +
    1032cdak NRFNN = 1
    +
    1033cdak IF(TB19H.LE.185.0.AND.TB37H.LE.210.0.AND.TB19V.LT.TB37V)
    +
    1034cdak $ NRFNN = 0
    +
    1035cdak BTAA(1) = TB19V
    +
    1036cdak BTAA(2) = TB22V
    +
    1037cdak BTAA(3) = TB37V
    +
    1038cdak BTAA(4) = TB37H
    +
    1039cdak BTAA(5) = TB85V
    +
    1040cdak SWNN = RISC02xx(BTAA)
    +
    1041
    +
    1042C 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
    +
    1056C 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
    +
    1072C> @brief Calc. ssm/i prods from neural net 3 alg.
    +
    1073C> @author V. Krasnopolsky @date 1997-02-02
    +
    1074
    +
    1075C> This retrieval algorithm is a neural network implementation
    +
    1076C> of the ssm/i transfer function. It retrieves the wind speed (w)
    +
    1077C> at the height 20 meters, columnar water vapor (v), columnar liquid
    +
    1078C> water (l) and sst. The nn was trained using back-propagation
    +
    1079C> algorithm. Transfer function is described and compared with
    +
    1080C> cal/val and other algorithms in omb technical note no. 137. See
    +
    1081C> remarks for detailed info on this algorithm. This is an improved
    +
    1082C> version of the earlier neural network 2 algorithm.
    +
    1083C>
    +
    1084C> ### Program History Log:
    +
    1085C> Date | Programmer | Comment
    +
    1086C> -----|------------|--------
    +
    1087C> 1997-02-02 | V. Krasnopolsky | Initial.
    +
    1088C>
    +
    1089C> @param[in] XT 7-word array containing brightness temperature in the order:
    +
    1090C> t19v (word 1), t19h (word 2), t22v (word 3), t37v (word 4), t37h (word 5),
    +
    1091C> t85v (word 6), t85h (word 7) (all in kelvin)
    +
    1092C> @param[in] V Columnar water vapor (total precip. water) (mm)
    +
    1093C> @param[in] L Columnar liquid water (mm)
    +
    1094C> @param[in] SST Sea surface temperature (deg. c)
    +
    1095C> @param[in] JERR Error return code:
    +
    1096C> - = 0 -- Good retrievals
    +
    1097C> - = 1 -- Retrievals could not be made due to one or
    +
    1098C> more brightness temperatures out of range
    +
    1099C> (i.e, failed the rain flag test)
    +
    1100C> - = 2 -- Retrievals could not be made due to ice
    +
    1101C> contamination
    +
    1102C> {for either 1 or 2 above, all retrievals set to
    +
    1103C> 99999. (missing)}
    +
    1104C>
    +
    1105C> @remark Function, called by subroutine misc01.
    +
    1106C> Description of training and test data set:
    +
    1107C> ------------------------------------------
    +
    1108C> The training set consists of 3460 matchups which were received
    +
    1109C> from two sources:
    +
    1110C> - 1. 3187 F11/SSMI/buoy matchups were filtered out from a
    +
    1111C> preliminary version of the new NRL database which was
    +
    1112C> kindly provided by G. Poe (NRL). Maximum available wind
    +
    1113C> speed is 24 m/s.
    +
    1114C> - 2. 273 F11/SSMI/OWS matchups were filtered out from two
    +
    1115C> datasets collected by high latitude OWS LIMA and MIKE.
    +
    1116C> These data sets were kindly provided by D. Kilham
    +
    1117C> (University of Bristol). Maximum available wind speed
    +
    1118C> is 26.4 m/s.
    +
    1119C>
    +
    1120C> Satellite data are collocated with both buoy and OWS data in
    +
    1121C> space within 15 km and in time within 15 min.
    +
    1122C>
    +
    1123C> The test data set has the same structure, the same number of
    +
    1124C> matchups and maximum buoy wind speed.
    +
    1125C>
    +
    1126C> Description of retrieval flags:
    +
    1127C> -------------------------------
    +
    1128C> Retrieval flags by Stogryn et al. are used. The algorithm
    +
    1129C> produces retrievals under CLEAR + CLOUDY conditions, that is
    +
    1130C> if:
    +
    1131C> - T37V - T37H > 50. => CLEAR condition -or-
    +
    1132C> - T37V - T37H =< 50.|
    +
    1133C> - T19H =< 185. and |
    +
    1134C> - T37H =< 210. and | => CLOUDY conditions
    +
    1135C> - T19V < T37V |
    +
    1136C>
    +
    1137C> @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
    +
    1146C -------- Retrieval flag (Stogryn) -------------------------
    +
    1147
    +
    1148C T19H =< 185
    +
    1149
    +
    1150 lq1 = (xt(2).LE.185.)
    +
    1151
    +
    1152C T37H =< 210
    +
    1153
    +
    1154 lq2 = (xt(5).LE.210.)
    +
    1155
    +
    1156C T19V < T37V
    +
    1157
    +
    1158 lq3 = (xt(1).LT.xt(4))
    +
    1159
    +
    1160C 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
    +
    1173C --------------- Call NN ----------------------
    +
    1174
    +
    1175C NN WIND SPEED
    +
    1176
    +
    1177 CALL misc10(xt,y)
    +
    1178 v = y(2)
    +
    1179 l = y(3)
    +
    1180 sst = y(4)
    +
    1181
    +
    1182C --------- 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
    +
    1188C ------ 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
    +
    1212C> @brief Calc. ssm/i prods from neural net 3 alg.
    +
    1213C> @author V. Krasnopolsky @date 1996-07-15
    +
    1214
    +
    1215C> This nn calculates w (in m/s), v (in mm), l (in mm), and
    +
    1216C> sst (in deg c). This nn was trained on blended f11 data set
    +
    1217C> (ssmi/buoy matchups plus ssmi/ows matchups 15 km x 15 min) under
    +
    1218C> clear + cloudy conditions.
    +
    1219C>
    +
    1220C> ### Program History Log:
    +
    1221C> Date | Programmer | Comment
    +
    1222C> -----|------------|--------
    +
    1223C> 1996-07-15 | V. Krasnopolsky | Initial.
    +
    1224C>
    +
    1225C> @param[in] X 5-word array containing brightness temperature in the
    +
    1226C> order: t19v (word 1), t19h (word 2), t22v (word 3),
    +
    1227C> t37v (word 4), t37h (word 5) (all in kelvin)
    +
    1228C> @param[out] Y 4-word array containing calculated products in the
    +
    1229C> order: wind speed (m/s) (word 1), columnar water
    +
    1230C> vapor (total precip. water) (mm) (word 2), columnar
    +
    1231C> liquid water (mm) (word 3), sea surface temperature
    +
    1232C> (deg. c) (word 4)
    +
    1233C>
    +
    1234C> @remark Called by subroutine risc02().
    +
    1235C>
    +
    1236C> @author V. Krasnopolsky @date 1996-07-15
    +
    +
    1237 SUBROUTINE misc10(X,Y)
    +
    1238 INTEGER HID,OUT
    +
    1239
    +
    1240C IN IS THE NUMBER OF NN INPUTS, HID IS THE NUMBER OF HIDDEN NODES,
    +
    1241C 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
    +
    1247C 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
    +
    1262C 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
    +
    1275C 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
    +
    1281C B2 HOLDS OUTPUT BIAS
    +
    1282
    +
    1283 DATA (b2(i), i=1,out)/-0.882873,-0.0120802,-3.19400,1.00314/
    +
    1284
    +
    1285C 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
    +
    1290C INITIALIZE
    +
    1291
    +
    1292 o1 = x
    +
    1293
    +
    1294C START NEURAL NETWORK
    +
    1295
    +
    1296C - 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
    +
    1307C - 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
    +
    1317C --- 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
    +
    1325C> @brief Calc. wspd from neural net 2 algorithm
    +
    1326C> @author V. Krasnopolsky @date 1996-05-07
    +
    1327
    +
    1328C> Calculates a single neural network output for wind speed.
    +
    1329C> the network was trained on the whole data set without any
    +
    1330C> separation into subsets. It gives rms = 1.64 m/s for training set
    +
    1331C> and 1.65 m/s for testing set. This is an improved version of the
    +
    1332C> earlier neural network 1 algorithm.
    +
    1333C>
    +
    1334C> ### Program History Log:
    +
    1335C> Date | Programmer | Comment
    +
    1336C> -----|------------|--------
    +
    1337C> 1994-03-20 | V. Krasnopolsky | Initial.
    +
    1338C> 1995-05-07 | V. Krasnopolsky | Replaced with neural net 2 algorithm.
    +
    1339C>
    +
    1340C> @param[in] X 5-Word array containing brightness temperature in the
    +
    1341C> order: t19v (word 1), t22v (word 2), t37v (word 3),
    +
    1342C> t37h (word 4), t85v (word 5) (all in kelvin)
    +
    1343C> @return XX Wind speed (meters/second)
    +
    1344C>
    +
    1345C> @remark Function, no longer called by this program. It is here
    +
    1346C> simply to save neural net 2 algorithm for possible later use
    +
    1347C> (has been replaced by neural net 3 algorithm, see subr. risc02
    +
    1348C> and misc10).
    +
    1349C>
    +
    1350C> @author V. Krasnopolsky @date 1996-05-07
    +
    +
    1351 FUNCTION risc02xx(X)
    +
    1352 INTEGER hid
    +
    1353C 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
    +
    1359C 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/
    +
    1364C W2 HOLDS HIDDEN WEIGHTS
    +
    1365 DATA (w2(i),i=1,hid)/8.705661e-01,1.430968/
    +
    1366C B1 HOLDS HIDDEN BIASES
    +
    1367 DATA (b1(i),i=1,hid)/-6.436114,8.799655/
    +
    1368C B2 HOLDS OUTPUT BIAS
    +
    1369C AY AND BY HOLD OUTPUT TRANSFORMATION COEFFICIENTS
    +
    1370 DATA b2/-0.736255/,ay/16.7833/,by/11.08/
    +
    1371 o1 = x
    +
    1372C 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)
    +
    1388C BIAS CORRECTION
    +
    1389 bias = 0.5 + 0.004*((risc02xx-10.)**3)*(1.-exp(-0.5*risc02xx))
    +
    1390 risc02xx = risc02xx + bias
    +
    1391 RETURN
    +
    +
    1392 END
    +
    1393C> @brief Calc. w.spd from b temp.- goodberlet alg.
    +
    1394C> @author W. Gemmill @date 1994-08-15
    +
    1395
    +
    1396C> Calculates a single goodberlet output for wind speed.
    +
    1397C> This is a linear regression algorithm from 1989.
    +
    1398C>
    +
    1399C> ### Program History Log:
    +
    1400C> Date | Programmer | Comment
    +
    1401C> -----|------------|--------
    +
    1402C> 1994-08-15 | W. Gemmill | Initial.
    +
    1403C>
    +
    1404C> @param[in] X 4-word array containing brightness temperature in the
    +
    1405C> order: t19v (word 1), t22v (word 2), t37v (word 3),
    +
    1406C> t37h (word 4) (all in kelvin)
    +
    1407C> @return XX Wind speed (meters/second)
    +
    1408C>
    +
    1409C> @remark Function, called by subroutine misc01.
    +
    1410C>
    +
    1411C> @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
    +
    1421C> @brief Returns land/sea tag for given lat/lon
    +
    1422C> @author Dennis Keyser @date 1995-01-04
    +
    1423
    +
    1424C> Finds and returns the low resolution land/sea tag nearest
    +
    1425C> to the requested latitude and longitude.
    +
    1426C>
    +
    1427C> ### Program History Log:
    +
    1428C> Date | Programmer | Comment
    +
    1429C> -----|------------|--------
    +
    1430C> 1978-01-20 | J. K. Kalinowski (S11213) | Original author
    +
    1431C> 1978-10-03 | J. K. Kalinowski (S1214) | Changes unknown
    +
    1432C> 1985-03-01 | N. Digirolamo (SSAI) | Conversion to vs fortran
    +
    1433C> 1995-01-04 | Dennis Keyser | Incorporated into w3miscan and streamlined code
    +
    1434C>
    +
    1435C> @param[in] INLSF Unit number of direct access nesdis land/sea file
    +
    1436C> @param[in] BLAT Latitude (whole degrees: range is 0. to +90. north,
    +
    1437C> 0. to -90. south)
    +
    1438C> @param[in] BLNG Longitude (whole degrees: range is 0. to +179.99 east,
    +
    1439C> 0. to -180. west)
    +
    1440C> @param[out] LSTAG Land/sea tag {=0 - sea; =1 - land; =2 - coastal
    +
    1441C> interface (higher resolution tags are available);
    +
    1442C> =3 - coastal interface (no higher resolution tags
    +
    1443C> exist)}
    +
    1444C>
    +
    1445C> @remark Called by subroutine w3miscan.
    +
    1446C>
    +
    1447C> @author Dennis Keyser @date 1995-01-04
    +
    +
    1448 SUBROUTINE misc04(INLSF,BLAT,BLNG,LSTAG)
    +
    1449 CHARACTER*1 LPUT
    +
    1450 REAL RGS(3)
    +
    1451C LPUT CONTAINS A REGION OF LAND/SEA TAGS (RETURNED FROM CALL TO MISC05)
    +
    1452 common/miscdd/lput(21960)
    +
    1453
    +
    1454 SAVE
    +
    1455
    +
    1456C RGS IS ARRAY HOLDING SOUTHERN BOUNDARIES OF EACH LAND/SEA TAG REGION
    +
    1457 DATA rgs/-85.,-30.,25./,numrgl/0/,iflag/0/
    +
    1458C INITIALIZE LAND/SEA TAG AS 1 (OVER LAND)
    +
    1459 lstag = 1
    +
    1460C FIND NEAREST POINT OF A HALF-DEGREE (LAT,LONG) GRID
    +
    1461C ..ALAT IS LATITUDE TO THE NEAREST HALF-DEGREE
    +
    1462 alat = int((blat+sign(.25,blat))/.5) * .5
    +
    1463C ..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.
    +
    1466C 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
    +
    1479C 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)
    +
    1482C ..NBYTE IS THE BYTE IN LPUT CONTAINING THE TAG
    +
    1483 nbyte = (180 * 8) + (lstpt/4 * 8)
    +
    1484 nshft = (2 * (mod(lstpt,4) + 1)) - 2
    +
    1485C PULL OUT THE TAG
    +
    1486 CALL gbyte(lput,lstag,nbyte+nshft,2)
    +
    1487 iflag = 0
    +
    1488 RETURN
    +
    1489C-----------------------------------------------------------------------
    +
    1490 99 CONTINUE
    +
    1491C COME HERE IF LAND/SEA TAG COULD NOT BE RETURNED FROM SUBR. W3MISCAN
    +
    1492C (IN THIS CASE IT WILL REMAIN SET TO 1 INDICATING OVER LAND)
    +
    1493 iflag = 1
    +
    1494 RETURN
    +
    1495C-----------------------------------------------------------------------
    +
    +
    1496 END
    +
    1497C> @brief Reads 2 records from land/sea tag database
    +
    1498C> @author Dennis Keyser @date 195-01-04
    +
    1499
    +
    1500C> Reads two records from a low resolution land/sea database and stores into common.
    +
    1501C>
    +
    1502C> ### Program History Log:
    +
    1503C> Date | Programmer | Comment
    +
    1504C> -----|------------|--------
    +
    1505C> 1978-01-20 | J. K. Kalinowski (S11213) | Original author
    +
    1506C> 1995-01-04 | Dennis Keyser | Incorporated into w3miscan and
    +
    1507C> streamlined code; modified to be machine independent thru
    +
    1508C> use of standard fortran direct access read
    +
    1509C>
    +
    1510C> @param[in] INLSF Unit number of direct access nesdis land/sea file
    +
    1511C> @param[in] NUMRGN The region (1,2 or 3) of the database to be accessed
    +
    1512C> (dependent on latitude band)
    +
    1513C>
    +
    1514C> @remark Called by subroutne misc04.
    +
    1515C>
    +
    1516C> @author Dennis Keyser @date 195-01-04
    +
    +
    1517 SUBROUTINE misc05(INLSF,NUMRGN,*)
    +
    1518 CHARACTER*1 LPUT
    +
    1519
    +
    1520C LPUT CONTAINS A REGION OF LAND/SEA TAGS (COMPRISED OF 2 RECORDS FROM
    +
    1521C LAND/SEA FILE) -- 180 BYTES OF DOCUMENTATION FOLLOWED BY 21780 BYTES
    +
    1522C 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
    +
    1533C-----------------------------------------------------------------------
    +
    1534 10 CONTINUE
    +
    1535C ERROR READING IN A RECORD FROM LAND-SEA FILE -- RETURN (TAG WILL BE
    +
    1536C 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
    +
    1541C-----------------------------------------------------------------------
    +
    +
    1542 END
    +
    1543C> @brief Reads in nh and sh 1-deg. sea-sfc temps.
    +
    1544C> @author Dennis Keyser @date 200-02-18
    +
    1545
    +
    1546C> Reads in global sea-surface temperature field on a one-degree grid from grib file.
    +
    1547C>
    +
    1548C> ### Program History Log:
    +
    1549C> Date | Programmer | Comment
    +
    1550C> -----|------------|--------
    +
    1551C> ????-??-?? | W. Gemmill (NP21) | Original author
    +
    1552C> 1995-01-04 | Dennis Keyser | Incorporated into w3miscan and
    +
    1553C> streamlined code; converted sst input file from vsam/on84 to
    +
    1554C> grib to allow code compile and run on the cray machines.
    +
    1555C> 2000-02-18 | Dennis Keyser | Modified to call w3lib routine "getgb",
    +
    1556C> this allows code to compile and run properly on ibm-sp
    +
    1557C>
    +
    1558C> @param[in] INGBI Unit number of grib index file for grib file
    +
    1559C> containing global 1-degree sea-surface temp field
    +
    1560C> @param[in] INGBD Unit number of grib file containing global 1-degree
    +
    1561C> sea-surface temp field
    +
    1562C> @param[in] IDAT1 Requested earliest year(yyyy), month, day, hour, min
    +
    1563C> @param[in] IDAT2 Requested latest year(yyyy), month, day, hour, min
    +
    1564C>
    +
    1565C> @remark Called by subroutine w3miscan.
    +
    1566C>
    +
    1567C> @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)
    +
    1587ccccc PRINT *,'SAGT: ',INGBD,FILEB,IRET1
    +
    1588 CALL baopenr(ingbi,filei,iret2)
    +
    1589ccccc 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)
    +
    1605C.......................................................................
    +
    1606C 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
    +
    1615C.......................................................................
    +
    1616C 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)
    +
    1629cppppp
    +
    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)
    +
    1637cppppp
    +
    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
    +
    1643C.......................................................................
    +
    1644C COME HERE IF SST GRIB MSG HAS A DATE THAT IS EITHER: 1) MORE THAN 7-
    +
    1645C DAYS PRIOR TO THE EARLIEST REQ. DATE (INPUT ARG. "IDAT1" TO W3MISCAN)
    +
    1646C OR 2) MORE THAN 7-DAYS AFTER THE LATEST REQ. DATE (INPUT ARG.
    +
    1647C "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
    +
    1652C.......................................................................
    +
    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
    +
    gbyte
    subroutine gbyte(ipackd, iunpkd, noff, nbits)
    This is the fortran version of gbyte.
    Definition gbyte.f:27
    +
    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
    +
    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
    +
    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
    +
    misc06
    subroutine misc06(ingbi, ingbd, idat1, idat2,,,,)
    Reads in nh and sh 1-deg.
    Definition w3miscan.f:1569
    +
    misc05
    subroutine misc05(inlsf, numrgn,)
    Reads 2 records from land/sea tag database.
    Definition w3miscan.f:1518
    +
    misc01
    subroutine misc01(nnalg, gbalg, kdata, swnn, tpwnn, swgb, nrfgb)
    Prepares for in-line caluclation of prods.
    Definition w3miscan.f:1007
    +
    risc02xx
    function risc02xx(x)
    Calc.
    Definition w3miscan.f:1352
    +
    risc02
    function risc02(xt, v, l, sst, jerr)
    Calc.
    Definition w3miscan.f:1139
    +
    risc03
    function risc03(x)
    Calc.
    Definition w3miscan.f:1413
    +
    misc10
    subroutine misc10(x, y)
    Calc.
    Definition w3miscan.f:1238
    +
    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
    +
    misc04
    subroutine misc04(inlsf, blat, blng, lstag)
    Returns land/sea tag for given lat/lon.
    Definition w3miscan.f:1449
    +
    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/w3movdat_8f.html b/w3movdat_8f.html index 3b93dcb6..4e0460dd 100644 --- a/w3movdat_8f.html +++ b/w3movdat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3movdat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3movdat.f File Reference
    +
    w3movdat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    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.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3movdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3movdat()

    + +

    ◆ w3movdat()

    @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -170,7 +176,7 @@

    diff --git a/w3movdat_8f_source.html b/w3movdat_8f_source.html index 6a57b2a2..c8cbb444 100644 --- a/w3movdat_8f_source.html +++ b/w3movdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3movdat.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,46 +81,54 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3movdat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    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
    -
    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
    -
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    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
    +
    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
    +
    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/w3nogds_8f.html b/w3nogds_8f.html index ec58d48f..acd3dae7 100644 --- a/w3nogds_8f.html +++ b/w3nogds_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3nogds.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3nogds.f File Reference
    +
    w3nogds.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Make a complete grib message.

    @@ -107,8 +113,8 @@

    Definition in file w3nogds.f.

    Function/Subroutine Documentation

    - -

    ◆ w3nogds()

    + +

    ◆ w3nogds()

    @@ -117,115 +123,115 @@

    subroutine w3nogds (   - ITYPE, + itype, real, dimension(*)  - FLD, + fld, integer, dimension(*)  - IFLD, + ifld,   - IBITL, + ibitl,   - IPFLAG, + ipflag, integer, dimension(*)  - ID, + id, character * 1, dimension(*)  - PDS, + pds,   - IGFLAG, + igflag,   - IGRID, + igrid, integer, dimension(*)  - IGDS, + igds,   - ICOMP, + icomp,   - IBFLAG, + ibflag, integer, dimension(*)  - IBMAP, + ibmap,   - IBLEN, + iblen, integer, dimension(*)  - IBDSFL, + ibdsfl,   - NPTS, + npts, character * 1, dimension(*)  - KBUF, + kbuf,   - ITOT, + itot,   - JERR  + jerr  @@ -236,14 +242,14 @@

    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.

    -

    +

    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:

    - + @@ -309,7 +315,7 @@

    diff --git a/w3nogds_8f.js b/w3nogds_8f.js index 3f931c62..560d360f 100644 --- a/w3nogds_8f.js +++ b/w3nogds_8f.js @@ -1,4 +1,4 @@ var w3nogds_8f = [ - [ "w3nogds", "w3nogds_8f.html#a9fee3e95f39d96f49f71d4fe1a681e6a", null ] + [ "w3nogds", "w3nogds_8f.html#a5717adc8ddf26fc6a7fdcd02d60a8c5b", null ] ]; \ No newline at end of file diff --git a/w3nogds_8f_source.html b/w3nogds_8f_source.html index 76b42d54..0c493fc8 100644 --- a/w3nogds_8f_source.html +++ b/w3nogds_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3nogds.f Source File @@ -23,10 +23,9 @@

    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).
    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 ).
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,448 +81,456 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3nogds.f
    +
    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
    -
    lengds
    function lengds(KGDS)
    Program history log:
    Definition: lengds.f:15
    -
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    -
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.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
    -
    w3fi73
    subroutine w3fi73(IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
    This subroutine constructs a grib bit map section.
    Definition: w3fi73.f:23
    -
    w3fi74
    subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
    This subroutine constructs a GRIB grid definition section.
    Definition: w3fi74.f:19
    -
    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
    -
    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
    -
    xmovex
    subroutine xmovex(OUT, IN, IBYTES)
    Definition: xmovex.f:21
    -
    xstore
    subroutine xstore(COUT, CON, MWORDS)
    Stores an 8-byte (fullword) value through consecutive storage locations.
    Definition: xstore.f:29
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Make a complete grib message
    +
    3C> @author Farley @date 1997-02-24
    +
    4
    +
    5C> Makes a complete grib message from a user supplied
    +
    6C> array of floating point or integer data. The user has the
    +
    7C> option of supplying the pds or an integer array that will be
    +
    8C> used to create a pds (with w3fi68()). The user must also
    +
    9C> supply other necessary info; see usage section below.
    +
    10C>
    +
    11C> ### Program History Log:
    +
    12C> Date | Programmer | Comment
    +
    13C> -----|------------|--------
    +
    14C> 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).
    +
    15C> 1998-06-24 | Stephen Gilbert | Added number of gridpoint values for grids 61-64, needed when igflag=2 ( no gds ).
    +
    16C> 1998-12-21 | Stephen Gilbert | Replaced function ichar with mova2i.
    +
    17C>
    +
    18C> @param[in] ITYPE 0 = Floating point data supplied in array 'fld'
    +
    19C> 1 = Data supplied in array 'ifld'
    +
    20C> @param[in] FLD Array of data (at proper gridpoints) to be
    +
    21C> converted to grib format if itype=0.
    +
    22C> see remarks #1 & 2.
    +
    23C> @param[in] IFLD Array of data (at proper gridpoints) to be
    +
    24C> converted to grib format if itype=1.
    +
    25C> see remarks #1 & 2.
    +
    26C> @param[in] IBITL 0 = Computer computes length for packing data from
    +
    27C> power of 2 (number of bits) best fit of data
    +
    28C> using 'variable' bit packer w3fi58.
    +
    29C> 8, 12, etc. computer rescales data to fit into that
    +
    30C> 'fixed' number of bits using w3fi59.
    +
    31C> see remarks #3.
    +
    32C> @param[in] IPFLAG 0 = Make pds from user supplied array (id)
    +
    33C> 1 = user supplying pds
    +
    34C> note: if pds is greater than 30, use iplfag=1.
    +
    35C> the user could call w3fi68 before he calls
    +
    36C> w3nogds. this would make the first 30 bytes of
    +
    37C> the pds, user then would make bytes after 30.
    +
    38C> @param[in] ID Array of values that w3fi68 will use
    +
    39C> to make an edition 1 pds if ipflag=0. (see the
    +
    40C> docblock for w3fi68 for layout of array)
    +
    41C> @param[in] PDS Array of values (valid pds supplied
    +
    42C> by user) if ipflag=1. length may exceed 28 bytes
    +
    43C> (contents of bytes beyond 28 are passed
    +
    44C> through unchanged).
    +
    45C> @param[in] IGFLAG 0 = Make gds based on 'igrid' value.
    +
    46C> 1 = make gds from user supplied info in 'igds' and 'igrid' value. see remarks #4.
    +
    47C> 2 = no gds will be included...for international grids
    +
    48C> *** this is an exception to remarks #4!!!!
    +
    49C> @param[in] IGRID # = Grid identification (table b)
    +
    50C> 255 = if user defined grid; igds must be supplied and igflag must =1.
    +
    51C> @param[in] IGDS Array containing user gds info (same
    +
    52C> format as supplied by w3fi71 - see dockblock for
    +
    53C> layout) if igflag=1.
    +
    54C> @param[in] ICOMP Resolution and component flag for bit 5 of gds(17)
    +
    55C> 0 = earth oriented winds
    +
    56C> 1 = grid oriented winds
    +
    57C> @param[in] IBFLAG 0 = Make bit map from user supplied data
    +
    58C> - # = bit map predefined by center see remarks #5.
    +
    59C> @param[in] IBMAP Array containing bit map
    +
    60C> @param[in] IBLEN Length of bit map will be used to verify length
    +
    61C> of field (error if it doesn't match).
    +
    62C> @param[in] IBDSFL Array containing table 11 flag info
    +
    63C> bds octet 4:
    +
    64C> (1) 0 = grid point data
    +
    65C> 1 = spherical harmonic coefficients
    +
    66C> (2) 0 = simple packing
    +
    67C> 1 = second order packing
    +
    68C> (3) ... same value as 'itype'
    +
    69C> 0 = original data were floating point values
    +
    70C> 1 = original data were integer values
    +
    71C> (4) 0 = no additional flags at octet 14
    +
    72C> 1 = octet 14 contains flag bits 5-12
    +
    73C> (5) 0 = reserved - always set to 0
    +
    74C> byte 6 option 1 not available (as of 5-16-93)
    +
    75C> (6) 0 = single datum at each grid point
    +
    76C> 1 = matrix of values at each grid point
    +
    77C> byte 7 option 0 with second order packing n/a (as of 5-16-93)
    +
    78C> (7) 0 = no secondary bit maps
    +
    79C> 1 = secondary bit maps present
    +
    80C> (8) 0 = second order values have constant width
    +
    81C> 1 = second order values have different widths
    +
    82C> @param[out] NPTS Number of gridpoints in array fld or ifld
    +
    83C> @param[out] KBUF Entire grib message ('grib' to '7777')
    +
    84C> equivalence to integer array to make sure it
    +
    85C> is on word bounary.
    +
    86C> @param[out] ITOT Total length of grib message in bytes
    +
    87C> @param[out] JERR =:
    +
    88C> - 0, Completed making grib field without error
    +
    89C> - 1, Ipflag not 0 or 1
    +
    90C> - 2, Igflag not 0 or 1 or 2
    +
    91C> - 3, Error converting ieee f.p. number to ibm370 f.p.
    +
    92C> - 4, W3fi71 error/igrid not defined
    +
    93C> - 5, W3fk74 error/grid representation type not valid
    +
    94C> - 6, Grid too large for packer dimension arrays
    +
    95C> see automation division for revision!
    +
    96C> - 7, Length of bit map not equal to size of fld/ifld
    +
    97C> - 8, W3fi73 error, all values in ibmap are zero
    +
    98C>
    +
    99C> @remark
    +
    100C> - 1 If bit map to be included in message, null data should
    +
    101C> be included in fld or ifld. this routine will take care
    +
    102C> of 'discarding' any null data based on the bit map.
    +
    103C> - 2 Units must be those in grib documentation: nmc o.n. 388
    +
    104C> or wmo publication 306.
    +
    105C> - 3 In either case, input numbers will be multiplied by
    +
    106C> '10 to the nth' power found in id(25) or pds(27-28),
    +
    107C> the d-scaling factor, prior to binary packing.
    +
    108C> - 4 All nmc produced grib fields will have a grid definition
    +
    109C> section included in the grib message. id(6) will be
    +
    110C> set to '1'.
    +
    111C> - gds will be built based on grid number (igrid), unless
    +
    112C> igflag=1 (user supplying igds). user must still supply
    +
    113C> igrid even if igds provided.
    +
    114C> - 5 If bit map used then id(7) or pds(8) must indicate the
    +
    115C> presence of a bit map.
    +
    116C> - 6 Array kbuf should be equivalenced to an integer value or
    +
    117C> array to make sure it is on a word boundary.
    +
    118C> - 7 Subprogram can be called from a multiprocessing environment.
    +
    119C>
    +
    +
    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)
    +
    125C
    +
    126 parameter(mxsize=260000)
    +
    127C ALLOW UP TO 24 BITS PER POINT
    +
    128 parameter(mxsiz3=mxsize*3)
    +
    129 parameter(mxsizb=mxsize/8+6)
    +
    130C FOR 64 BIT CRAY
    +
    131 parameter(mxsizi=mxsiz3/8)
    +
    132C FOR 32 BIT WORKSTATIONS AND HDS
    +
    133C PARAMETER (MXSIZI=MXSIZ3/4)
    +
    134C
    +
    135 REAL FLD(*)
    +
    136C
    +
    137 INTEGER IBDSFL(*)
    +
    138 INTEGER IBMAP(*)
    +
    139 INTEGER ID(*)
    +
    140 INTEGER IFLD(*)
    +
    141 INTEGER IGDS(*)
    +
    142 INTEGER IPFLD(MXSIZI)
    +
    143 INTEGER IB(4)
    +
    144C
    +
    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
    +
    153C
    +
    154 equivalence(ipfld(1),pfld(1))
    +
    155 equivalence(bds11(1),idummy)
    +
    156C
    +
    157C ASCII REP OF /'G', 'R', 'I', 'B'/
    +
    158C
    +
    159 DATA ib / 71, 82, 73, 66/
    +
    160C
    +
    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
    +
    170C
    +
    171C$ 1.0 PRODUCT DEFINITION SECTION(PDS).
    +
    172C
    +
    173C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ...
    +
    174C REGARDLESS OF USER SPECIFICATION...
    +
    175C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS
    +
    176C ***** exception for international GRIB GRIDS 21-26, 61-64
    +
    177C ***** which will NOT contain a GDS until subroutine W3FI71 is fixed!
    +
    178C
    +
    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
    +
    187C BOTH GDS AND BMS
    +
    188 pds(8) = char(192)
    +
    189 ELSE IF (mova2i(pds(8)) .EQ. 0) THEN
    +
    190C GDS ONLY
    +
    191 pds(8) = char(128)
    +
    192 END IF
    +
    193 CONTINUE
    +
    194 ELSE
    +
    195C PRINT *,' W3NOGDS ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG
    +
    196 jerr = 1
    +
    197 GO TO 900
    +
    198 END IF
    +
    199C
    +
    200C GET LENGTH OF PDS
    +
    201C
    +
    202 ipdsl = mova2i(pds(1)) * 65536 + mova2i(pds(2)) * 256 +
    +
    203 & mova2i(pds(3))
    +
    204C
    +
    205C$ 2.0 GRID DEFINITION SECTION (GDS).
    +
    206C
    +
    207C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION
    +
    208C IF IGFLAG=2 THEN USER doesn't want a GDS and this section
    +
    209C will be skipped...LENGDS=0
    +
    210C
    +
    211 IF (igflag .EQ. 0) THEN
    +
    212 CALL w3fi71(igrid,igds,igerr)
    +
    213 IF (igerr .EQ. 1) THEN
    +
    214C 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
    +
    222C 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
    +
    228C PRINT *,' W3NOGDS ERROR, GRID TOO LARGE FOR PACKER ARRAY',
    +
    229C & ' 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
    +
    251C PRINT *,' W3NOGDS ERROR, IGFLAG IS NOT 0-2 IGFLAG = ',IGFLAG
    +
    252 GO TO 900
    +
    253 END IF
    +
    254C
    +
    255C$ 3.0 BIT MAP SECTION (BMS).
    +
    256C
    +
    257C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA
    +
    258C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE
    +
    259C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'.
    +
    260C
    +
    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
    +
    266C 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
    +
    272C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO'
    +
    273 jerr = 8
    +
    274 GO TO 900
    +
    275 END IF
    +
    276 ELSE
    +
    277C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG
    +
    278 END IF
    +
    279 END IF
    +
    280C
    +
    281C$ 4.0 BINARY DATA SECTION (BDS).
    +
    282C
    +
    283C$ 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28)
    +
    284C
    +
    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
    +
    299C
    +
    300C$ 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS.
    +
    301C
    +
    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
    +
    308C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO
    +
    309C ORIGINAL VALUE
    +
    310C
    +
    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
    +
    323C
    +
    324C$ 5.0 OUTPUT SECTION.
    +
    325C
    +
    326C$ 5.1 ZERO OUT THE OUTPUT ARRAY KBUF.
    +
    327C
    +
    328 zero = char(00)
    +
    329 itot = igribl + ipdsl + lengds + lenbms + lenbds + 4
    +
    330C PRINT *,'IGRIBL =',IGRIBL
    +
    331C PRINT *,'IPDSL =',IPDSL
    +
    332C PRINT *,'LENGDS =',LENGDS
    +
    333C PRINT *,'LENBMS =',LENBMS
    +
    334C PRINT *,'LENBDS =',LENBDS
    +
    335C PRINT *,'ITOT =',ITOT
    +
    336C
    +
    337C KBUF MUST BE ON A WORD BOUNDRY, EQUIVALENCE TO AN
    +
    338C INTEGER ARRAY IN THE MAIN PROGRAM TO MAKE SURE IT IS.
    +
    339C THIS IS BOTH COMPUTER AND COMPILER DEPENDENT, W3FI01
    +
    340C IS USED TO FILL OUT IF THE COMPUTER IS A 64 BIT OR
    +
    341C 32 BIT WORD SIZE COMPUTER. LW IS SET TO 4 FOR 32 BIT
    +
    342C COMPUTER, 8 FOR 64 BIT COMPUTER.
    +
    343C
    +
    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
    +
    353C
    +
    354C$ 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES).
    +
    355C
    +
    356 istart = 0
    +
    357 DO 520 i = 1,4
    +
    358 kbuf(i) = char(ib(i))
    +
    359 520 CONTINUE
    +
    360C
    +
    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)
    +
    365C
    +
    366C$ 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES).
    +
    367C
    +
    368 istart = istart + igribl
    +
    369 IF (ipdsl.GT.0) THEN
    +
    370 CALL xmovex(kbuf(istart+1),pds,ipdsl)
    +
    371 ELSE
    +
    372C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL
    +
    373 END IF
    +
    374C
    +
    375C$ 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF.
    +
    376C
    +
    377 istart = istart + ipdsl
    +
    378 IF (lengds .GT. 0) THEN
    +
    379 CALL xmovex(kbuf(istart+1),gds,lengds)
    +
    380 END IF
    +
    381C
    +
    382C$ 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF.
    +
    383C
    +
    384 istart = istart + lengds
    +
    385 IF (lenbms .GT. 0) THEN
    +
    386 CALL xmovex(kbuf(istart+1),bms,lenbms)
    +
    387 END IF
    +
    388C
    +
    389C$ 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF.
    +
    390C
    +
    391C$ MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF.
    +
    392C
    +
    393 istart = istart + lenbms
    +
    394 CALL xmovex(kbuf(istart+1),bds11,11)
    +
    395C
    +
    396C$ MOVE THE PACKED DATA INTO THE KBUF
    +
    397C
    +
    398 istart = istart + 11
    +
    399 IF (len.GT.0) THEN
    +
    400 CALL xmovex(kbuf(istart+1),pfld,len)
    +
    401 END IF
    +
    402C
    +
    403C$ ADD '7777' TO END OFF KBUF
    +
    404C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS.
    +
    405C
    +
    406 seven = char(55)
    +
    407 istart = itot - 4
    +
    408 DO 562 i = 1,4
    +
    409 kbuf(istart+i) = seven
    +
    410 562 CONTINUE
    +
    411C
    +
    412 900 CONTINUE
    +
    413 RETURN
    +
    +
    414 END
    +
    lengds
    function lengds(kgds)
    Program history log:
    Definition lengds.f:15
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition mova2i.f:25
    +
    w3fi01
    subroutine w3fi01(lw)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition w3fi01.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
    +
    w3fi73
    subroutine w3fi73(ibflag, ibmap, iblen, bms, lenbms, ier)
    This subroutine constructs a grib bit map section.
    Definition w3fi73.f:23
    +
    w3fi74
    subroutine w3fi74(igds, icomp, gds, lengds, npts, igerr)
    This subroutine constructs a GRIB grid definition section.
    Definition w3fi74.f:19
    +
    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
    +
    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
    +
    xmovex
    subroutine xmovex(out, in, ibytes)
    Definition xmovex.f:21
    +
    xstore
    subroutine xstore(cout, con, mwords)
    Stores an 8-byte (fullword) value through consecutive storage locations.
    Definition xstore.f:29
    diff --git a/w3pradat_8f.html b/w3pradat_8f.html index 1217e52f..1f1fc753 100644 --- a/w3pradat_8f.html +++ b/w3pradat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3pradat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3pradat.f File Reference
    +
    w3pradat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    subroutine w3pradat (idat, cdat)
     This subprogram forms various character strings useful in describing an NCEP absolute date and time.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3pradat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3pradat()

    + +

    ◆ w3pradat()

    @@ -134,7 +140,7 @@

    This subprogram forms various character strings useful in describing an NCEP absolute date and time.

    -

    +

    Program History Log:

    @@ -172,7 +178,7 @@

    diff --git a/w3pradat_8f_source.html b/w3pradat_8f_source.html index 304c6643..9060f64f 100644 --- a/w3pradat_8f_source.html +++ b/w3pradat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3pradat.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,68 +81,76 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3pradat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    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
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    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
    diff --git a/w3reddat_8f.html b/w3reddat_8f.html index be1b7ab3..e726d08b 100644 --- a/w3reddat_8f.html +++ b/w3reddat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3reddat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3reddat.f File Reference
    +
    w3reddat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    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.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3reddat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3reddat()

    + +

    ◆ w3reddat()

    @@ -147,7 +153,7 @@

    +

    Program History Log:

    @@ -182,7 +188,7 @@

    diff --git a/w3reddat_8f_source.html b/w3reddat_8f_source.html index 8d733128..43ec5287 100644 --- a/w3reddat_8f_source.html +++ b/w3reddat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3reddat.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,75 +81,83 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3reddat.f
    +
    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
    +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/w3tagb_8f.html b/w3tagb_8f.html index 4ea3bacb..bd14830e 100644 --- a/w3tagb_8f.html +++ b/w3tagb_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3tagb.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +

    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3tagb.f File Reference
    +
    w3tagb.f File Reference
    @@ -94,11 +100,11 @@

    Go to the source code of this file.

    - - - - + + +

    +

    Functions/Subroutines

    subroutine w3tagb (PROG, KYR, JD, LF, ORG)
     Prints identifying information for operational codes. More...
     
    subroutine w3tagb (prog, kyr, jd, lf, org)
     Prints identifying information for operational codes.
     

    Detailed Description

    Operational job identifier.

    @@ -107,8 +113,8 @@

    Definition in file w3tagb.f.

    Function/Subroutine Documentation

    - -

    ◆ w3tagb()

    + +

    ◆ w3tagb()

    @@ -117,31 +123,31 @@

    subroutine w3tagb ( character *(*)  - PROG, + prog,   - KYR, + kyr,   - JD, + jd,   - LF, + lf, character *(*)  - ORG  + org  @@ -152,8 +158,8 @@

    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.

    -

    +

    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:

    @@ -202,7 +208,7 @@

    diff --git a/w3tagb_8f.js b/w3tagb_8f.js index 758641db..55bae345 100644 --- a/w3tagb_8f.js +++ b/w3tagb_8f.js @@ -1,4 +1,4 @@ var w3tagb_8f = [ - [ "w3tagb", "w3tagb_8f.html#ac295260f62d3bdcf6c621177ff7d9275", null ] + [ "w3tagb", "w3tagb_8f.html#a7e2cdefc989c6ec94d6366fe46e86b2f", null ] ]; \ No newline at end of file diff --git a/w3tagb_8f_source.html b/w3tagb_8f_source.html index 1bfd6224..f17597df 100644 --- a/w3tagb_8f_source.html +++ b/w3tagb_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3tagb.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,126 +81,134 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3tagb.f
    +
    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
    -
    w3doxdat
    subroutine w3doxdat(idat, jdow, jdoy, jday)
    Program history log:
    Definition: w3doxdat.f:17
    -
    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
    -
    w3tagb
    subroutine w3tagb(PROG, KYR, JD, LF, ORG)
    Prints identifying information for operational codes.
    Definition: w3tagb.f:47
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Operational job identifier
    +
    3C> @author J. Newell @date 1985-10-29
    +
    4
    +
    5C> Prints identifying information for operational
    +
    6C> codes. Called at the beginning of a code, w3tagb() prints
    +
    7C> the program name, the year and julian day of its
    +
    8C> compilation, and the responsible organization. On a 2nd
    +
    9C> line it prints the starting date-time. Called at the
    +
    10C> end of a job, entry routine, w3tage prints a line with the
    +
    11C> ending date-time and a 2nd line stating the program name
    +
    12C> and that it has ended.
    +
    13C>
    +
    14C> ### Program History Log:
    +
    15C> Date | Programmer | Comment
    +
    16C> -----|------------|--------
    +
    17C> 1985-10-29 | J. Newell | Initial.
    +
    18C> 1989-10-20 | Ralph Jones | Convert to cray cft77 fortran
    +
    19C> 1991-03-01 | Ralph Jones | Add machine name to ending line
    +
    20C> 1992-12-02 | Ralph Jones | Add start-ending time-date
    +
    21C> 1993-11-16 | Ralph Jones | Add day of year, day of week, and julian day number.
    +
    22C> 1997-12-24 | M. Farley | Print statements modified for 4-digit yr
    +
    23C> 1998-03-17 | M. Farley | Replaced datimx with calls to w3locdat/w3doxdat
    +
    24C> 1999-01-29 | B. Vuong | Converted to ibm rs/6000 sp
    +
    25C> 1999-06-17 | A. Spruill | Adjusted the size of program name to accommodate
    +
    26C> the 20 character name convention on the ibm sp.
    +
    27C> 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.
    +
    28C> 2012-10-18 | Vuong | Remove print statement 604
    +
    29C> 2013-02-06 | Vuong | Modified print statement 604
    +
    30c>
    +
    31C> @param[in] PROG Program name character*1
    +
    32C> @param[in] KYR Year of compilation integer
    +
    33C> @param[in] JD Julian day of compilation integer
    +
    34C> @param[in] LF Hundreths of julian day of compilation
    +
    35C> integer (range is 0 to 99 inclusive)
    +
    36C> @param[in] ORG Organization code (such as wd42)
    +
    37C> character*1
    +
    38C>
    +
    39C> @remark Full word used in order to have at least
    +
    40C> seven decimal digits accuracy for value of ddate.
    +
    41C> subprogram clock and date may differ for each type
    +
    42C> computer. you may have to change them for another
    +
    43C> type of computer.
    +
    44C>
    +
    45C> @author J. Newell @date 1985-10-29
    +
    +
    46 SUBROUTINE w3tagb(PROG,KYR,JD,LF,ORG)
    +
    47C
    +
    48 CHARACTER *(*) PROG,ORG
    +
    49 CHARACTER * 3 JMON(12)
    +
    50 CHARACTER * 3 DAYW(7)
    +
    51C
    +
    52 INTEGER IDAT(8), JDOW, JDOY, JDAY
    +
    53C
    +
    54 SAVE
    +
    55C
    +
    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'/
    +
    59C
    +
    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)
    +
    73C
    +
    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
    +
    81C
    +
    82 entry w3tage(prog)
    +
    83C
    +
    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.')
    +
    92C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY J916/2048')
    +
    93C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY Y-MP EL2/256')
    +
    94 print 605
    +
    95 605 FORMAT(10('* . * . '))
    +
    96
    +
    97 CALL summary()
    +
    98C
    +
    99 RETURN
    +
    +
    100 END
    +
    w3doxdat
    subroutine w3doxdat(idat, jdow, jdoy, jday)
    Program history log:
    Definition w3doxdat.f:17
    +
    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
    +
    w3tagb
    subroutine w3tagb(prog, kyr, jd, lf, org)
    Prints identifying information for operational codes.
    Definition w3tagb.f:47
    diff --git a/w3trnarg_8f.html b/w3trnarg_8f.html index 94b9be43..9860e35a 100644 --- a/w3trnarg_8f.html +++ b/w3trnarg_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3trnarg.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3trnarg.f File Reference
    +
    w3trnarg.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    Translates arg line from standard input.

    @@ -107,8 +113,8 @@

    Definition in file w3trnarg.f.

    Function/Subroutine Documentation

    - -

    ◆ w3trnarg()

    + +

    ◆ w3trnarg()

    @@ -117,61 +123,61 @@

    subroutine w3trnarg ( character*(*)  - SUBDIR, + subdir,   - LSUBDR, + lsubdr, character*(*)  - TANKID, + tankid,   - LTNKID, + ltnkid, character*(*)  - APPCHR, + appchr,   - LAPCHR, + lapchr, character*(*)  - TLFLAG, + tlflag,   - IYMDHB, + iymdhb,   - IYMDHE, + iymdhe,   - IERR  + ierr  @@ -182,7 +188,7 @@

    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:

    @@ -206,10 +212,11 @@

    - +
    [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.
    IERR
    +

    Input 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
    @@ -223,7 +230,7 @@

    diff --git a/w3trnarg_8f.js b/w3trnarg_8f.js index a5b20e42..87f16dba 100644 --- a/w3trnarg_8f.js +++ b/w3trnarg_8f.js @@ -1,4 +1,4 @@ var w3trnarg_8f = [ - [ "w3trnarg", "w3trnarg_8f.html#a469f580bad86541dc4ffe778b0eaf9bf", null ] + [ "w3trnarg", "w3trnarg_8f.html#aa93f106864755e8a7347b10d425e1764", null ] ]; \ No newline at end of file diff --git a/w3trnarg_8f_source.html b/w3trnarg_8f_source.html index 1a79f9b3..13a60459 100644 --- a/w3trnarg_8f_source.html +++ b/w3trnarg_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3trnarg.f Source File @@ -23,10 +23,9 @@
    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ + +

    @@ -76,186 +81,194 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3trnarg.f
    +
    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
    -
    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
    -
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Translates arg line from standard input
    +
    3C> @author Dennis Keyser @date 2002-02-11
    +
    4
    +
    5C> Reads argument lines from standard input and obtains subdirectory, bufr
    +
    6C> tankname, characters to append for adding an orbit, and options for limiting
    +
    7C> the time window.
    +
    8C>
    +
    9C> ### Program History Log:
    +
    10C> Date | Programmer | Comment
    +
    11C> -----|------------|--------
    +
    12C> 1996-09-03 | B. KATZ | Original author
    +
    13C> 1998-11-27 | B. KATZ | Changes for y2k and fortran 90 compliance
    +
    14C> 2002-02-11 | D. KEYSER | If "tlflag" is not specified, it defaults to
    +
    15C> "notimlim" rather than "timlim" and gross time limits will not be
    +
    16C> calculated and returned in "iymdhb" and "iymdhe"
    +
    17C>
    +
    18C> @param[in] SUBDIR Name of sub-directory including bufr data type where
    +
    19C> bufr data tank is located.
    +
    20C> @param[in] LSUBDR Number of characters in 'subdir'.
    +
    21C> @param[in] TANKID Name of file including bufr data sub-type containing
    +
    22C> bufr data tank.
    +
    23C> @param[in] LTNKID Number of characters in 'tankid'.
    +
    24C> @param[in] APPCHR Characters to be appended to 'tankid' giving a
    +
    25C> uniquely named file to contain the original tank
    +
    26C> with one orbit appended to it.
    +
    27C> @param[in] LAPCHR Number of characters in 'appchr'.
    +
    28C> @param[in] TLFLAG 8 character flag indicating whether time acceptance
    +
    29C> checks atre to be performed.
    +
    30C> = 'timlim ' : perform time acceptance checks.
    +
    31C> = 'notimlim' : do not perform time acceptance checks.
    +
    32C> jdate and kdate are disregarded.
    +
    33C> @param[in] IYMDHB Start of time acceptance window, in form yyyymmddhh.
    +
    34C> @param[in] IYMDHE End of time acceptance window, in form yyyymmddhh.
    +
    35C> @param IERR
    +
    36C>
    +
    37C> Input files :
    +
    38C> unit 05 - standard input for passing in arguments. arguments
    +
    39C> (for list-directed i/o) are as follows :
    +
    40C> record 1 - (1) subdirectory. contains bufr data type
    +
    41C> (2) tankfile. contains bufr data sub-type
    +
    42C> (3) append characters. appended to tankfile
    +
    43C> to give unique output file name.
    +
    44C> (4) date in yyyymmddhh format.
    +
    45C> next three records are optional :
    +
    46C> record 2 - (1) time limit flag. may be either
    +
    47C> 'timlim ' or 'notimlim'. see
    +
    48C> description of 'tlflag' above.
    +
    49C> (default is 'notimlim')
    +
    50C> record 3 - (1) hours before current time.
    +
    51C> record 4 - (1) hours after current time.
    +
    52C> if 'timlim ' is specified in record 2, the
    +
    53C> quantities in records 3 and 4 are used to
    +
    54C> compute the limits of the time acceptance window.
    +
    55C> if records 3 and 4 are omitted, the values
    +
    56C> default to -48 (48 hours before current time)
    +
    57C> and +12 (12 hours after current time).
    +
    58C> if 'notimlim ' is specified in record 2, then
    +
    59C> these quantities are not used regardless of whether
    +
    60C> or not they were specified.
    +
    61C>
    +
    62C> @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
    +
    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
    +
    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
    diff --git a/w3unpk77_8f.html b/w3unpk77_8f.html index a076eddd..70d62d81 100644 --- a/w3unpk77_8f.html +++ b/w3unpk77_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3unpk77.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3unpk77.f File Reference
    +
    w3unpk77.f File Reference
    @@ -94,38 +100,38 @@

    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...
     
    subroutine unpk7701 (lunit, itp, iret)
     Reads a single report out of bufr dataset.
     
    subroutine unpk7702 (rdata, itp)
     Initializes the output array for a report.
     
    subroutine unpk7703 (lunit, rdata, iret)
     Fills in header in o-put array - pflr rpt.
     
    subroutine unpk7704 (lunit, rdata)
     Fills cat.10 into o-put array - pflr rpt.
     
    subroutine unpk7705 (lunit, rdata)
     Fills cat.11 into o-put array - pflr rpt.
     
    subroutine unpk7706 (lunit, rdata, iret)
     Fills in header in o-put array - vadw rpt.
     
    subroutine unpk7707 (lunit, rdata, iret)
     Fills cat.
     
    subroutine unpk7708 (lunit, rdata, kount, iret)
     Fills in header in o-put array - goes snd.
     
    subroutine unpk7709 (lunit, rdata, iret)
     Fills cat.
     
    subroutine w3unpk77 (idate, ihe, ihl, lunit, rdata, iret)
     This subroutine decodes a single report from bufr messages in a jbufr-type data file.
     

    Detailed Description

    Decodes single report from bufr messages.

    @@ -134,8 +140,8 @@

    Definition in file w3unpk77.f.

    Function/Subroutine Documentation

    - -

    ◆ unpk7701()

    + +

    ◆ unpk7701()

    @@ -144,19 +150,19 @@

    subroutine unpk7701 (   - LUNIT, + lunit,   - ITP, + itp,   - IRET  + iret  @@ -169,7 +175,7 @@

    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:

    @@ -192,8 +198,8 @@

    - -

    ◆ unpk7702()

    + +

    ◆ unpk7702()

    @@ -202,13 +208,13 @@

    subroutine unpk7702

    - + - + @@ -221,7 +227,7 @@

    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:

    ( real, dimension(*) RDATA, rdata,
     ITP itp 
    @@ -243,8 +249,8 @@

    - -

    ◆ unpk7703()

    + +

    ◆ unpk7703()

    @@ -253,19 +259,19 @@

    subroutine unpk7703

    - + - + - + @@ -278,7 +284,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA, rdata,
     IRET iret 
    @@ -303,8 +309,8 @@

    - -

    ◆ unpk7704()

    + +

    ◆ unpk7704()

    @@ -313,13 +319,13 @@

    subroutine unpk7704

    - + - + @@ -332,7 +338,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA rdata 
    @@ -355,8 +361,8 @@

    - -

    ◆ unpk7705()

    + +

    ◆ unpk7705()

    @@ -365,13 +371,13 @@

    subroutine unpk7705

    - + - + @@ -384,7 +390,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA rdata 
    @@ -408,8 +414,8 @@

    - -

    ◆ unpk7706()

    + +

    ◆ unpk7706()

    @@ -418,19 +424,19 @@

    subroutine unpk7706

    - + - + - + @@ -443,7 +449,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA, rdata,
     IRET iret 
    @@ -466,8 +472,8 @@

    - -

    ◆ unpk7707()

    + +

    ◆ unpk7707()

    @@ -476,19 +482,19 @@

    subroutine unpk7707

    - + - + - + @@ -501,7 +507,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA, rdata,
     IRET iret 
    @@ -524,8 +530,8 @@

    - -

    ◆ unpk7708()

    + +

    ◆ unpk7708()

    @@ -534,25 +540,25 @@

    subroutine unpk7708

    - + - + - + - + @@ -565,7 +571,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA, rdata,
     KOUNT, kount,
     IRET iret 
    @@ -591,8 +597,8 @@

    - -

    ◆ unpk7709()

    + +

    ◆ unpk7709()

    @@ -601,19 +607,19 @@

    subroutine unpk7709

    - + - + - + @@ -626,7 +632,7 @@

    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:

    (  LUNIT, lunit,
    real, dimension(*) RDATA, rdata,
     IRET iret 
    @@ -649,8 +655,8 @@

    - -

    ◆ w3unpk77()

    + +

    ◆ w3unpk77()

    @@ -659,37 +665,37 @@

    subroutine w3unpk77

    - + - + - + - + - + - + @@ -701,7 +707,7 @@

    +

    Program History Log:

    ( integer, dimension(4) IDATE, idate,
     IHE, ihe,
     IHL, ihl,
     LUNIT, lunit,
    real, dimension(*) RDATA, rdata,
     IRET iret 
    @@ -748,7 +754,7 @@

    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

    @@ -792,7 +798,7 @@

    43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
    -

    +

    CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)

    @@ -812,7 +818,7 @@

    (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)

    @@ -837,7 +843,7 @@

    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:
    +

    SEE:
    • *- ALWAYS MISSING
    • &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
      • @@ -888,7 +894,7 @@

      diff --git a/w3unpk77_8f.js b/w3unpk77_8f.js index a32ee629..859369de 100644 --- a/w3unpk77_8f.js +++ b/w3unpk77_8f.js @@ -1,13 +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 ] + [ "unpk7701", "w3unpk77_8f.html#a6e6b3e1b8bac81ed3db73ab1fca6c40f", null ], + [ "unpk7702", "w3unpk77_8f.html#a35877dbb88d9e6fb89b1807238f95018", null ], + [ "unpk7703", "w3unpk77_8f.html#ac39a6820df8dfea69d930ab738b8b07e", null ], + [ "unpk7704", "w3unpk77_8f.html#a9dfb4c67d159cc49f2a43151ec25e915", null ], + [ "unpk7705", "w3unpk77_8f.html#a3b7ce3ad5342da6e89fbbeb173ae47d5", null ], + [ "unpk7706", "w3unpk77_8f.html#a781d7a1d34ea17a555131bdde0ce1579", null ], + [ "unpk7707", "w3unpk77_8f.html#a73cd8561593c0b5c72075104f7200594", null ], + [ "unpk7708", "w3unpk77_8f.html#a03a9e7379784e4998d610e00673b05ea", null ], + [ "unpk7709", "w3unpk77_8f.html#a515f864a3a6adab3695cef735f610479", null ], + [ "w3unpk77", "w3unpk77_8f.html#a5f0f3e0fe1648c04ba5a47a13f405c4f", null ] ]; \ No newline at end of file diff --git a/w3unpk77_8f_source.html b/w3unpk77_8f_source.html index e75839d6..7051921e 100644 --- a/w3unpk77_8f_source.html +++ b/w3unpk77_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3unpk77.f Source File @@ -23,10 +23,9 @@
      - - + @@ -34,22 +33,28 @@
      -
      NCEPLIBS-w3emc -  2.11.0 +
      +
      NCEPLIBS-w3emc 2.11.0
      - + +/* @license-end */ + +

    @@ -76,2404 +81,2430 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3unpk77.f
    +
    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
    -
    errexit
    subroutine errexit(IRET)
    Exit with a return code.
    Definition: errexit.f:20
    -
    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
    -
    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
    -
    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
    -
    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
    -
    unpk7709
    subroutine unpk7709(LUNIT, RDATA, IRET)
    Fills cat.
    Definition: w3unpk77.f:2021
    -
    unpk7706
    subroutine unpk7706(LUNIT, RDATA, IRET)
    Fills in header in o-put array - vadw rpt.
    Definition: w3unpk77.f:1451
    -
    unpk7705
    subroutine unpk7705(LUNIT, RDATA)
    Fills cat.11 into o-put array - pflr rpt.
    Definition: w3unpk77.f:1222
    -
    unpk7707
    subroutine unpk7707(LUNIT, RDATA, IRET)
    Fills cat.
    Definition: w3unpk77.f:1615
    -
    unpk7704
    subroutine unpk7704(LUNIT, RDATA)
    Fills cat.10 into o-put array - pflr rpt.
    Definition: w3unpk77.f:1116
    -
    unpk7708
    subroutine unpk7708(LUNIT, RDATA, KOUNT, IRET)
    Fills in header in o-put array - goes snd.
    Definition: w3unpk77.f:1794
    -
    unpk7701
    subroutine unpk7701(LUNIT, ITP, IRET)
    Reads a single report out of bufr dataset.
    Definition: w3unpk77.f:649
    -
    unpk7703
    subroutine unpk7703(LUNIT, RDATA, IRET)
    Fills in header in o-put array - pflr rpt.
    Definition: w3unpk77.f:896
    -
    unpk7702
    subroutine unpk7702(RDATA, ITP)
    Initializes the output array for a report.
    Definition: w3unpk77.f:800
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Decodes single report from bufr messages
    +
    3C> @author Dennis Keyser @date 2002-03-05
    +
    4
    +
    5C> This subroutine decodes a single report from bufr messages
    +
    6C> in a jbufr-type data file. Currently wind profiler, nexrad (vad)
    +
    7C> wind and goes sounding/radiance data types are valid. Report is
    +
    8C> returned in quasi-office note 29 unpacked format (see remarks 4.).
    +
    9C>
    +
    10C> ### Program History Log:
    +
    11C> Date | Programmer | Comment
    +
    12C> -----|------------|--------
    +
    13C> 1996-12-16 | Dennis Keyser | Original author (based on w3lib routine w3fi77)
    +
    14C> 1997-06-02 | Dennis Keyser | Added nexrad (vad) wind data type
    +
    15C> 1997-06-16 | Dennis Keyser | Added goes sounding/radiance data type
    +
    16C> 1997-09-18 | Dennis Keyser | Added instrument data used in processing,
    +
    17C> solar zenith angle, and satellite zenith angle
    +
    18C> to list of parameters returned from goes
    +
    19C> sounding/radiance data type
    +
    20C> 1998-07-09 | Dennis Keyser | Modified wind profiler cat. 11 (height, horiz.
    +
    21C> significance, vert. significance) to account
    +
    22C> for updates to bufrtable mnemonics in /dcom;
    +
    23C> changed char. 6 of goes stnid to be unique for
    +
    24C> two different even or odd satellite id's
    +
    25C> (every other even or odd sat. id now gets same
    +
    26C> char. 6 tag)
    +
    27C> 1998-08-19 | Dennis Keyser | Subroutine now y2k and fortran 90 compliant
    +
    28C> 1999-03-16 | Dennis Keyser | Incorporated bob kistler's changes needed
    +
    29C> to port the code to the ibm sp
    +
    30C> 1999-05-17 | Dennis Keyser | Made changes necessary to port this routine to
    +
    31C> the ibm sp
    +
    32C> 1999-09-26 | Dennis Keyser | Changes to make code more portable
    +
    33C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind
    +
    34C> profiler) bufr dump file after 3/2002: cat. 10
    +
    35C> surface data now all missing (mnemonics "pmsl",
    +
    36C> "wdir1","wspd1", "tmdb", "rehu", "reqv" no
    +
    37C> longer available); cat. 11 mnemonics "acavh",
    +
    38C> "acavv", "spp0", and "nphl" no longer
    +
    39C> available; header mnemonic "npsm" is no longer
    +
    40C> available, header mnemonic "tpse" replaces
    +
    41C> "tpmi" (avg. time in minutes still output);
    +
    42C> number of upper-air levels incr. from 43 to up
    +
    43C> to 64 (size of output "rdata" array incr. from
    +
    44C> 600 to 1200 to account for this) (will still
    +
    45C> work properly for input proflr dump files prior
    +
    46C> to 3/2002)
    +
    47C>
    +
    48C> @param[in] IDATE 4-word array holding "central" date to process (yyyy, mm, dd, hh)
    +
    49C> @param[in] IHE Number of whole hours relative to "idate" for date of
    +
    50C> earliest bufr message that is to be decoded; earliest date is "idate" +
    +
    51C> "ihe" hours (if "ihe" is positive, latest message date is after "idate";
    +
    52C> if "ihe" is negative latest message date is prior to "idate") example:
    +
    53C> if ihe=1, then earliest date is 1-hr after idate; if ihe=-3, then earliest
    +
    54C> date is 3-hr prior to idate
    +
    55C> @param[in] IHL Number of whole hours relative to "idate" for date of
    +
    56C> latest bufr message that is to be decoded; latest date is "idate" + ("ihl"
    +
    57C> hours plus 59 min) if "ihl" is positive (latest message date is after
    +
    58C> "idate"), and "idate" + ("ihl"+1 hours minus 1 min) if "ihl" is negative
    +
    59C> (latest message date is prior to "idate") example: if ihl=3, then latest
    +
    60C> date is 3-hr 59-min after idate; if ihl=-2, then latest date is 1-hr 1-min
    +
    61C> prior to idate
    +
    62C> @param[in] LUNIT Fortran unit number for input data file
    +
    63C> @param[out] RDATA Single report returned an a quasi-office note 29 unpacked
    +
    64C> format (see remarks 4.) (minimum size is 1200 words)
    +
    65C> @param[inout] IRET [in] Controls degree of unit 6 printout (.ge. 0 -limited
    +
    66C> printout; = -1 some additional diagnostic printout; = .lt. -1 -extensive
    +
    67C> printout) (see remarks 3.)
    +
    68C> [out] Return code as follows:
    +
    69C> - IRET = 0 ---> Report successfully returned
    +
    70C> - IRET > 0 ---> No report returned due to:
    +
    71C> - = 1 ---> All reports read in, end
    +
    72C> - = 2 ---> Lat and/or lon data missing
    +
    73C> - = 3 ---> Reserved
    +
    74C> - = 4 ---> Some/all date information missing
    +
    75C> - = 5 ---> No data levels processed (all levels are missing)
    +
    76C> - = 6 ---> Number of levels in report header is not 1
    +
    77C> - = 7 ---> Number of levels in another single level sequence is not 1
    +
    78C>
    +
    79C> @remark
    +
    80C> - 1 A condition code (stop) of 15 will occur if the input
    +
    81C> dates for start and/or stop time are specified incorrectly.
    +
    82C> - 2 A condition code (stop) of 22 will occur if the
    +
    83C> characters on this machine are neither ascii nor ebcdic.
    +
    84C> - 3 The input argument "iret" should be set prior to each
    +
    85C> call to this subroutine.
    +
    86C>
    +
    87C> ***************************************************************
    +
    88C> 4)
    +
    89C> BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA
    +
    90C> (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE)
    +
    91C> N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77
    +
    92C> EXCEPT WHERE NOTED
    +
    93C> ***************************************************************
    +
    94C>
    +
    95C> #### FORMAT FOR WIND PROFILER REPORTS
    +
    96C> WORD | CONTENT | UNIT | FORMAT
    +
    97C> ---- | --------------------- | ------------------- | ---------
    +
    98C> 1 | LATITUDE | 0.01 DEGREES | REAL
    +
    99C> 2 | LONGITUDE | 0.01 DEGREES WEST | REAL
    +
    100C> 3 | TIME SIGNIFICANCE | (BUFR CODE TABLE "0 08 021") | INTEGER
    +
    101C> 4 | OBSERVATION TIME | 0.01 HOURS (UTC) | REAL
    +
    102C> 5 | YEAR/MONTH | 4-CHAR. 'YYMM' LEFT-JUSTIFIED | CHARACTER
    +
    103C> 6 | DAY/HOUR | 4-CHARACTERS 'DDHH' | CHARACTER
    +
    104C> 7 | STATION ELEVATION | METERS | REAL
    +
    105C> 8 | SUBMODE/EDITION NO. | (SM X 10) + ED. NO. (ED. NO.=2, CONSTANT; SEE &,~) | INTEGER
    +
    106C> 9 | REPORT TYPE | 71 (CONSTANT) | INTEGER
    +
    107C> 10 | AVERAGING TIME | MINUTES (NEGATIVE MEANS PRIOR TO OBS. TIME) | INTEGER
    +
    108C> 11 | STN. ID. (FIRST 4 CHAR.) | 4-CHARACTERS LEFT-JUSTIFIED| CHARACTER
    +
    109C> 12 | STN. ID. (LAST 2 CHAR.) | 2-CHARACTERS LEFT-JUSTIFIED| CHARACTER
    +
    110C> 13-34 | ZEROED OUT - NOT USED | | INTEGER
    +
    111C> 35 | CATEGORY 10, NO. LEVELS | COUNT | INTEGER
    +
    112C> 36 | CATEGORY 10, DATA INDEX | COUNT | INTEGER
    +
    113C> 37 | CATEGORY 11, NO. LEVELS | COUNT | INTEGER
    +
    114C> 38 | CATEGORY 11, DATA INDEX | COUNT | INTEGER
    +
    115C> 39-42 | ZEROED OUT - NOT USED | | INTEGER
    +
    116C> 43-END | UNPACKED DATA GROUPS | (FOLLOWS) | REAL
    +
    117C>
    +
    118C> #### CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)
    +
    119C> WORD | PARAMETER | UNITS | FORMAT
    +
    120C> ---- | --------- | ----------------- | -------------
    +
    121C>(SEE @)1 | SEA-LEVEL PRESSURE | 0.1 MILLIBARS | REAL
    +
    122C>(SEE *)2 | STATION PRESSURE | 0.1 MILLIBARS | REAL
    +
    123C>(SEE @)3 | HORIZ. WIND DIR. | DEGREES | REAL
    +
    124C>(SEE @)4 | HORIZ. WIND SPEED | 0.1 M/S | REAL
    +
    125C>(SEE @)5 | AIR TEMPERATURE | 0.1 DEGREES K | REAL
    +
    126C>(SEE @)6 | RELATIVE HUMIDITY | PERCENT | REAL
    +
    127C>(SEE @)7 | RAINFALL RATE | 0.0000001 M/S | REAL
    +
    128C>
    +
    129C> #### CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)
    +
    130C> WORD | PARAMETER | UNITS | FORMAT
    +
    131C> ---- | --------- | ----------------- | -------------
    +
    132C> 1 | HEIGHT ABOVE SEA-LVL | METERS | REAL
    +
    133C> 2 | HORIZ. WIND DIR. | DEGREES | REAL
    +
    134C> 3 | HORIZ. WIND SPEED | 0.1 M/S | REAL
    +
    135C> 4 | QUALITY CODE | (SEE %) | INTEGER
    +
    136C> 5 | VERT. WIND COMP. (W) | 0.01 M/S | REAL
    +
    137C>(SEE @)6 | HORIZ. CONSENSUS NO. | (SEE $) | INTEGER
    +
    138C>(SEE @)7 | VERT. CONSENSUS NO. | (SEE $) | INTEGER
    +
    139C>(SEE @)8 | SPECTRAL PEAK POWER | DB | REAL
    +
    140C> 9 | HORIZ. WIND SPEED | 0.1 M/S | REAL
    +
    141C> | STANDARD DEVIATION | 0.1 M/S | REAL
    +
    142C> 10 | VERT. WIND COMPONENT | 0.1 M/S | REAL
    +
    143C> | STANDARD DEVIATION | 0.1 M/S | REAL
    +
    144C>(SEE @)11 | MODE | (SEE #) | INTEGER
    +
    145C>
    +
    146C> ##### SEE:
    +
    147C> - *- ALWAYS MISSING
    +
    148C> - &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
    +
    149C> - %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED
    +
    150C> - 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE
    +
    151C> - 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED
    +
    152C> - 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED
    +
    153C> - 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED
    +
    154C> - $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE
    +
    155C> INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10)
    +
    156C> (BASED ON A ONE-HOUR AVERAGE)
    +
    157C> - #- 1 - DATA FROM LOW MODE
    +
    158C> 2 - DATA FROM HIGH MODE
    +
    159C> 3 - MISSING
    +
    160C> - @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET
    +
    161C> TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL)
    +
    162C> - ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3
    +
    163C> (ITS MISSING VALUE)
    +
    164C>
    +
    165C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    166C> FORMAT FOR GOES SOUNDING/RADIANCE REPORTS
    +
    167C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    168C> HEADER
    +
    169C> WORD CONTENT UNIT FORMAT
    +
    170C> ---- ---------------------- ------------------- ---------
    +
    171C> 1 LATITUDE 0.01 DEGREES REAL
    +
    172C> 2 LONGITUDE 0.01 DEGREES WEST REAL
    +
    173C> 3 FIELD OF VIEW NUMBER NUMERIC INTEGER
    +
    174C> 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
    +
    175c>vvvvvdak port
    +
    176C> 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
    +
    177c>aaaaadak port
    +
    178C> LEFT-JUSTIFIED
    +
    179C> 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
    +
    180C> 7 STATION ELEVATION METERS REAL
    +
    181C> 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER
    +
    182C> 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED)
    +
    183C> 9 REPORT TYPE 61 (CONSTANT) INTEGER
    +
    184C> 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER
    +
    185C> 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
    +
    186C> LEFT-JUSTIFIED
    +
    187C> 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
    +
    188C> LEFT-JUSTIFIED (SEE %)
    +
    189C>
    +
    190C> 13-26 ZEROED OUT - NOT USED
    +
    191C> 27 CATEGORY 08, NO. LEVELS COUNT INTEGER
    +
    192C> 28 CATEGORY 08, DATA INDEX COUNT INTEGER
    +
    193C> 29-38 ZEROED OUT - NOT USED
    +
    194C> 39 CATEGORY 12, NO. LEVELS COUNT INTEGER
    +
    195C> 40 CATEGORY 12, DATA INDEX COUNT INTEGER
    +
    196C> 41 CATEGORY 13, NO. LEVELS COUNT INTEGER
    +
    197C> 42 CATEGORY 13, DATA INDEX COUNT INTEGER
    +
    198C>
    +
    199C> 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
    +
    200C>
    +
    201C> CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE;
    +
    202C> EACH LEVEL, SEE 39 ABOVE)
    +
    203C> WORD PARAMETER UNITS FORMAT
    +
    204C> ---- --------- ----------------- -------------
    +
    205C> 1 PRESSURE 0.1 MILLIBARS REAL
    +
    206C> 2 GEOPOTENTIAL METERS REAL
    +
    207C> 3 TEMPERATURE 0.1 DEGREES C REAL
    +
    208C> 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL
    +
    209C> 5 NOT USED SET TO MISSING REAL
    +
    210C> 6 NOT USED SET TO MISSING REAL
    +
    211C> 7 QUALITY MARKERS 4-CHARACTERS CHARACTER
    +
    212C> LEFT-JUSTIFIED (SEE &)
    +
    213C>
    +
    214C> CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE
    +
    215C> 41 ABOVE)
    +
    216C> WORD PARAMETER UNITS FORMAT
    +
    217C> ---- --------- ----------------- -------------
    +
    218C> 1 CHANNEL NUMBER NUMERIC INTEGER
    +
    219C> 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL
    +
    220C> 3 QUALITY MARKERS 4-CHARACTERS CHARACTER
    +
    221C> LEFT-JUSTIFIED (SEE &&)
    +
    222C>
    +
    223C> CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @
    +
    224C> BELOW)
    +
    225C> WORD PARAMETER UNITS FORMAT
    +
    226C> ---- --------- ----------------- -------------
    +
    227C> 1 VARIABLE SEE @ BELOW REAL
    +
    228C> 2 CODE FIGURE SEE @ BELOW REAL
    +
    229C> 3 MARKERS 2-CHARACTERS CHARACTER
    +
    230C> LEFT-JUSTIFIED (SEE #)
    +
    231C>
    +
    232C> %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS:
    +
    233C> "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR.
    +
    234C> "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR.
    +
    235
    +
    236C> "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR.
    +
    237C> "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR.
    +
    238
    +
    239C> "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR.
    +
    240C> "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR.
    +
    241
    +
    242C> "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR.
    +
    243C> "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR.
    +
    244
    +
    245C> "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN
    +
    246
    +
    247C> &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL
    +
    248C> SECOND CHARACTER IS Q.M. FOR TEMPERATURE
    +
    249C> THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE
    +
    250C> FOURTH CHARACTER IS NOT USED
    +
    251C> " " - INDICATES DATA NOT SUSPECT
    +
    252C> "Q" - INDICATES DATA ARE SUSPECT
    +
    253C> "F" - INDICATES DATA ARE BAD
    +
    254C> &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE
    +
    255C> SECOND-FOURTH CHARACTERS ARE NOT USED
    +
    256C> " " - INDICATES DATA NOT SUSPECT
    +
    257C> "Q" - INDICATES DATA ARE SUSPECT
    +
    258C> "F" - INDICATES DATA ARE BAD
    +
    259C> @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED
    +
    260C> AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED)
    +
    261C> 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250.
    +
    262C> 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251.
    +
    263C> 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252.
    +
    264C> 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253.
    +
    265C> 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254.
    +
    266C> 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255.
    +
    267C> 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256.
    +
    268C> 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257.
    +
    269C> 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258.
    +
    270C> 10 - INSTR. DATA USED IN PROC.
    +
    271C> (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259.
    +
    272C> 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260.
    +
    273C> 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261.
    +
    274C> #- FIRST CHARACTER IS Q.M. FOR THE DATUM
    +
    275C> " " - INDICATES DATA NOT SUSPECT
    +
    276C> "Q" - INDICATES DATA ARE SUSPECT
    +
    277C> "F" - INDICATES DATA ARE BAD
    +
    278C> SECOND CHARACTER IS NOT USED
    +
    279C>
    +
    280C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    281C> FORMAT FOR NEXRAD (VAD) WIND REPORTS
    +
    282C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    283C> HEADER
    +
    284C> WORD CONTENT UNIT FORMAT
    +
    285C> ---- ---------------------- ------------------- ---------
    +
    286C> 1 LATITUDE 0.01 DEGREES REAL
    +
    287C> 2 LONGITUDE 0.01 DEGREES WEST REAL
    +
    288C> 3 ** RESERVED ** SET TO 99999 INTEGER
    +
    289C> 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
    +
    290c>vvvvvdak port
    +
    291C> 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
    +
    292c>aaaaadak port
    +
    293C> LEFT-JUSTIFIED
    +
    294C> 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
    +
    295C> 7 STATION ELEVATION METERS REAL
    +
    296C> 8 ** RESERVED ** SET TO 99999 INTEGER
    +
    297C>
    +
    298C> 9 REPORT TYPE 72 (CONSTANT) INTEGER
    +
    299C> 10 ** RESERVED ** SET TO 99999 INTEGER
    +
    300C> 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
    +
    301C> LEFT-JUSTIFIED
    +
    302C> 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
    +
    303C> LEFT-JUSTIFIED
    +
    304C>
    +
    305C> 13-18 ZEROED OUT - NOT USED INTEGER
    +
    306C> 19 CATEGORY 04, NO. LEVELS COUNT INTEGER
    +
    307C> 20 CATEGORY 04, DATA INDEX COUNT INTEGER
    +
    308C> 21-42 ZEROED OUT - NOT USED INTEGER
    +
    309C>
    +
    310C> 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
    +
    311C>
    +
    312C> CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE)
    +
    313C> (EACH LEVEL, SEE WORD 19 ABOVE)
    +
    314C> WORD PARAMETER UNITS FORMAT
    +
    315C> ---- --------- ----------------- -------------
    +
    316C> 1 HEIGHT ABOVE SEA-LVL METERS REAL
    +
    317C> 2 HORIZ. WIND DIR. DEGREES REAL
    +
    318C> 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL
    +
    319C> 4 QUALITY MARKERS 4-CHARACTERS CHARACTER
    +
    320C> LEFT-JUSTIFIED (SEE %)
    +
    321C>
    +
    322C> *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29
    +
    323C> (WHERE UNITS ARE KNOTS)
    +
    324C> %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH
    +
    325C> CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT-
    +
    326C> MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS
    +
    327C> DEFINED AS FOLLOWS:
    +
    328C> 'A' = RMS OF 1.9 KNOTS
    +
    329C> 'B' = RMS OF 3.9 KNOTS
    +
    330C> 'C' = RMS OF 5.8 KNOTS
    +
    331C> 'D' = RMS OF 7.8 KNOTS
    +
    332C> 'E' = RMS OF 9.7 KNOTS
    +
    333C> 'F' = RMS OF 11.7 KNOTS
    +
    334C> 'G' = RMS > 13.6 KNOTS
    +
    335C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    336C>
    +
    337C> FOR ALL REPORT TYPES, MISSING VALUES ARE:
    +
    338C> 99999. FOR REAL
    +
    339C> 99999 FOR INTEGER
    +
    340C> 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER
    +
    341C> BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER
    +
    342C> AND FOR CHARACTERS IN ANY CATEGORY LEVEL
    +
    343C>
    +
    344C> @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
    +
    363C-----------------------------------------------------------------------
    +
    364
    +
    365C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS....
    +
    366
    +
    367 itm = 1
    +
    368 ifov = 0
    +
    369 kntsat = 0
    +
    370C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF
    +
    371C 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
    +
    377C 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
    +
    383C-----------------------------------------------------------------------
    +
    384 END IF
    +
    385 IF(lunit.NE.lunitl) THEN
    +
    386C-----------------------------------------------------------------------
    +
    387
    +
    388C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME
    +
    389C 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/)
    +
    396C-----------------------------------------------------------------------
    +
    397 ELSE
    +
    398
    +
    399C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME,
    +
    400C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST
    +
    401C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE
    +
    402C 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
    +
    411C-----------------------------------------------------------------------
    +
    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'/)
    +
    416C-----------------------------------------------------------------------
    +
    417
    +
    418C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR
    +
    419C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL
    +
    420
    +
    421C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN)
    +
    422C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME,
    +
    423C OPEN BUFR DATA SET
    +
    424
    +
    425C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES
    +
    426
    +
    427C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED)
    +
    428
    +
    429C-----------------------------------------------------------------------
    +
    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)
    +
    441cppppp
    +
    442 print *,'CENTER DATE (ICDATE) = ',icdate
    +
    443 print *,'DUMP DATE (IDDATE) = ',iddate
    +
    444cppppp
    +
    445
    +
    446 if(icdate(1).le.0) then
    +
    447C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
    +
    448C - 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
    +
    454C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
    +
    455C - 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
    +
    462C If 2-digit year returned in ICDATE(1), must use "windowing" technique
    +
    463C to create a 4-digit year
    +
    464
    +
    465C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    466C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    467C 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
    +
    485C If 2-digit year returned in IDDATE(1), must use "windowing" technique
    +
    486C to create a 4-digit year
    +
    487
    +
    488C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    489C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    490C 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
    +
    506C 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'/)
    +
    520C 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/)
    +
    524C 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
    +
    540C-----------------------------------------------------------------------
    +
    541 END IF
    +
    542C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE
    +
    543 CALL unpk7701(lunit,itp,iret)
    +
    544C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD
    +
    545C (REWIND DATA FILE AND RETURN W/ IRET=1)
    +
    546C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN)
    +
    547C (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
    +
    575C INITIALIZE THE OUTPUT ON29 ARRAY
    +
    576 CALL unpk7702(rdata,itp)
    +
    577 IF(itp.EQ.1) THEN
    +
    578C-----------------------------------------------------------------------
    +
    579C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS
    +
    580C-----------------------------------------------------------------------
    +
    581C STORE THE HEADER INFORMATION INTO ON29 FORMAT
    +
    582 CALL unpk7703(lunit,rdata,iret)
    +
    583C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
    +
    584 IF(iret.GE.2) GO TO 99
    +
    585C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10)
    +
    586 CALL unpk7704(lunit,rdata)
    +
    587C 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
    +
    592C-----------------------------------------------------------------------
    +
    593C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS
    +
    594C-----------------------------------------------------------------------
    +
    595C STORE THE HEADER INFORMATION INTO ON29 FORMAT
    +
    596 CALL unpk7708(lunit,rdata,kount,iret)
    +
    597C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
    +
    598 IF(iret.GE.2) GO TO 99
    +
    599C 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
    +
    602C-----------------------------------------------------------------------
    +
    603C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS
    +
    604C-----------------------------------------------------------------------
    +
    605C STORE THE HEADER INFORMATION INTO ON29 FORMAT
    +
    606 CALL unpk7706(lunit,rdata,iret)
    +
    607C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
    +
    608 IF(iret.GE.2) GO TO 99
    +
    609C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4)
    +
    610 CALL unpk7707(lunit,rdata,iret)
    +
    611C-----------------------------------------------------------------------
    +
    612 END IF
    +
    613 99 CONTINUE
    +
    614C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL
    +
    615 lsdate = idate
    +
    616 lshe = ihe
    +
    617 lshl = ihl
    +
    618 RETURN
    +
    619C-----------------------------------------------------------------------
    +
    620 9999 CONTINUE
    +
    621C 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
    +
    631C> @brief Reads a single report out of bufr dataset
    +
    632C> @author Dennis Keyser @date 1996-12-16
    +
    633
    +
    634C> Calls bufrlib routines to read in a bufr message and then read a single
    +
    635C> report (subset) out of the message.
    +
    636C>
    +
    637C> ### Program History Log:
    +
    638C> Date | Programmer | Comment
    +
    639C> -----|------------|--------
    +
    640C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    641C>
    +
    642C> @param[in] LUNIT Fortran unit number for input data file.
    +
    643C> @param[out] ITP The type of report that has been decoded {=1 - wind profiler,
    +
    644C> =2 - goes sndg, =3 - nexrad(vad) wind}
    +
    645C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    646C>
    +
    647C> @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
    +
    661C=======================================================================
    +
    662 IF(index.EQ.0) THEN
    +
    663
    +
    664C READ IN NEXT BUFR MESSAGE
    +
    665
    +
    666 CALL readmg(lunit,subset,ibdate,jret)
    +
    667 IF(jret.NE.0) THEN
    +
    668C-----------------------------------------------------------------------
    +
    669 print 101
    +
    670 101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/)
    +
    671 iret = 1
    +
    672 RETURN
    +
    673C-----------------------------------------------------------------------
    +
    674 END IF
    +
    675 if(ibdate.lt.100000000) then
    +
    676c If input BUFR file does not return messages with a 4-digit year,
    +
    677c something is wrong (even non-compliant BUFR messages should
    +
    678c 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)
    +
    690C 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)
    +
    727C 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
    +
    736C=======================================================================
    +
    737C 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
    +
    745C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL
    +
    746C 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
    +
    752C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS
    +
    753C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND
    +
    754C 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
    +
    776C-----------------------------------------------------------------------
    +
    777 IF(iprint.GT.1) print *, 'READY TO PROCESS NEW DECODED REPORT'
    +
    778C***********************************************************************
    +
    779C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED
    +
    780C***********************************************************************
    +
    781 index = index + 1
    +
    782 IF(iprint.GE.1) print *, 'WORKING WITH SUBSET NUMBER ',index
    +
    783 RETURN
    +
    +
    784 END
    +
    785C> @brief Initializes the output array for a report.
    +
    786C> @author Dennis Keyser @date 1996-12-16
    +
    787
    +
    788C> Initializes the output array which holds a single report in the quasi-office
    +
    789C> note 29 unpacked format to all missing.
    +
    790C>
    +
    791C> ### Program History Log:
    +
    792C> Date | Programmer | Comment
    +
    793C> -----|------------|--------
    +
    794C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    795C> @param[in] ITP the type of report that has been decoded {=1 - wind profiler, =2 - goes sndg, =3 - nexrad(vad) wind}
    +
    796C> @param[out] RDATA single report returned an a quasi-office note 29 unpacked format; all data are missing
    +
    797C>
    +
    798C> @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
    +
    803C
    +
    804 SAVE
    +
    805C
    +
    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
    +
    823C
    +
    824C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS
    +
    825C
    +
    826 idata(13:42) = 0
    +
    827C
    +
    828C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION
    +
    829C
    +
    830 rdatx(43:1200) = xmsg
    +
    831 IF(itp.EQ.1) THEN
    +
    832C
    +
    833C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE
    +
    834C (Current limit of 104 Cat. 11 levels)
    +
    835C
    +
    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
    +
    841C
    +
    842C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12
    +
    843C LEVEL QUALITY MARKERS
    +
    844C (Current limit of 50 Cat. 12 levels)
    +
    845C (could be expanded if need be)
    +
    846C
    +
    847 idata(49:392:7) = iob
    +
    848C
    +
    849C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08
    +
    850C LEVEL QUALITY MARKER
    +
    851C (Current limit of 9 Cat. 08 levels)
    +
    852C (could be expanded if need be)
    +
    853C
    +
    854 idata(395:419:3) = iob
    +
    855C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER
    +
    856C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL
    +
    857C QUALITY MARKER
    +
    858C (Current limit of 60 Cat. 13 levels)
    +
    859C (could be expanded if need be)
    +
    860C
    +
    861 idata(420:599:3) = imsg
    +
    862 idata(422:599:3) = iob
    +
    863 ELSE IF(itp.EQ.3) THEN
    +
    864C
    +
    865C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04
    +
    866C LEVEL QUALITY MARKER
    +
    867C (Current limit of 70 Cat. 04 levels)
    +
    868C (could be expanded if need be)
    +
    869C
    +
    870 idata(46:1200:4) = iob
    +
    871 END IF
    +
    872 rdata(1:1200) = rdatx(1:1200)
    +
    873 RETURN
    +
    +
    874 END
    +
    875C> @brief Fills in header in o-put array - pflr rpt.
    +
    876C> @author Dennis Keyser @date 2002-03-05
    +
    877
    +
    878C> For report (subset) read out of bufr message (passed in
    +
    879C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    880C> header data for wind profiler report. header is then filled into
    +
    881C> the output array which holds a single wind profiler report in the
    +
    882C> quasi-office note 29 unpacked format.
    +
    883C>
    +
    884C> ### Program History Log:
    +
    885C> Date | Programmer | Comment
    +
    886C> -----|------------|--------
    +
    887C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    888C> 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)
    +
    889C>
    +
    890C> @param[in] LUNIT Fortran unit number for input data file
    +
    891C> @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
    +
    892C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    893C>
    +
    894C> @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
    +
    914C.......................................................................
    +
    915C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    916C 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
    +
    922C.......................................................................
    +
    923 END IF
    +
    924
    +
    925C 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
    +
    943C 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
    +
    959C 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
    +
    968C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
    +
    969C (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
    +
    977C SUBMODE INFORMATION
    +
    978C EDITION NUMBER (ALWAYS = 2)
    +
    979C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER)
    +
    980C {NOTE: After 3/2002, the submode information is no longer
    +
    981C 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
    +
    991C AVERAGING TIME (STORED AS INTEGER)
    +
    992C (NOTE: Prior to 3/2002, this is decoded in minutes, after
    +
    993C 3/2002 this is decoded in seconds - in either case
    +
    994C 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)
    +
    1006C-----------------------------------------------------------------------
    +
    1007
    +
    1008C STATION IDENTIFICATION (STORED AS CHARACTER)
    +
    1009C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS)
    +
    1010
    +
    1011 stnid = ' '
    +
    1012
    +
    1013C 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
    +
    1019C 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
    +
    1034cvvvvvdak port
    +
    1035C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
    +
    1036caaaaadak 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
    +
    1045cvvvvvdak port
    +
    1046 iyear = mod(iyear,100)
    +
    1047caaaaadak port
    +
    1048 iyear = nint(hdr(10)) + (iyear * 100)
    +
    1049cvvvvvdak port
    +
    1050cdak WRITE(COB,'(I6.6,2X)') IYEAR
    +
    1051 WRITE(cob,'(I4.4,4X)') iyear
    +
    1052caaaaadak 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
    +
    1061C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
    +
    1062C 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
    +
    1093C> @brief Fills cat.10 into o-put array - pflr rpt
    +
    1094C> @author Dennis Keyser @date 2002-03-05
    +
    1095
    +
    1096C> For report (subset) read out of bufr message (passed in
    +
    1097C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1098C> surface data for wind profiler report. Surface data are then
    +
    1099C> filled into the output array as category 10. The ouput array
    +
    1100C> holds a single wind profiler report in the quasi-office note 29
    +
    1101C> unpacked format.
    +
    1102C>
    +
    1103C> ### Program History Log:
    +
    1104C> Date | Programmer | Comment
    +
    1105C> -----|------------|--------
    +
    1106C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    1107C> 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)
    +
    1108C>
    +
    1109C> @param[in] LUNIT Fortran unit number for input data file
    +
    1110C> @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
    +
    1111C>
    +
    1112C> @remark Called by subroutine w3unpkb7. after 3/2002, there is no surface data available.
    +
    1113C>
    +
    1114C$$$
    +
    +
    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
    +
    1131C.......................................................................
    +
    1132C 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
    +
    1137C.......................................................................
    +
    1138 END IF
    +
    1139
    +
    1140C 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
    +
    1150C 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
    +
    1158C 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
    +
    1166C 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
    +
    1174C 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
    +
    1182C 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
    +
    1190C 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
    +
    1200C> @brief Fills cat.11 into o-put array - pflr rpt
    +
    1201C> @author Dennis Keyser @date 2002-03-05
    +
    1202
    +
    1203C> For report (subset) read out of bufr message (passed in
    +
    1204C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1205C> upper-air data for wind profiler report. upper-air data are then
    +
    1206C> filled into the output array as category 11. the ouput array
    +
    1207C> holds a single wind profiler report in the quasi-office note 29
    +
    1208C> unpacked format.
    +
    1209C>
    +
    1210C> ### Program History Log:
    +
    1211C> Date | Programmer | Comment
    +
    1212C> -----|------------|--------
    +
    1213C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    1214C> 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
    +
    1215C> 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)
    +
    1216C>
    +
    1217C> @param[in] LUNIT Fortran unit number for input data file
    +
    1218C> @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
    +
    1219C>
    +
    1220C$$$
    +
    +
    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
    +
    1240C 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
    +
    1264C.......................................................................
    +
    1265C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    1266 IF(nsfc.EQ.0) THEN
    +
    1267C ... 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
    +
    1273C ... 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
    +
    1279C.......................................................................
    +
    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
    +
    1289C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
    +
    1290C (NOTE: At one time, possibly even now, the height above sea
    +
    1291C level was erroneously stored under mnemonic "HAST"
    +
    1292C when it should have been stored under mnemonic "HEIT".
    +
    1293C ("HAST" is defined as the height above the station.)
    +
    1294C Will test first for valid data in "HEIT" - if missing,
    +
    1295C then will use data in "HAST" - this will allow this
    +
    1296C 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
    +
    1311C 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
    +
    1318C 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
    +
    1325C 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
    +
    1333C 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
    +
    1340C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER)
    +
    1341C (NOTE: Prior to 2/18/1999, the horizonal consensus number was
    +
    1342C stored under mnemonic "ACAV1".
    +
    1343C From 2/18/1999 through 3/2002, the horizontal consensus
    +
    1344C number was stored under mnemonic "ACAVH".
    +
    1345C After 3/2002, the horizontal consensus number is no
    +
    1346C longer stored.
    +
    1347C Will test first for valid data in "ACAVH" - if missing,
    +
    1348C then will test for data in "ACAV1" - this will allow
    +
    1349C 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
    +
    1362C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER)
    +
    1363C (NOTE: Prior to 2/18/1999, the vertical consensus number was
    +
    1364C stored under mnemonic "ACAV2".
    +
    1365C From 2/18/1999 through 3/2002, the vertical consensus
    +
    1366C number was stored under mnemonic "ACAVV".
    +
    1367C After 3/2002, the vertical consensus number is no
    +
    1368C longer stored.
    +
    1369C Will test first for valid data in "ACAVV" - if missing,
    +
    1370C then will test for data in "ACAV2" - this will allow
    +
    1371C 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
    +
    1384C SPECTRAL PEAK POWER (STORED AS REAL)
    +
    1385C (NOTE: After 3/2002, the spectral peak power is no longer
    +
    1386C 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
    +
    1393C 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
    +
    1400C 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
    +
    1407C MODE INFORMATION (STORED AS INTEGER)
    +
    1408C (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)
    +
    1414C.......................................................................
    +
    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
    +
    1420C 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
    +
    1431C> @brief Fills in header in o-put array - vadw rpt.
    +
    1432C> @author Dennis Keyser @date 1997-06-02
    +
    1433
    +
    1434C> For report (subset) read out of bufr message (passed in
    +
    1435C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1436C> header data for nexrad (vad) wind report. Header is then filled
    +
    1437C> into the output array which holds a single vad wind report in the
    +
    1438C> quasi-office note 29 unpacked format.
    +
    1439C>
    +
    1440C> ### Program History Log:
    +
    1441C> Date | Programmer | Comment
    +
    1442C> -----|------------|--------
    +
    1443C> 1997-06-02 | Dennis Keyser NP22 | Initial.
    +
    1444C>
    +
    1445C> @param[in] LUNIT Fortran unit number for input data file
    +
    1446C> @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
    +
    1447C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    1448C>
    +
    1449C> @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
    +
    1467C.......................................................................
    +
    1468C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    1469C 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
    +
    1475C.......................................................................
    +
    1476 END IF
    +
    1477
    +
    1478C 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
    +
    1495C 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
    +
    1510C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
    +
    1511C (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
    +
    1519C STATION IDENTIFICATION (STORED AS CHARACTER)
    +
    1520C ('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
    +
    1535cvvvvvdak port
    +
    1536C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
    +
    1537caaaaadak 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
    +
    1546cvvvvvdak port
    +
    1547 iyear = mod(iyear,100)
    +
    1548caaaaadak port
    +
    1549 iyear = nint(hdr(6)) + (iyear * 100)
    +
    1550cvvvvvdak port
    +
    1551cdak WRITE(COB,'(I6.6,2X)') IYEAR
    +
    1552 WRITE(cob,'(I4.4,4X)') iyear
    +
    1553caaaaadak 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
    +
    1562C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
    +
    1563C 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
    +
    1594C> @brief Fills cat. 4 into o-put array - vadw rpt
    +
    1595C> @author Dennis Keyser @date 1997-06-02
    +
    1596
    +
    1597C> For report (subset) read out of bufr message (passed in
    +
    1598C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1599C> upper-air data for nexrad (vad) wind report. Upper-air data are
    +
    1600C> then filled into the output array as category 4. The ouput array
    +
    1601C> holds a single vad wind report in the quasi-office note 29
    +
    1602C> unpacked format.
    +
    1603C>
    +
    1604C> ### Program History Log:
    +
    1605C> Date | Programmer | Comment
    +
    1606C> -----|------------|--------
    +
    1607C> 1997-06-02 | Dennis Keyser NP22 | Initial.
    +
    1608C>
    +
    1609C> @param[in] LUNIT Fortran unit number for input data file
    +
    1610C> @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
    +
    1611C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    1612C>
    +
    1613C> @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
    +
    1633C 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
    +
    1641C NOTE: The following was added because of a problem on the sgi-ha
    +
    1642C platform related to equivalencing character and non-character
    +
    1643C -- for now the addition of these two lines will set the quality
    +
    1644C mark for sfc. cat . 4 level to the correct value of " "
    +
    1645C rather than to "9999" - Mary McCann notified SGI of this
    +
    1646C 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
    +
    1656C.......................................................................
    +
    1657C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    1658 IF(nsfc.EQ.0) THEN
    +
    1659C ... 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
    +
    1665C ... 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
    +
    1671C.......................................................................
    +
    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
    +
    1681C 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
    +
    1689C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT
    +
    1690
    +
    1691 ilvl = ilvl + 1
    +
    1692 ELSE
    +
    1693
    +
    1694C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID
    +
    1695C 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
    +
    1703C 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
    +
    1710C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED
    +
    1711C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD
    +
    1712C 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
    +
    1719C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR)
    +
    1720C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED
    +
    1721C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE
    +
    1722C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT
    +
    1723C 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
    +
    1729C ... CONVERT FROM M/S TO KNOTS
    +
    1730
    +
    1731CDAKCDAK 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
    +
    1744C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED)
    +
    1745
    +
    1746 m = 5
    +
    1747 IF(iprint.GT.1) print 199, uair(5,i),m
    +
    1748C.......................................................................
    +
    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
    +
    1756C 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
    +
    1772C> @brief Fills in header in o-put array - goes snd
    +
    1773C> @author Dennis Keyser @date 1998-07-09
    +
    1774
    +
    1775C> For report (subset) read out of bufr message (passed in
    +
    1776C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1777C> header data for goes sounding report. Header is then filled into
    +
    1778C> the output array which holds a single goes sounding report in the
    +
    1779C> quasi-office note 29 unpacked format.
    +
    1780C>
    +
    1781C> ### Program History Log:
    +
    1782C> Date | Programmer | Comment
    +
    1783C> -----|------------|--------
    +
    1784C> 1997-06-05 | Dennis Keyser NP22 | Initial.
    +
    1785C> 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)
    +
    1786C>
    +
    1787C> @param[in] LUNIT Fortran unit number for input data file
    +
    1788C> @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
    +
    1789C> @param[in] KOUNT Number of reports processed including this one
    +
    1790C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    1791C>
    +
    1792C> @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
    +
    1811C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007)
    +
    1812C -----------------------------------------------------------
    +
    1813
    +
    1814C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256
    +
    1815C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257
    +
    1816C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258
    +
    1817
    +
    1818C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 --
    +
    1819C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,...
    +
    1820C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN
    +
    1821C --- --- ---- --- --- ---- --- --- ---- --- --- ----
    +
    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
    +
    1829C.......................................................................
    +
    1830C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    1831C 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
    +
    1837C.......................................................................
    +
    1838 END IF
    +
    1839
    +
    1840C 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
    +
    1857C 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
    +
    1872C 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
    +
    1881C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL)
    +
    1882C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709
    +
    1883
    +
    1884
    +
    1885C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING
    +
    1886C 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
    +
    1900C 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
    +
    1908C STATION IDENTIFICATION (STORED AS CHARACTER)
    +
    1909C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER,
    +
    1910C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG)
    +
    1911
    +
    1912 WRITE(stnid(1:5),'(I5.5)') min(kount,99999)
    +
    1913
    +
    1914C 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
    +
    1940cvvvvvdak port
    +
    1941C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
    +
    1942caaaaadak 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
    +
    1951cvvvvvdak port
    +
    1952 iyear = mod(iyear,100)
    +
    1953caaaaadak port
    +
    1954 iyear = nint(hdr(8)) + (iyear * 100)
    +
    1955cvvvvvdak port
    +
    1956cdak WRITE(COB,'(I6.6,2X)') IYEAR
    +
    1957 WRITE(cob,'(I4.4,4X)') iyear
    +
    1958caaaaadak 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
    +
    1967C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
    +
    1968C 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
    +
    1999C> @brief Fills cat. 12,8 to o-put array -goes sndg
    +
    2000C> @author Dennis Keyser @date 1997-06-05
    +
    2001
    +
    2002C> For report (subset) read out of bufr message (passed in
    +
    2003C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    2004C> upper-air (sounding) and additional data for goes sounding. Upper-
    +
    2005C> air data are then filled into the output array as category 12
    +
    2006C> (satellite sounding) and additional data are filled as category 8.
    +
    2007C> The ouput array holds a single goes sounding in the quasi-office
    +
    2008C> note 29 unpacked format.
    +
    2009C>
    +
    2010C> ### Program History Log:
    +
    2011C> Date | Programmer | Comment
    +
    2012C> -----|------------|--------
    +
    2013C> 1997-06-05 | Dennis Keyser NP22 | Initial.
    +
    2014C>
    +
    2015C> @param[in] LUNIT Fortran unit number for input data file
    +
    2016C> @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
    +
    2017C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    2018C>
    +
    2019C> @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
    +
    2043C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF-
    +
    2044C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING
    +
    2045C --> 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
    +
    2057C***********************************************************************
    +
    2058C FILL CATEGORY 12 PART OF OUTPUT
    +
    2059C***********************************************************************
    +
    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
    +
    2066C.......................................................................
    +
    2067C 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
    +
    2073C.......................................................................
    +
    2074C 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
    +
    2079C.......................................................................
    +
    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
    +
    2089C 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
    +
    2097C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE
    +
    2098C -- 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
    +
    2103C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE
    +
    2104C 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
    +
    2110C 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
    +
    2117C 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
    +
    2131C 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
    +
    2140C 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
    +
    2149C 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,'"')
    +
    2155C.......................................................................
    +
    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
    +
    2163C 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
    +
    2170C***********************************************************************
    +
    2171C FILL CATEGORY 8 PART OF OUTPUT
    +
    2172C WILL ATTEMPT TO FILL 12 "LEVELS"
    +
    2173C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250.
    +
    2174C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251.
    +
    2175C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252.
    +
    2176C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253.
    +
    2177C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254.
    +
    2178C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255.
    +
    2179C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256.
    +
    2180C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257.
    +
    2181C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258.
    +
    2182C LVL 10- INSTR. DATA USED IN PROC.
    +
    2183C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259.
    +
    2184C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260.
    +
    2185C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261.
    +
    2186C
    +
    2187C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED
    +
    2188C***********************************************************************
    +
    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
    +
    2196C.......................................................................
    +
    2197C 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
    +
    2202C.......................................................................
    +
    2203 ELSE
    +
    2204C.......................................................................
    +
    2205C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    2206C 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
    +
    2212C.......................................................................
    +
    2213 END IF
    +
    2214 END IF
    +
    2215
    +
    2216C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO
    +
    2217C 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
    +
    2229C 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
    +
    2239C WE HAVE A VALID CATEGORY 8 "LEVEL"
    +
    2240
    +
    2241 ilvl = ilvl + 1
    +
    2242
    +
    2243C 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
    +
    2248C 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
    +
    2253C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL
    +
    2254
    +
    2255 cob = cqmflg//' '
    +
    2256
    +
    2257C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL
    +
    2258C 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
    +
    2273C 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
    +
    2280C***********************************************************************
    +
    2281C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES)
    +
    2282C***********************************************************************
    +
    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
    +
    2289C.......................................................................
    +
    2290C 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
    +
    2296C.......................................................................
    +
    2297C 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
    +
    2302C.......................................................................
    +
    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
    +
    2312C 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
    +
    2318C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL
    +
    2319C 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
    +
    2325C 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
    +
    2332C 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
    +
    2339C 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)
    +
    2344C.......................................................................
    +
    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
    +
    2352C 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
    +
    errexit
    subroutine errexit(iret)
    Exit with a return code.
    Definition errexit.f:20
    +
    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
    +
    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
    +
    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
    +
    unpk7708
    subroutine unpk7708(lunit, rdata, kount, iret)
    Fills in header in o-put array - goes snd.
    Definition w3unpk77.f:1794
    +
    unpk7702
    subroutine unpk7702(rdata, itp)
    Initializes the output array for a report.
    Definition w3unpk77.f:800
    +
    unpk7705
    subroutine unpk7705(lunit, rdata)
    Fills cat.11 into o-put array - pflr rpt.
    Definition w3unpk77.f:1222
    +
    unpk7709
    subroutine unpk7709(lunit, rdata, iret)
    Fills cat.
    Definition w3unpk77.f:2021
    +
    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
    +
    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
    +
    unpk7706
    subroutine unpk7706(lunit, rdata, iret)
    Fills in header in o-put array - vadw rpt.
    Definition w3unpk77.f:1451
    +
    unpk7704
    subroutine unpk7704(lunit, rdata)
    Fills cat.10 into o-put array - pflr rpt.
    Definition w3unpk77.f:1116
    +
    unpk7703
    subroutine unpk7703(lunit, rdata, iret)
    Fills in header in o-put array - pflr rpt.
    Definition w3unpk77.f:896
    diff --git a/w3utcdat_8f.html b/w3utcdat_8f.html index 7c71ada6..dffcbf42 100644 --- a/w3utcdat_8f.html +++ b/w3utcdat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3utcdat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3utcdat.f File Reference
    +
    w3utcdat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    subroutine w3utcdat (idat)
     This subprogram returns the utc (greenwich) date and time in the NCEP absolute date and time data structure.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3utcdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3utcdat()

    + +

    ◆ w3utcdat()

    @@ -124,7 +130,7 @@

    This subprogram returns the utc (greenwich) date and time in the NCEP absolute date and time data structure.

    -

    +

    Program History Log:

    @@ -154,7 +160,7 @@

    diff --git a/w3utcdat_8f_source.html b/w3utcdat_8f_source.html index a467e815..2f8d1a1c 100644 --- a/w3utcdat_8f_source.html +++ b/w3utcdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3utcdat.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,59 +81,67 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3utcdat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    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
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    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
    diff --git a/w3valdat_8f.html b/w3valdat_8f.html index 39f9d910..ee5302b5 100644 --- a/w3valdat_8f.html +++ b/w3valdat_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3valdat.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3valdat.f File Reference
    +
    w3valdat.f File Reference
    @@ -94,10 +100,10 @@

    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...
    logical function w3valdat (idat)
     This logical function returns true if the input is a valid NCEP absolute date and time.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file w3valdat.f.

    Function/Subroutine Documentation

    - -

    ◆ w3valdat()

    + +

    ◆ w3valdat()

    @@ -124,7 +130,7 @@

    This logical function returns true if the input is a valid NCEP absolute date and time.

    -

    +

    Program History Log:

    @@ -152,7 +158,7 @@

    diff --git a/w3valdat_8f_source.html b/w3valdat_8f_source.html index 2ec659d5..0208505d 100644 --- a/w3valdat_8f_source.html +++ b/w3valdat_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3valdat.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,48 +81,56 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3valdat.f
    +
    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
    -
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    -
    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
    -
    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
    +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
    +
    iw3jdn
    function iw3jdn(iyear, month, iday)
    Computes julian day number from year (4 digits), month, and day.
    Definition iw3jdn.f:42
    +
    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
    +
    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
    diff --git a/w3ymdh4_8f.html b/w3ymdh4_8f.html index 9bcbce53..7e6080f4 100644 --- a/w3ymdh4_8f.html +++ b/w3ymdh4_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ymdh4.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    w3ymdh4.f File Reference
    +
    w3ymdh4.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    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.
     

    Detailed Description

    4-byte date word unpacker and packer.

    @@ -107,8 +113,8 @@

    Definition in file w3ymdh4.f.

    Function/Subroutine Documentation

    - -

    ◆ w3ymdh4()

    + +

    ◆ w3ymdh4()

    @@ -117,37 +123,37 @@

    subroutine w3ymdh4 ( character, dimension(4)  - IDATE, + idate,   - IYEAR, + iyear,   - MONTH, + month,   - IDAY, + iday,   - IHOUR, + ihour,   - NN  + nn  @@ -166,7 +172,7 @@

    +

    Program History Log:

    @@ -205,7 +211,7 @@

    diff --git a/w3ymdh4_8f.js b/w3ymdh4_8f.js index 3e772cad..7dfcf9f3 100644 --- a/w3ymdh4_8f.js +++ b/w3ymdh4_8f.js @@ -1,4 +1,4 @@ var w3ymdh4_8f = [ - [ "w3ymdh4", "w3ymdh4_8f.html#a78ffe9a370f362c71bcb5573f595f105", null ] + [ "w3ymdh4", "w3ymdh4_8f.html#a6ec6f6ef8936c7069feafafcb4ca333b", null ] ]; \ No newline at end of file diff --git a/w3ymdh4_8f_source.html b/w3ymdh4_8f_source.html index 835603d3..2055a129 100644 --- a/w3ymdh4_8f_source.html +++ b/w3ymdh4_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: w3ymdh4.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,119 +81,127 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    w3ymdh4.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief 4-byte date word unpacker and packer.
    +
    3C> @author K. F. Brill @date 1998-07-29
    +
    4
    +
    5C> Obtains the components of the nmc date word (ncep y2k
    +
    6C> compliant form), or given its components, forms an nmc type date
    +
    7C> word. The packing is done using base 32.
    +
    8C>
    +
    9C> If the first byte of IDATE is less than 101, then the old
    +
    10C> Office Note 84 packing is assumed. A four-digit year is
    +
    11C> always returned. To pack the "old" way, pass in a 2-digit
    +
    12C> year.
    +
    13C>
    +
    14C> This program will work for the years ranging from A.D. 101
    +
    15C> through 79359.
    +
    16C>
    +
    17C> On unpacking, years less than or equal to 100 are returned
    +
    18C> as follows:
    +
    19C>
    +
    20C> - 0-50 2000--2050
    +
    21C> - 51-100 1951--2000
    +
    22C>
    +
    23C>
    +
    24C> ### Program History Log:
    +
    25C> Date | Programmer | Comment
    +
    26C> -----|------------|--------
    +
    27C> 1998-07-29 | K. F. Brill | Initial.
    +
    28C> 1999-03-15 | Gilbert | Removed Call to W3FS11() and put its processing inline.
    +
    29C> W3FS11 was deleted from the W3LIB.
    +
    30C>
    +
    31C> @param[inout] IDATE Left 4 bytes of integer 64 bit word, or can be
    +
    32C> IDATE(4) or CHARACTER*4 IDATE.
    +
    33C> @param[inout] IYEAR Year (4 digits or 2 digits for on84)
    +
    34C> @param[inout] MONTH Month
    +
    35C> @param[inout] IDAY Day
    +
    36C> @param[inout] IHOUR Hour
    +
    37C> @param[in] NN Code:
    +
    38C> - .eq. 0 pack iyear, month, iday, ihour into idate
    +
    39C> - .ne. 0 unpack idate into iyear, month, iday, ihour
    +
    40C>
    +
    41C> @author K. F. Brill @date 1998-07-29
    +
    +
    42 SUBROUTINE w3ymdh4 (IDATE,IYEAR,MONTH,IDAY,IHOUR,NN)
    +
    43C
    +
    44 CHARACTER IDATE(4)
    +
    45C
    +
    46 IF (nn.NE.0) THEN
    +
    47C
    +
    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
    +
    67C
    +
    68 ELSE
    +
    69C
    +
    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
    +
    81C*
    +
    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)
    +
    90C
    +
    91 ENDIF
    +
    92C
    +
    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/xdopen_8f.html b/xdopen_8f.html index 3f63e8c3..0bfe3742 100644 --- a/xdopen_8f.html +++ b/xdopen_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: xdopen.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    xdopen.f File Reference
    +
    xdopen.f File Reference
    @@ -94,10 +100,10 @@

    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...
    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.
     

    Detailed Description

    @@ -107,8 +113,8 @@

    Definition in file xdopen.f.

    Function/Subroutine Documentation

    - -

    ◆ xdopen()

    + +

    ◆ xdopen()

    @@ -121,7 +127,7 @@

    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:

    @@ -142,7 +148,7 @@

    diff --git a/xdopen_8f_source.html b/xdopen_8f_source.html index 00a46f29..8a434bed 100644 --- a/xdopen_8f_source.html +++ b/xdopen_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: xdopen.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,76 +81,84 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    xdopen.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Dummy subroutine
    +
    3C> @author Dennis Keyser @date 1992-07-02
    +
    4
    +
    5C> This subroutine and the corresponding entries: "errset",
    +
    6C> "xdchek", "xdclos", "xdwrit", "xdread", and "xdform" are placed
    +
    7C> here to allow calling routines which reside on both the nas and
    +
    8C> the cray to compile. These subroutines perform nas-specific
    +
    9C> functions, but have no corresponding function on the cray. There-
    +
    10C> fore this subroutine is a "dummy". ft06 print is provided to
    +
    11C> alert the user that the call to the subroutine results in an
    +
    12C> immediate return with no function.
    +
    13C>
    +
    14C> ### Program History Log:
    +
    15C> Date | Programmer | Comment
    +
    16C> -----|------------|--------
    +
    17C> 1992-07-02 | Dennis Keyser (W/NMC22) | Initial.
    +
    18C>
    +
    19C> @author Dennis Keyser @date 1992-07-02
    +
    +
    20 SUBROUTINE xdopen
    +
    21C
    +
    22 CHARACTER*6 ROUTIN(7)
    +
    23C
    +
    24 DATA routin/'XDOPEN','ERRSET','XDCHEK','XDCLOS','XDWRIT',
    +
    25 $ 'XDREAD','XDFORM'/
    +
    26C
    +
    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/xmovex_8f.html b/xmovex_8f.html index 0c11690b..c07c76b4 100644 --- a/xmovex_8f.html +++ b/xmovex_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: xmovex.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@

    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    xmovex.f File Reference
    +
    xmovex.f File Reference
    @@ -94,10 +100,10 @@

    Go to the source code of this file.

    - - - + +

    +

    Functions/Subroutines

    subroutine xmovex (OUT, IN, IBYTES)
     
    subroutine xmovex (out, in, ibytes)
     

    Detailed Description

    Assembler language to move data.

    @@ -106,8 +112,8 @@

    Definition in file xmovex.f.

    Function/Subroutine Documentation

    - -

    ◆ xmovex()

    + +

    ◆ xmovex()

    @@ -116,19 +122,19 @@

    subroutine xmovex ( character*1, dimension(*)  - OUT, + out, character*1, dimension(*)  - IN, + in, integer  - IBYTES  + ibytes  @@ -137,7 +143,7 @@

    -

    +

    Program History Log:

    @@ -166,7 +172,7 @@

    diff --git a/xmovex_8f.js b/xmovex_8f.js index 85b8a2f5..0b440c81 100644 --- a/xmovex_8f.js +++ b/xmovex_8f.js @@ -1,4 +1,4 @@ var xmovex_8f = [ - [ "xmovex", "xmovex_8f.html#a4736b412fd765dc34e51e7ebf774cc61", null ] + [ "xmovex", "xmovex_8f.html#a9966425854c3a77f854b1397051af333", null ] ]; \ No newline at end of file diff --git a/xmovex_8f_source.html b/xmovex_8f_source.html index 72af3023..d582b88e 100644 --- a/xmovex_8f_source.html +++ b/xmovex_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: xmovex.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,55 +81,63 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    xmovex.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Assembler language to move data
    +
    3C> @author Unknown @date Unknown
    +
    4
    +
    5C> ### Program History Log:
    +
    6C> Date | Programmer | Comment
    +
    7C> -----|------------|--------
    +
    8C> Unkonwn | Unknonw | Initial.
    +
    9C>
    +
    10C> @param[out] OUT
    +
    11C> @param[in] IN
    +
    12C> @param IBYTES
    +
    13C> This subroutine may not be needed, its was in
    +
    14C> assembler language to move data, it ran about three
    +
    15C> times faster than a fortan do loop, it was used to
    +
    16C> make sure the data to be unpacked was on a word boundary,
    +
    17C> this may not be needed on some brands of computers.
    +
    18C>
    +
    19C> @author Unknown @date Unknown
    +
    +
    20 SUBROUTINE xmovex(OUT,IN,IBYTES)
    +
    21 CHARACTER*1 OUT(*)
    +
    22 CHARACTER*1 IN(*)
    +
    23C
    +
    24 INTEGER IBYTES
    +
    25C
    +
    26 DO 100 i = 1,ibytes
    +
    27 out(i) = in(i)
    +
    28 100 CONTINUE
    +
    29C
    +
    30 RETURN
    +
    +
    31 END
    +
    xmovex
    subroutine xmovex(out, in, ibytes)
    Definition xmovex.f:21
    diff --git a/xstore_8f.html b/xstore_8f.html index 4534945c..89be76f4 100644 --- a/xstore_8f.html +++ b/xstore_8f.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: xstore.f File Reference @@ -23,10 +23,9 @@
    - - + @@ -34,21 +33,22 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0
    - + +/* @license-end */ +
    @@ -62,7 +62,7 @@
    @@ -76,16 +76,22 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    Functions/Subroutines
    -
    -
    xstore.f File Reference
    +
    xstore.f File Reference
    @@ -94,11 +100,11 @@

    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...
     
    subroutine xstore (cout, con, mwords)
     Stores an 8-byte (fullword) value through consecutive storage locations.
     

    Detailed Description

    Stores a constant value into an array.

    @@ -107,8 +113,8 @@

    Definition in file xstore.f.

    Function/Subroutine Documentation

    - -

    ◆ xstore()

    + +

    ◆ xstore()

    @@ -117,19 +123,19 @@

    subroutine xstore ( dimension(*)  - COUT, + cout,   - CON, + con,   - MWORDS  + mwords  @@ -141,7 +147,7 @@

    +

    Program History Log:

    @@ -173,7 +179,7 @@

    diff --git a/xstore_8f.js b/xstore_8f.js index 07d11501..c7a84564 100644 --- a/xstore_8f.js +++ b/xstore_8f.js @@ -1,4 +1,4 @@ var xstore_8f = [ - [ "xstore", "xstore_8f.html#a31e695d6327ff9328c6604bc9d72a245", null ] + [ "xstore", "xstore_8f.html#ad26510a638e68e3e62108516ffc9e5dc", null ] ]; \ No newline at end of file diff --git a/xstore_8f_source.html b/xstore_8f_source.html index ea829bab..5b8fee0d 100644 --- a/xstore_8f_source.html +++ b/xstore_8f_source.html @@ -1,9 +1,9 @@ - + - - + + NCEPLIBS-w3emc: xstore.f Source File @@ -23,10 +23,9 @@

    - - + @@ -34,22 +33,28 @@
    -
    NCEPLIBS-w3emc -  2.11.0 +
    +
    NCEPLIBS-w3emc 2.11.0

    - + +/* @license-end */ + +
    @@ -76,61 +81,69 @@
    - +
    +
    +
    +
    +
    Loading...
    +
    Searching...
    +
    No Matches
    +
    +
    +
    -
    -
    xstore.f
    +
    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
    +Go to the documentation of this file.
    1C> @file
    +
    2C> @brief Stores a constant value into an array
    +
    3C> @author Dennis Keyser @date 1992-07-02
    +
    4
    +
    5C> Stores an 8-byte (fullword) value through consecutive storage locations.
    +
    6C> (moving is accomplished with a do loop.)
    +
    7C>
    +
    8C> ### Program History Log:
    +
    9C> Date | Programmer | Comment
    +
    10C> -----|------------|--------
    +
    11C> 1992-07-02 | Dennis Keyser (W/NMC22) | Initial.
    +
    12C> 1995-10-31 | Mark Iredell | Removed saves and prints.
    +
    13C>
    +
    14C> @param[in] CON Constant to be stored into "mwords" consecutive
    +
    15C> fullwords beginning with "cout" array
    +
    16C> @param[in] MWORDS Number of fullwords in "cout" array to store "con";
    +
    17C> must be .gt. zero (not checked for this)
    +
    18C> @param[out] COUT Starting address for array of "mwords" fullwords
    +
    19C> set to the contents of the value "con"
    +
    20C>
    +
    21C> @remark The version of this subroutine on the hds common library
    +
    22C> is nas-specific subr. written in assembly lang. to allow fast
    +
    23C> computation time. subr. placed in cray w3lib to allow codes to
    +
    24C> compile on both the hds and cray machines.
    +
    25C> subprogram can be called from a multiprocessing environment.
    +
    26C>
    +
    27C> @author Dennis Keyser @date 1992-07-02
    +
    +
    28 SUBROUTINE xstore(COUT,CON,MWORDS)
    +
    29C
    +
    30 dimension cout(*)
    +
    31C
    +
    32 DO 1000 i = 1,mwords
    +
    33 cout(i) = con
    +
    341000 CONTINUE
    +
    35C
    +
    36 RETURN
    +
    +
    37 END
    +
    xstore
    subroutine xstore(cout, con, mwords)
    Stores an 8-byte (fullword) value through consecutive storage locations.
    Definition xstore.f:29