From e7f53e57c4081be14327ce03674c535075186f7e Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Wed, 3 Jun 2020 13:17:20 -0600 Subject: [PATCH 01/11] Remove the libsrc/ and fix/ submodules --- .gitmodules | 7 ------- fix | 1 - libsrc | 1 - 3 files changed, 9 deletions(-) delete mode 100644 .gitmodules delete mode 160000 fix delete mode 160000 libsrc diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index f4bfd21ee7..0000000000 --- a/.gitmodules +++ /dev/null @@ -1,7 +0,0 @@ -[submodule "fix"] - path = fix - url = gerrit:GSI-fix - -[submodule "libsrc"] - path = libsrc - url = gerrit:GSI-libsrc diff --git a/fix b/fix deleted file mode 160000 index f0f7447ff0..0000000000 --- a/fix +++ /dev/null @@ -1 +0,0 @@ -Subproject commit f0f7447ff01d07e7d9b6efe017a62e26541751cb diff --git a/libsrc b/libsrc deleted file mode 160000 index 21f2383e07..0000000000 --- a/libsrc +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 21f2383e075a0d0bfd24df60998c061fc4de202a From c26870479be0766bba95424b69e64a0014c066d2 Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Thu, 4 Jun 2020 00:42:14 -0600 Subject: [PATCH 02/11] remove libsrc/ and fix/, start to use NCEPLIBS add GSD/ wrflib/ bufr/ to src/ (NCEPLIBS did not release bufr lib yet) Generic.cmake (let it default to use compiled NCEPLIBS) util/EnKF/arw/src/enspreproc_regional.fd (need to link module_fv3gfs_ncio) gsdcloudanalysis*.F90 (adjust #ifdef block to solve compiling problems) src/enkf/gridio_wrf.f90 (update to match lastest gfsv16 updates) ush/build.comgsi: adapt to new code structure after transition to Github --- CMakeLists.txt | 16 +- cmake/Modules/FindBUFR.cmake | 6 +- cmake/Modules/findHelpers.cmake | 8 +- cmake/Modules/platforms/Generic.cmake | 11 + src/GSD/gsdcloud/ARPS_cldLib.f90 | 1405 +++ src/GSD/gsdcloud/BackgroundCld.f90 | 315 + src/GSD/gsdcloud/BckgrndCC.f90 | 158 + src/GSD/gsdcloud/CMakeLists.txt | 7 + src/GSD/gsdcloud/PrecipMxr_radar.f90 | 213 + src/GSD/gsdcloud/PrecipType.f90 | 118 + src/GSD/gsdcloud/TempAdjust.f90 | 199 + src/GSD/gsdcloud/adaslib.f90 | 474 + src/GSD/gsdcloud/build_missing_REFcone.f90 | 245 + src/GSD/gsdcloud/cloudCover_NESDIS.f90 | 713 ++ src/GSD/gsdcloud/cloudCover_Surface.f90 | 427 + src/GSD/gsdcloud/cloudCover_radar.f90 | 131 + src/GSD/gsdcloud/cloudLWC.f90 | 419 + src/GSD/gsdcloud/cloudLayers.f90 | 167 + src/GSD/gsdcloud/cloudType.f90 | 147 + src/GSD/gsdcloud/cloud_saturation.f90 | 335 + src/GSD/gsdcloud/configure | 93 + src/GSD/gsdcloud/constants.f90 | 324 + src/GSD/gsdcloud/convert_lghtn2ref.f90 | 197 + src/GSD/gsdcloud/get_sfm_1d_gnl.f90 | 384 + src/GSD/gsdcloud/hydro_mxr_thompson.f90 | 196 + src/GSD/gsdcloud/kinds.f90 | 105 + src/GSD/gsdcloud/make.dependencies | 33 + src/GSD/gsdcloud/make.filelist | 35 + src/GSD/gsdcloud/map_ctp.f90 | 291 + src/GSD/gsdcloud/map_ctp_lar.f90 | 258 + src/GSD/gsdcloud/mthermo.f90 | 229 + src/GSD/gsdcloud/pbl_height.f90 | 103 + src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 | 509 + src/GSD/gsdcloud/radar_ref2tten.f90 | 334 + src/GSD/gsdcloud/read_Lightning_cld.f90 | 93 + src/GSD/gsdcloud/read_NESDIS.f90 | 124 + src/GSD/gsdcloud/read_Surface.f90 | 240 + src/GSD/gsdcloud/read_nasalarc_cld.f90 | 301 + src/GSD/gsdcloud/read_radar_ref.f90 | 106 + src/GSD/gsdcloud/smooth.f90 | 98 + src/GSD/gsdcloud/vinterp_radar_ref.f90 | 142 + src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 | 1405 +++ src/GSD/gsdcloud4nmmb/BackgroundCld.f90 | 193 + src/GSD/gsdcloud4nmmb/BckgrndCC.f90 | 159 + src/GSD/gsdcloud4nmmb/CheckCld.f90 | 292 + src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 | 167 + src/GSD/gsdcloud4nmmb/PrecipType.f90 | 118 + src/GSD/gsdcloud4nmmb/TempAdjust.f90 | 199 + src/GSD/gsdcloud4nmmb/adaslib.f90 | 474 + .../gsdcloud4nmmb/build_missing_REFcone.f90 | 245 + src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 | 697 ++ src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 | 411 + src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 | 137 + src/GSD/gsdcloud4nmmb/cloudLWC.f90 | 418 + src/GSD/gsdcloud4nmmb/cloudLayers.f90 | 167 + src/GSD/gsdcloud4nmmb/cloudType.f90 | 147 + src/GSD/gsdcloud4nmmb/cloud_saturation.f90 | 315 + src/GSD/gsdcloud4nmmb/constants.f90 | 324 + src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 | 245 + .../gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 | 211 + src/GSD/gsdcloud4nmmb/diff.sh | 11 + src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 | 384 + src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 | 198 + src/GSD/gsdcloud4nmmb/kinds.f90 | 105 + src/GSD/gsdcloud4nmmb/make.dependencies | 35 + src/GSD/gsdcloud4nmmb/make.filelist | 36 + src/GSD/gsdcloud4nmmb/makefile | 36 + src/GSD/gsdcloud4nmmb/map_ctp.f90 | 291 + src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 | 256 + src/GSD/gsdcloud4nmmb/mthermo.f90 | 229 + src/GSD/gsdcloud4nmmb/pbl_height.f90 | 103 + src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 | 757 ++ src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 | 631 ++ src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 | 95 + .../gsdcloud4nmmb/read_Lightningbufr_cld.f90 | 109 + src/GSD/gsdcloud4nmmb/read_NESDIS.f90 | 125 + src/GSD/gsdcloud4nmmb/read_Surface.f90 | 251 + src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 | 167 + src/GSD/gsdcloud4nmmb/read_radar_ref.f90 | 107 + src/GSD/gsdcloud4nmmb/smooth.f90 | 98 + src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 | 143 + src/bufr/.gitrepo | 11 + src/bufr/CMakeLists.txt | 22 + src/bufr/README.libbufr | 1617 ++++ src/bufr/adn30.f | 85 + src/bufr/atrcpt.f | 104 + src/bufr/bfrini.f | 299 + src/bufr/blocks.f | 117 + src/bufr/bort.f | 88 + src/bufr/bort2.f | 52 + src/bufr/bort_exit.c | 35 + src/bufr/bufrlib.h | 143 + src/bufr/bufrlib0.PRM | 202 + src/bufr/bvers.f | 50 + src/bufr/cadn30.f | 45 + src/bufr/capit.f | 64 + src/bufr/ccbfl.c | 36 + src/bufr/chekstab.f | 111 + src/bufr/chrtrn.f | 48 + src/bufr/chrtrna.f | 64 + src/bufr/cktaba.f | 292 + src/bufr/closbf.f | 68 + src/bufr/closmg.f | 136 + src/bufr/cmpia.c | 42 + src/bufr/cmpmsg.f | 56 + src/bufr/cmsgini.f | 211 + src/bufr/cnved4.f | 137 + src/bufr/cobfl.c | 106 + src/bufr/conwin.f | 108 + src/bufr/copybf.f | 106 + src/bufr/copymg.f | 136 + src/bufr/copysb.f | 187 + src/bufr/cpbfdx.f | 108 + src/bufr/cpdxmm.f | 162 + src/bufr/cpymem.f | 156 + src/bufr/cpyupd.f | 113 + src/bufr/crbmg.c | 150 + src/bufr/cread.c | 94 + src/bufr/cwbmg.c | 54 + src/bufr/datebf.f | 142 + src/bufr/datelen.f | 73 + src/bufr/digit.f | 52 + src/bufr/drfini.f | 105 + src/bufr/drstpl.f | 99 + src/bufr/dumpbf.f | 174 + src/bufr/dxdump.f | 334 + src/bufr/dxinit.f | 141 + src/bufr/dxmini.f | 178 + src/bufr/elemdx.f | 149 + src/bufr/errwrt.f | 57 + src/bufr/getabdb.f | 90 + src/bufr/getbmiss.f | 49 + src/bufr/getlens.f | 83 + src/bufr/getntbe.f | 77 + src/bufr/gets1loc.f | 220 + src/bufr/gettagpr.f | 101 + src/bufr/gettbh.f | 95 + src/bufr/getvalnb.f | 140 + src/bufr/getwin.f | 128 + src/bufr/i4dy.f | 66 + src/bufr/ibfms.f | 57 + src/bufr/icbfms.f | 71 + src/bufr/ichkstr.f | 65 + src/bufr/icmpdx.f | 91 + src/bufr/icopysb.f | 48 + src/bufr/icvidx.c | 40 + src/bufr/idn30.f | 81 + src/bufr/idxmsg.f | 58 + src/bufr/ifbget.f | 85 + src/bufr/ifxy.f | 66 + src/bufr/igetdate.f | 60 + src/bufr/igetfxy.f | 79 + src/bufr/igetntbi.f | 66 + src/bufr/igetntbl.f | 59 + src/bufr/igetsc.f | 55 + src/bufr/igettdi.f | 69 + src/bufr/inctab.f | 81 + src/bufr/invcon.f | 107 + src/bufr/invmrg.f | 156 + src/bufr/invtag.f | 99 + src/bufr/invwin.f | 90 + src/bufr/iok2cpy.f | 97 + src/bufr/ipkm.f | 77 + src/bufr/ipks.f | 96 + src/bufr/ireadmg.f | 54 + src/bufr/ireadmm.f | 56 + src/bufr/ireadns.f | 51 + src/bufr/ireadsb.f | 44 + src/bufr/irev.F | 80 + src/bufr/ishrdx.f | 80 + src/bufr/isize.f | 51 + src/bufr/istdesc.f | 56 + src/bufr/iupb.f | 55 + src/bufr/iupbs01.f | 179 + src/bufr/iupbs3.f | 85 + src/bufr/iupm.f | 74 + src/bufr/iupvs01.f | 82 + src/bufr/jstchr.f | 68 + src/bufr/jstnum.f | 108 + src/bufr/lcmgdf.f | 79 + src/bufr/lmsg.f | 56 + src/bufr/lstjpb.f | 110 + src/bufr/makebufrlib.sh | 289 + src/bufr/makestab.f | 400 + src/bufr/maxout.f | 88 + src/bufr/mesgbc.f | 192 + src/bufr/mesgbf.f | 98 + src/bufr/minimg.f | 79 + src/bufr/mrginv.f | 66 + src/bufr/msgfull.f | 79 + src/bufr/msgini.f | 214 + src/bufr/msgupd.f | 143 + src/bufr/msgwrt.f | 307 + src/bufr/mtinfo.f | 62 + src/bufr/mvb.f | 79 + src/bufr/nemock.f | 89 + src/bufr/nemtab.f | 149 + src/bufr/nemtba.f | 81 + src/bufr/nemtbax.f | 92 + src/bufr/nemtbb.f | 129 + src/bufr/nemtbd.f | 224 + src/bufr/nenubd.f | 103 + src/bufr/nevn.f | 110 + src/bufr/newwin.f | 93 + src/bufr/nmsub.f | 77 + src/bufr/nmwrd.f | 52 + src/bufr/numbck.f | 91 + src/bufr/nummtb.c | 68 + src/bufr/numtab.f | 183 + src/bufr/numtbd.f | 118 + src/bufr/nvnwin.f | 109 + src/bufr/nwords.f | 63 + src/bufr/nxtwin.f | 96 + src/bufr/openbf.f | 318 + src/bufr/openbt.f | 73 + src/bufr/openmb.f | 111 + src/bufr/openmg.f | 100 + src/bufr/pad.f | 92 + src/bufr/padmsg.f | 63 + src/bufr/parstr.f | 98 + src/bufr/parusr.f | 197 + src/bufr/parutg.f | 277 + src/bufr/pkb.f | 87 + src/bufr/pkbs1.f | 116 + src/bufr/pkc.f | 118 + src/bufr/pkftbv.f | 50 + src/bufr/pktdd.f | 146 + src/bufr/pkvs01.f | 151 + src/bufr/posapx.f | 96 + src/bufr/rbytes.c | 62 + src/bufr/rcstpl.f | 187 + src/bufr/rdbfdx.f | 157 + src/bufr/rdcmps.f | 197 + src/bufr/rdmemm.f | 227 + src/bufr/rdmems.f | 165 + src/bufr/rdmgsb.f | 112 + src/bufr/rdmsgb.f | 103 + src/bufr/rdmsgw.f | 68 + src/bufr/rdmtbb.f | 130 + src/bufr/rdmtbd.f | 138 + src/bufr/rdtree.f | 137 + src/bufr/rdusdx.f | 273 + src/bufr/readdx.f | 147 + src/bufr/readerme.f | 230 + src/bufr/readlc.f | 193 + src/bufr/readmg.f | 184 + src/bufr/readmm.f | 83 + src/bufr/readmt.f | 256 + src/bufr/readns.f | 102 + src/bufr/reads3.f | 243 + src/bufr/readsb.f | 130 + src/bufr/restd.c | 139 + src/bufr/rewnbf.f | 180 + src/bufr/rjust.f | 54 + src/bufr/rsvfvm.f | 67 + src/bufr/rtrcpt.f | 95 + src/bufr/seqsdx.f | 253 + src/bufr/setblock.f | 47 + src/bufr/setbmiss.f | 48 + src/bufr/sntbbe.f | 161 + src/bufr/sntbde.f | 180 + src/bufr/status.f | 155 + src/bufr/stbfdx.f | 180 + src/bufr/stdmsg.f | 60 + src/bufr/stndrd.f | 293 + src/bufr/stntbi.f | 69 + src/bufr/stntbia.f | 95 + src/bufr/strcln.f | 47 + src/bufr/strcpt.f | 76 + src/bufr/string.f | 152 + src/bufr/strnum.f | 88 + src/bufr/strsuc.f | 95 + src/bufr/stseq.c | 407 + src/bufr/tabent.f | 184 + src/bufr/tabsub.f | 460 + src/bufr/trybump.f | 120 + src/bufr/ufbcnt.f | 86 + src/bufr/ufbcpy.f | 129 + src/bufr/ufbcup.f | 137 + src/bufr/ufbdmp.f | 290 + src/bufr/ufbevn.f | 290 + src/bufr/ufbget.f | 187 + src/bufr/ufbin3.f | 263 + src/bufr/ufbint.f | 454 + src/bufr/ufbinx.f | 168 + src/bufr/ufbmem.f | 249 + src/bufr/ufbmex.f | 202 + src/bufr/ufbmms.f | 109 + src/bufr/ufbmns.f | 107 + src/bufr/ufbovr.f | 191 + src/bufr/ufbpos.f | 143 + src/bufr/ufbqcd.f | 95 + src/bufr/ufbqcp.f | 79 + src/bufr/ufbrep.f | 296 + src/bufr/ufbrms.f | 154 + src/bufr/ufbrp.f | 145 + src/bufr/ufbrw.f | 218 + src/bufr/ufbseq.f | 386 + src/bufr/ufbsp.f | 141 + src/bufr/ufbstp.f | 244 + src/bufr/ufbtab.f | 564 ++ src/bufr/ufbtam.f | 283 + src/bufr/ufdump.f | 409 + src/bufr/upb.f | 69 + src/bufr/upbb.f | 82 + src/bufr/upc.f | 81 + src/bufr/upds3.f | 81 + src/bufr/upftbv.f | 100 + src/bufr/ups.f | 97 + src/bufr/uptdd.f | 115 + src/bufr/usrtpl.f | 250 + src/bufr/valx.f | 87 + src/bufr/wrcmps.f | 472 + src/bufr/wrdesc.c | 59 + src/bufr/wrdlen.F | 482 + src/bufr/wrdxtb.f | 182 + src/bufr/writcp.f | 51 + src/bufr/writdx.f | 88 + src/bufr/writlc.f | 222 + src/bufr/writsa.f | 180 + src/bufr/writsb.f | 85 + src/bufr/wrtree.f | 155 + src/bufr/wtstat.f | 121 + src/enkf/gridio_wrf.f90 | 57 +- src/gsi/.CMakeLists.txt.swp | Bin 0 -> 16384 bytes src/gsi/gsdcloudanalysis.F90 | 48 +- src/gsi/gsdcloudanalysis4gfs.F90 | 49 +- src/wrflib/CMakeLists.txt | 11 + src/wrflib/ext_ncd_get_dom_ti.code | 157 + src/wrflib/ext_ncd_get_var_td.code | 227 + src/wrflib/ext_ncd_get_var_ti.code | 174 + src/wrflib/ext_ncd_put_dom_ti.code | 164 + src/wrflib/ext_ncd_put_var_td.code | 233 + src/wrflib/ext_ncd_put_var_ti.code | 144 + src/wrflib/field_routines.F90 | 175 + src/wrflib/io_int_stubs.f90 | 157 + src/wrflib/model_data_order.inc | 8 + src/wrflib/module_driver_constants.F90 | 180 + src/wrflib/module_machine.F90 | 175 + src/wrflib/pack_utils.c | 390 + src/wrflib/streams.h | 16 + src/wrflib/transpose.code | 40 + src/wrflib/wrf_io.F90.orig | 3685 ++++++++ src/wrflib/wrf_io.f90 | 8169 +++++++++++++++++ src/wrflib/wrf_io_flags.h | 15 + src/wrflib/wrf_status_codes.h | 133 + ush/build.comgsi | 27 +- .../src/enspreproc_regional.fd/CMakeLists.txt | 4 +- 348 files changed, 68338 insertions(+), 112 deletions(-) create mode 100644 src/GSD/gsdcloud/ARPS_cldLib.f90 create mode 100644 src/GSD/gsdcloud/BackgroundCld.f90 create mode 100644 src/GSD/gsdcloud/BckgrndCC.f90 create mode 100644 src/GSD/gsdcloud/CMakeLists.txt create mode 100644 src/GSD/gsdcloud/PrecipMxr_radar.f90 create mode 100644 src/GSD/gsdcloud/PrecipType.f90 create mode 100644 src/GSD/gsdcloud/TempAdjust.f90 create mode 100644 src/GSD/gsdcloud/adaslib.f90 create mode 100644 src/GSD/gsdcloud/build_missing_REFcone.f90 create mode 100644 src/GSD/gsdcloud/cloudCover_NESDIS.f90 create mode 100644 src/GSD/gsdcloud/cloudCover_Surface.f90 create mode 100644 src/GSD/gsdcloud/cloudCover_radar.f90 create mode 100644 src/GSD/gsdcloud/cloudLWC.f90 create mode 100644 src/GSD/gsdcloud/cloudLayers.f90 create mode 100644 src/GSD/gsdcloud/cloudType.f90 create mode 100644 src/GSD/gsdcloud/cloud_saturation.f90 create mode 100755 src/GSD/gsdcloud/configure create mode 100755 src/GSD/gsdcloud/constants.f90 create mode 100644 src/GSD/gsdcloud/convert_lghtn2ref.f90 create mode 100644 src/GSD/gsdcloud/get_sfm_1d_gnl.f90 create mode 100644 src/GSD/gsdcloud/hydro_mxr_thompson.f90 create mode 100755 src/GSD/gsdcloud/kinds.f90 create mode 100644 src/GSD/gsdcloud/make.dependencies create mode 100644 src/GSD/gsdcloud/make.filelist create mode 100644 src/GSD/gsdcloud/map_ctp.f90 create mode 100644 src/GSD/gsdcloud/map_ctp_lar.f90 create mode 100644 src/GSD/gsdcloud/mthermo.f90 create mode 100644 src/GSD/gsdcloud/pbl_height.f90 create mode 100644 src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 create mode 100644 src/GSD/gsdcloud/radar_ref2tten.f90 create mode 100644 src/GSD/gsdcloud/read_Lightning_cld.f90 create mode 100644 src/GSD/gsdcloud/read_NESDIS.f90 create mode 100644 src/GSD/gsdcloud/read_Surface.f90 create mode 100644 src/GSD/gsdcloud/read_nasalarc_cld.f90 create mode 100644 src/GSD/gsdcloud/read_radar_ref.f90 create mode 100644 src/GSD/gsdcloud/smooth.f90 create mode 100644 src/GSD/gsdcloud/vinterp_radar_ref.f90 create mode 100755 src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 create mode 100755 src/GSD/gsdcloud4nmmb/BackgroundCld.f90 create mode 100755 src/GSD/gsdcloud4nmmb/BckgrndCC.f90 create mode 100755 src/GSD/gsdcloud4nmmb/CheckCld.f90 create mode 100755 src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 create mode 100755 src/GSD/gsdcloud4nmmb/PrecipType.f90 create mode 100755 src/GSD/gsdcloud4nmmb/TempAdjust.f90 create mode 100755 src/GSD/gsdcloud4nmmb/adaslib.f90 create mode 100755 src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloudLWC.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloudLayers.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloudType.f90 create mode 100755 src/GSD/gsdcloud4nmmb/cloud_saturation.f90 create mode 100755 src/GSD/gsdcloud4nmmb/constants.f90 create mode 100755 src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 create mode 100755 src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 create mode 100755 src/GSD/gsdcloud4nmmb/diff.sh create mode 100755 src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 create mode 100755 src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 create mode 100755 src/GSD/gsdcloud4nmmb/kinds.f90 create mode 100755 src/GSD/gsdcloud4nmmb/make.dependencies create mode 100755 src/GSD/gsdcloud4nmmb/make.filelist create mode 100755 src/GSD/gsdcloud4nmmb/makefile create mode 100755 src/GSD/gsdcloud4nmmb/map_ctp.f90 create mode 100644 src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 create mode 100755 src/GSD/gsdcloud4nmmb/mthermo.f90 create mode 100755 src/GSD/gsdcloud4nmmb/pbl_height.f90 create mode 100755 src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 create mode 100755 src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 create mode 100755 src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 create mode 100755 src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 create mode 100755 src/GSD/gsdcloud4nmmb/read_NESDIS.f90 create mode 100755 src/GSD/gsdcloud4nmmb/read_Surface.f90 create mode 100755 src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 create mode 100755 src/GSD/gsdcloud4nmmb/read_radar_ref.f90 create mode 100755 src/GSD/gsdcloud4nmmb/smooth.f90 create mode 100755 src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 create mode 100644 src/bufr/.gitrepo create mode 100644 src/bufr/CMakeLists.txt create mode 100755 src/bufr/README.libbufr create mode 100644 src/bufr/adn30.f create mode 100644 src/bufr/atrcpt.f create mode 100644 src/bufr/bfrini.f create mode 100644 src/bufr/blocks.f create mode 100644 src/bufr/bort.f create mode 100644 src/bufr/bort2.f create mode 100644 src/bufr/bort_exit.c create mode 100644 src/bufr/bufrlib.h create mode 100755 src/bufr/bufrlib0.PRM create mode 100644 src/bufr/bvers.f create mode 100644 src/bufr/cadn30.f create mode 100644 src/bufr/capit.f create mode 100644 src/bufr/ccbfl.c create mode 100644 src/bufr/chekstab.f create mode 100644 src/bufr/chrtrn.f create mode 100644 src/bufr/chrtrna.f create mode 100644 src/bufr/cktaba.f create mode 100644 src/bufr/closbf.f create mode 100644 src/bufr/closmg.f create mode 100644 src/bufr/cmpia.c create mode 100644 src/bufr/cmpmsg.f create mode 100644 src/bufr/cmsgini.f create mode 100644 src/bufr/cnved4.f create mode 100644 src/bufr/cobfl.c create mode 100644 src/bufr/conwin.f create mode 100644 src/bufr/copybf.f create mode 100644 src/bufr/copymg.f create mode 100644 src/bufr/copysb.f create mode 100644 src/bufr/cpbfdx.f create mode 100644 src/bufr/cpdxmm.f create mode 100644 src/bufr/cpymem.f create mode 100644 src/bufr/cpyupd.f create mode 100644 src/bufr/crbmg.c create mode 100644 src/bufr/cread.c create mode 100644 src/bufr/cwbmg.c create mode 100644 src/bufr/datebf.f create mode 100644 src/bufr/datelen.f create mode 100644 src/bufr/digit.f create mode 100644 src/bufr/drfini.f create mode 100644 src/bufr/drstpl.f create mode 100644 src/bufr/dumpbf.f create mode 100644 src/bufr/dxdump.f create mode 100644 src/bufr/dxinit.f create mode 100644 src/bufr/dxmini.f create mode 100644 src/bufr/elemdx.f create mode 100644 src/bufr/errwrt.f create mode 100644 src/bufr/getabdb.f create mode 100644 src/bufr/getbmiss.f create mode 100644 src/bufr/getlens.f create mode 100644 src/bufr/getntbe.f create mode 100644 src/bufr/gets1loc.f create mode 100644 src/bufr/gettagpr.f create mode 100644 src/bufr/gettbh.f create mode 100644 src/bufr/getvalnb.f create mode 100644 src/bufr/getwin.f create mode 100644 src/bufr/i4dy.f create mode 100644 src/bufr/ibfms.f create mode 100644 src/bufr/icbfms.f create mode 100644 src/bufr/ichkstr.f create mode 100644 src/bufr/icmpdx.f create mode 100644 src/bufr/icopysb.f create mode 100644 src/bufr/icvidx.c create mode 100644 src/bufr/idn30.f create mode 100644 src/bufr/idxmsg.f create mode 100644 src/bufr/ifbget.f create mode 100644 src/bufr/ifxy.f create mode 100644 src/bufr/igetdate.f create mode 100644 src/bufr/igetfxy.f create mode 100644 src/bufr/igetntbi.f create mode 100644 src/bufr/igetntbl.f create mode 100644 src/bufr/igetsc.f create mode 100644 src/bufr/igettdi.f create mode 100644 src/bufr/inctab.f create mode 100644 src/bufr/invcon.f create mode 100644 src/bufr/invmrg.f create mode 100644 src/bufr/invtag.f create mode 100644 src/bufr/invwin.f create mode 100644 src/bufr/iok2cpy.f create mode 100644 src/bufr/ipkm.f create mode 100644 src/bufr/ipks.f create mode 100644 src/bufr/ireadmg.f create mode 100644 src/bufr/ireadmm.f create mode 100644 src/bufr/ireadns.f create mode 100644 src/bufr/ireadsb.f create mode 100755 src/bufr/irev.F create mode 100644 src/bufr/ishrdx.f create mode 100644 src/bufr/isize.f create mode 100644 src/bufr/istdesc.f create mode 100644 src/bufr/iupb.f create mode 100644 src/bufr/iupbs01.f create mode 100644 src/bufr/iupbs3.f create mode 100644 src/bufr/iupm.f create mode 100644 src/bufr/iupvs01.f create mode 100644 src/bufr/jstchr.f create mode 100644 src/bufr/jstnum.f create mode 100644 src/bufr/lcmgdf.f create mode 100644 src/bufr/lmsg.f create mode 100644 src/bufr/lstjpb.f create mode 100755 src/bufr/makebufrlib.sh create mode 100644 src/bufr/makestab.f create mode 100644 src/bufr/maxout.f create mode 100644 src/bufr/mesgbc.f create mode 100644 src/bufr/mesgbf.f create mode 100644 src/bufr/minimg.f create mode 100644 src/bufr/mrginv.f create mode 100644 src/bufr/msgfull.f create mode 100644 src/bufr/msgini.f create mode 100644 src/bufr/msgupd.f create mode 100644 src/bufr/msgwrt.f create mode 100644 src/bufr/mtinfo.f create mode 100644 src/bufr/mvb.f create mode 100644 src/bufr/nemock.f create mode 100644 src/bufr/nemtab.f create mode 100644 src/bufr/nemtba.f create mode 100644 src/bufr/nemtbax.f create mode 100644 src/bufr/nemtbb.f create mode 100644 src/bufr/nemtbd.f create mode 100644 src/bufr/nenubd.f create mode 100644 src/bufr/nevn.f create mode 100644 src/bufr/newwin.f create mode 100644 src/bufr/nmsub.f create mode 100644 src/bufr/nmwrd.f create mode 100644 src/bufr/numbck.f create mode 100644 src/bufr/nummtb.c create mode 100644 src/bufr/numtab.f create mode 100644 src/bufr/numtbd.f create mode 100644 src/bufr/nvnwin.f create mode 100644 src/bufr/nwords.f create mode 100644 src/bufr/nxtwin.f create mode 100644 src/bufr/openbf.f create mode 100644 src/bufr/openbt.f create mode 100644 src/bufr/openmb.f create mode 100644 src/bufr/openmg.f create mode 100644 src/bufr/pad.f create mode 100644 src/bufr/padmsg.f create mode 100644 src/bufr/parstr.f create mode 100644 src/bufr/parusr.f create mode 100644 src/bufr/parutg.f create mode 100644 src/bufr/pkb.f create mode 100644 src/bufr/pkbs1.f create mode 100644 src/bufr/pkc.f create mode 100644 src/bufr/pkftbv.f create mode 100644 src/bufr/pktdd.f create mode 100644 src/bufr/pkvs01.f create mode 100644 src/bufr/posapx.f create mode 100644 src/bufr/rbytes.c create mode 100644 src/bufr/rcstpl.f create mode 100644 src/bufr/rdbfdx.f create mode 100644 src/bufr/rdcmps.f create mode 100644 src/bufr/rdmemm.f create mode 100644 src/bufr/rdmems.f create mode 100644 src/bufr/rdmgsb.f create mode 100644 src/bufr/rdmsgb.f create mode 100644 src/bufr/rdmsgw.f create mode 100644 src/bufr/rdmtbb.f create mode 100644 src/bufr/rdmtbd.f create mode 100644 src/bufr/rdtree.f create mode 100644 src/bufr/rdusdx.f create mode 100644 src/bufr/readdx.f create mode 100644 src/bufr/readerme.f create mode 100644 src/bufr/readlc.f create mode 100644 src/bufr/readmg.f create mode 100644 src/bufr/readmm.f create mode 100644 src/bufr/readmt.f create mode 100644 src/bufr/readns.f create mode 100644 src/bufr/reads3.f create mode 100644 src/bufr/readsb.f create mode 100644 src/bufr/restd.c create mode 100644 src/bufr/rewnbf.f create mode 100644 src/bufr/rjust.f create mode 100644 src/bufr/rsvfvm.f create mode 100644 src/bufr/rtrcpt.f create mode 100644 src/bufr/seqsdx.f create mode 100644 src/bufr/setblock.f create mode 100644 src/bufr/setbmiss.f create mode 100644 src/bufr/sntbbe.f create mode 100644 src/bufr/sntbde.f create mode 100644 src/bufr/status.f create mode 100644 src/bufr/stbfdx.f create mode 100644 src/bufr/stdmsg.f create mode 100644 src/bufr/stndrd.f create mode 100644 src/bufr/stntbi.f create mode 100644 src/bufr/stntbia.f create mode 100644 src/bufr/strcln.f create mode 100644 src/bufr/strcpt.f create mode 100644 src/bufr/string.f create mode 100644 src/bufr/strnum.f create mode 100644 src/bufr/strsuc.f create mode 100644 src/bufr/stseq.c create mode 100644 src/bufr/tabent.f create mode 100644 src/bufr/tabsub.f create mode 100644 src/bufr/trybump.f create mode 100644 src/bufr/ufbcnt.f create mode 100644 src/bufr/ufbcpy.f create mode 100644 src/bufr/ufbcup.f create mode 100644 src/bufr/ufbdmp.f create mode 100644 src/bufr/ufbevn.f create mode 100644 src/bufr/ufbget.f create mode 100644 src/bufr/ufbin3.f create mode 100644 src/bufr/ufbint.f create mode 100644 src/bufr/ufbinx.f create mode 100644 src/bufr/ufbmem.f create mode 100644 src/bufr/ufbmex.f create mode 100644 src/bufr/ufbmms.f create mode 100644 src/bufr/ufbmns.f create mode 100644 src/bufr/ufbovr.f create mode 100644 src/bufr/ufbpos.f create mode 100644 src/bufr/ufbqcd.f create mode 100644 src/bufr/ufbqcp.f create mode 100644 src/bufr/ufbrep.f create mode 100644 src/bufr/ufbrms.f create mode 100644 src/bufr/ufbrp.f create mode 100644 src/bufr/ufbrw.f create mode 100644 src/bufr/ufbseq.f create mode 100644 src/bufr/ufbsp.f create mode 100644 src/bufr/ufbstp.f create mode 100644 src/bufr/ufbtab.f create mode 100644 src/bufr/ufbtam.f create mode 100644 src/bufr/ufdump.f create mode 100644 src/bufr/upb.f create mode 100644 src/bufr/upbb.f create mode 100644 src/bufr/upc.f create mode 100644 src/bufr/upds3.f create mode 100644 src/bufr/upftbv.f create mode 100644 src/bufr/ups.f create mode 100644 src/bufr/uptdd.f create mode 100644 src/bufr/usrtpl.f create mode 100644 src/bufr/valx.f create mode 100644 src/bufr/wrcmps.f create mode 100644 src/bufr/wrdesc.c create mode 100755 src/bufr/wrdlen.F create mode 100644 src/bufr/wrdxtb.f create mode 100644 src/bufr/writcp.f create mode 100644 src/bufr/writdx.f create mode 100644 src/bufr/writlc.f create mode 100644 src/bufr/writsa.f create mode 100644 src/bufr/writsb.f create mode 100644 src/bufr/wrtree.f create mode 100644 src/bufr/wtstat.f create mode 100644 src/gsi/.CMakeLists.txt.swp create mode 100644 src/wrflib/CMakeLists.txt create mode 100644 src/wrflib/ext_ncd_get_dom_ti.code create mode 100644 src/wrflib/ext_ncd_get_var_td.code create mode 100644 src/wrflib/ext_ncd_get_var_ti.code create mode 100644 src/wrflib/ext_ncd_put_dom_ti.code create mode 100644 src/wrflib/ext_ncd_put_var_td.code create mode 100644 src/wrflib/ext_ncd_put_var_ti.code create mode 100644 src/wrflib/field_routines.F90 create mode 100755 src/wrflib/io_int_stubs.f90 create mode 100644 src/wrflib/model_data_order.inc create mode 100644 src/wrflib/module_driver_constants.F90 create mode 100644 src/wrflib/module_machine.F90 create mode 100644 src/wrflib/pack_utils.c create mode 100644 src/wrflib/streams.h create mode 100644 src/wrflib/transpose.code create mode 100644 src/wrflib/wrf_io.F90.orig create mode 100644 src/wrflib/wrf_io.f90 create mode 100644 src/wrflib/wrf_io_flags.h create mode 100644 src/wrflib/wrf_status_codes.h diff --git a/CMakeLists.txt b/CMakeLists.txt index bfeb9438b8..8c9bf8a28b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -185,11 +185,11 @@ project(GSI) find_package( LAPACK ) endif() # build the WRF I/O libraries - if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/libsrc/wrflib) - add_subdirectory(libsrc/wrflib) + if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/src/wrflib) + add_subdirectory(src/wrflib) else() - message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") - message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") + message("src/wrflib not pulled from git, looking for WRF dependencies locally") + message("src/wrflib not pulled from git, looking for WRF dependencies locally") find_package( WRF ) endif() @@ -230,12 +230,12 @@ project(GSI) find_package( IP ) if(BUILD_NCDIAG) - set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/libsrc/ncdiag/include") + set(NCDIAG_INCS "${PROJECT_BINARY_DIR}/src/ncdiag/include") add_subdirectory(src/ncdiag) set(NCDIAG_LIBRARIES ncdiag ) endif(BUILD_NCDIAG) if(BUILD_FV3GFS_NCIO) - set(FV3GFS_NCIO_INCS "${PROJECT_BINARY_DIR}/libsrc/fv3gfs_ncio/include") + set(FV3GFS_NCIO_INCS "${PROJECT_BINARY_DIR}/src/fv3gfs_ncio/include") add_subdirectory(src/fv3gfs_ncio) set(FV3GFS_NCIO_LIBRARIES fv3gfs_ncio ) endif(BUILD_FV3GFS_NCIO) @@ -255,9 +255,9 @@ project(GSI) find_package( IP ) if(BUILD_GSDCLOUD_ARW) - set(GSDCLOUD_DIR "${CMAKE_SOURCE_DIR}/libsrc/GSD/gsdcloud") + set(GSDCLOUD_DIR "${CMAKE_SOURCE_DIR}/src/GSD/gsdcloud") set(gsdcloud gsdcloud_arw) - add_subdirectory(libsrc/GSD/gsdcloud) + add_subdirectory(src/GSD/gsdcloud) set(GSDCLOUD_LIBRARY ${gsdcloud} ) else(BUILD_GSDCLOUD_ARW) set(GSDCLOUD_LIBRARY "") diff --git a/cmake/Modules/FindBUFR.cmake b/cmake/Modules/FindBUFR.cmake index 58527743bc..1f85768b16 100644 --- a/cmake/Modules/FindBUFR.cmake +++ b/cmake/Modules/FindBUFR.cmake @@ -31,17 +31,17 @@ if(NOT BUILD_BUFR ) endif() endif() if( NOT BUFR_LIBRARY ) # didn't find the library, so build it from source - message("Could not find BUFR library, so building from libsrc") + message("Could not find BUFR library, so building from src") if( NOT DEFINED ENV{BUFR_SRC} ) findSrc( "bufr" BUFR_VER BUFR_DIR ) else() - set( BUFR_DIR "$ENV{BUFR_SRC}/libsrc" CACHE STRING "BUFR Source Location") + set( BUFR_DIR "$ENV{BUFR_SRC}/src" CACHE STRING "BUFR Source Location") endif() set( libsuffix "_v${BUFR_VER}${debug_suffix}" ) set( BUFR_LIBRARY "${LIBRARY_OUTPUT_PATH}/libbufr${libsuffix}.a" CACHE STRING "BUFR Library" ) set( bufr "bufr${libsuffix}") set( BUILD_BUFR "ON" CACHE INTERNAL "Build the BUFR library") - add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/bufr) + add_subdirectory(${CMAKE_SOURCE_DIR}/src/bufr) set( BUFR_LIBRARY ${bufr} ) if( CORE_BUILT ) diff --git a/cmake/Modules/findHelpers.cmake b/cmake/Modules/findHelpers.cmake index 028957a0a6..e251175da9 100644 --- a/cmake/Modules/findHelpers.cmake +++ b/cmake/Modules/findHelpers.cmake @@ -1,8 +1,8 @@ function (findSrc varName version varDir ) - if(EXISTS ${CMAKE_SOURCE_DIR}/libsrc/${varName}) - message("setting source for ${varName} to be in libsrc") - set( ${varDir} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" PARENT_SCOPE) - set( ${varCacheName} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" CACHE STRING "" FORCE ) + if(EXISTS ${CMAKE_SOURCE_DIR}/src/${varName}) + message("setting source for ${varName} to be in src") + set( ${varDir} "${CMAKE_SOURCE_DIR}/src/${varName}" PARENT_SCOPE) + set( ${varCacheName} "${CMAKE_SOURCE_DIR}/src/${varName}" CACHE STRING "" FORCE ) else() set(searchName ${varName}_v${${version}}) message("searching for source for ${searchName} in ${CRTM_BASE}") diff --git a/cmake/Modules/platforms/Generic.cmake b/cmake/Modules/platforms/Generic.cmake index 1e06239a4e..1cf3613ce2 100644 --- a/cmake/Modules/platforms/Generic.cmake +++ b/cmake/Modules/platforms/Generic.cmake @@ -11,4 +11,15 @@ macro (setGeneric) set(GSI_Intel_Platform_FLAGS "-DPOUND_FOR_STRINGIFY -O3 -fp-model source -assume byterecl -convert big_endian -g -traceback -D_REAL8_ ${OpenMP_Fortran_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}" CACHE INTERNAL "GSI Fortran Flags") set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") + message("setting values for corelibs") + set(BUILD_BUFR "ON" CACHE INTERNAL "Build the BUFR library" ) + + set(BUILD_BACIO "OFF" CACHE INTERNAL "Build the BACIO library" ) + set(BUILD_SFCIO "OFF" CACHE INTERNAL "Build the SFCIO library" ) + set(BUILD_SIGIO "OFF" CACHE INTERNAL "Build the SIGIO library" ) + set(BUILD_NEMSIO "OFF" CACHE INTERNAL "Build the NEMSIO library" ) + set(BUILD_SP "OFF" CACHE INTERNAL "Build the SP library" ) + set(BUILD_CRTM "OFF" CACHE INTERNAL "Build the CRTM library" ) + set(BUILD_W3EMC "OFF" CACHE INTERNAL "Build the EMC library" ) + set(BUILD_NCO "OFF" CACHE INTERNAL "Build the NCO library" ) endmacro() diff --git a/src/GSD/gsdcloud/ARPS_cldLib.f90 b/src/GSD/gsdcloud/ARPS_cldLib.f90 new file mode 100644 index 0000000000..b1d6d0d1fe --- /dev/null +++ b/src/GSD/gsdcloud/ARPS_cldLib.f90 @@ -0,0 +1,1405 @@ +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ARPS_cldLib +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: +! +! ABSTRACT: +! This file include a collection of subroutines that are related to +! cloud analysis from ARPS cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_STABILITY ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & + ,dte_dz_1d) +! +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns stability at a given level given +! 1D temperature and pressure array inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on LAPS cloud analysis code of 07/95 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),INTENT(IN) :: nz ! number of vertical model levels + REAL(r_single) ,INTENT(IN) :: t_1d(nz) ! temperature (degree Kelvin) profile + REAL(r_single) ,INTENT(IN) :: zs_1d(nz) ! heights (m MSL) of each level + REAL(r_single) ,INTENT(IN) :: p_mb_1d(nz)! pressure (mb) at each level + INTEGER(i_kind),INTENT(IN) :: kbtm,ktop ! indices of the bottom and top cloud layer +! +! OUTPUT: + REAL(r_single) ,INTENT(out):: dte_dz_1d(nz) ! stability array +! +! LOCAL: + REAL(r_single) :: thetae_1d(nz) ! (equivalent) potential temperature. +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: k,km1,kp1,klow,khigh + REAL(r_single) :: os_fast +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Calculate Stability +! +!----------------------------------------------------------------------- +! + klow = MAX(kbtm-1,1) + khigh = MIN(ktop+1,nz-1) + + DO k = klow,khigh + thetae_1d(k) = os_fast(t_1d(k), p_mb_1d(k)) + END DO ! k + + dte_dz_1d=0._r_kind + + DO k = kbtm,ktop + km1 = MAX(k-1,1) + kp1 = MIN(k+1,nz-1) + + IF( (zs_1d(kp1) - zs_1d(km1)) <= 0._r_kind) THEN + write(6,*) 'GNRLCLD_mpi, get_stability: Error in get_stability ' + write(6,*) 'GNRLCLD_mpi, get_stability: k,kp1,km1 = ',k,kp1,km1 + write(6,*) 'GNRLCLD_mpi, get_stability: zs_1d(kp1),zs_1d(km1)= ',zs_1d(kp1),zs_1d(km1), & + (zs_1d(kp1) - zs_1d(km1)) + call STOP2(114) + ELSE + dte_dz_1d(k) = (thetae_1d(kp1) - thetae_1d(km1)) & + / (zs_1d(kp1) - zs_1d(km1)) + END IF + END DO ! k + + RETURN +END SUBROUTINE get_stability + + +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION OS_FAST ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION os_fast(tk,p) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! THIS FUNCTION RETURNS THE EQUIVALENT POTENTIAL TEMPERATURE OS +! (K) FOR A PARCEL OF AIR SATURATED AT TEMPERATURE T (K) +! AND PRESSURE P (MILLIBARS). +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (BAKER,SCHLATTER) +! 05/17/1982 +! +! +! MODIFICATION HISTORY: +! 05/11/96 (Jian Zhang) +! Modified for ADAS grid. Add document stuff. +! +!----------------------------------------------------------------------- +! +! Variables declaration +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single) ,INTENT(IN) :: tk ! temperature in kelvin + REAL(r_single) ,INTENT(IN) :: p ! pressure in mb +! +! OUTPUT: + REAL(r_single) :: os_fast ! equivalent potential temperature +! +! LOCAL: + REAL(r_kind) :: b ! empirical const. approx.= latent heat of + ! vaporiz'n for water devided by the specific + ! heat at const. pressure for dry air. + DATA b/2.6518986_r_kind/ + + REAL(r_kind) :: tc,x,w + REAL(r_kind) :: eslo +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + tc = tk - 273.15_r_kind +! +!----------------------------------------------------------------------- +! +! From W routine +! +!----------------------------------------------------------------------- +! + x= eslo(tc) + w= 622._r_kind*x/(p-x) + + os_fast= tk*((1000._r_kind/p)**.286_r_kind)*(EXP(b*w/tk)) + + RETURN + END FUNCTION os_fast + + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_CLOUDTYPE ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & + ,itype,c2_type) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns cloud type at a given point given +! temperature and stability inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 05/1995 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single),INTENT(IN) :: temp_k ! temperature + REAL(r_single),INTENT(IN) :: dte_dz ! stability factor + REAL(r_single),INTENT(IN) :: cbase_m ! height at cloud base level + REAL(r_single),INTENT(IN) :: ctop_m ! height at cloud top level +! +! OUTPUT: + INTEGER(i_kind),INTENT(out):: itype ! cloud type index + CHARACTER (LEN=2) :: c2_type +! +! LOCAL: + CHARACTER (LEN=2) :: c2_cldtyps(10) + + DATA c2_cldtyps /'St','Sc','Cu','Ns','Ac' & + ,'As','Cs','Ci','Cc','Cb'/ +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_kind) :: depth_m,temp_c +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + temp_c = temp_k - 273.15_r_kind + depth_m = ctop_m - cbase_m +! +!----------------------------------------------------------------------- +! +! Go from Stability to Cloud Type +! +!----------------------------------------------------------------------- +! + IF ( temp_c >= -10._r_kind) THEN + IF (dte_dz >= +.001_r_kind) THEN + itype = 1 ! St + ELSE IF (dte_dz < +.001_r_kind .AND. dte_dz >= -.001_r_kind) THEN + itype = 2 ! Sc + ELSE IF (dte_dz < -.001_r_kind .AND. dte_dz >= -.005_r_kind) THEN + itype = 3 ! Cu + ELSE ! dte_dz .lt. -.005 + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE ! depth < 5km + itype = 3 ! Cu + END IF + END IF + + ELSE IF (temp_c < -10._r_kind .AND. temp_c >= -20._r_kind) THEN + + IF (dte_dz < 0._r_kind) THEN + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE + itype = 5 ! Ac + END IF + ELSE + itype = 6 ! As + END IF + + ELSE ! temp_c.lt.-20. + + IF (dte_dz >= +.0005_r_kind) THEN + itype = 7 ! Cs + ELSE IF (dte_dz < +.0005_r_kind .AND. dte_dz >= -.0005_r_kind) THEN + itype = 8 ! Ci + ELSE ! dte_dz .lt. -.0005 + itype = 9 ! Cc + END IF + + IF(depth_m > 5000 .AND. dte_dz < -.0000_r_kind) THEN + itype = 10 ! Cb + END IF + + END IF + + c2_type = c2_cldtyps(itype) + + RETURN +END SUBROUTINE get_cloudtype + +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nz ! number of model vertical levels + REAL(r_single),intent(in) :: zs_1d(nz) ! physical height (m) at each scalar level + REAL(r_single),intent(in) :: p_mb_1d(nz)! pressure (mb) at each level + REAL(r_single),intent(in) :: t_1d(nz) ! temperature (K) at each level + + REAL(r_single),intent(in) :: zcb ! cloud base height (m) + REAL(r_single),intent(in) :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL(r_single),intent(out) :: ql(nz) ! liquid water content (g/kg) + REAL(r_single),intent(out) :: qi(nz) ! ice water content (g/kg) + REAL(r_single),intent(out) :: cldt(nz) +! +! LOCAL: + REAL(r_single) :: calw(200) + REAL(r_single) :: cali(200) + REAL(r_single) :: catk(200) + REAL(r_single) :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_single) :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL(r_single) :: c,a1,b1,c1,a2,b2,c2 + REAL(r_single) :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL(r_single) :: arg,fraclw,tlwc + REAL(r_single) :: temp,press,zbase,alw,zht,ht,y + REAL(r_single) :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER(i_kind):: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL(r_single) :: zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0_r_single + cali(i)=0.0_r_single + END DO +! if(i_prt.le.20) then +! i_prt=i_prt+1 +! l_prt=.true. +! else +! l_prt=.false. +! endif +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0_r_single ! m + rv=461.5_r_single ! J/deg/kg + rair=287.04_r_single ! J/deg/kg + grav=9.81_r_single ! m/s2 + cp=1004._r_single ! J/deg/kg + rlvo=2.5003E+6_r_single ! J/kg + rlso=2.8339E+6_r_single ! J/kg + dlvdt=-2.3693E+3_r_single ! J/kg/K + eso=610.78_r_single ! pa + c=0.01_r_single + a1=8.4897_r_single + b1=-13.2191_r_single + c1=4.7295_r_single + a2=10.357_r_single + b2=-28.2416_r_single + c2=8.8846_r_single +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2._r_single + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0_r_single + zbase = zcb + nlevel = ((zctop-zcb)/100.0_r_single)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0_r_single + calw(1)= 0.0_r_single + cali(1)= 0.0_r_single + catk(1)= temp + entr(1)= 1.0_r_single + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622_r_single*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0_r_single+0.621_r_single*es*rl/(press*rair*temp))/ & + (cp+0.621_r_single*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622_r_single*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001_r_single +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032_r_single) THEN + y = -11.0_r_single*ht+1.0_r_single ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177_r_single) THEN + y = -1.4_r_single*ht+0.6915_r_single ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726_r_single) THEN + y = -0.356_r_single*ht+0.505_r_single ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5_r_single) THEN + y = -0.0608_r_single*ht+0.2912_r_single ! y(ht=1.5) = 0.2 + ELSE + y = 0.20_r_single + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15_r_single) THEN + IF(temp > 248.15_r_single) THEN + fraclw=0.05*(temp-248.15_r_single) + ELSE + fraclw=0.0_r_single + END IF + ELSE + fraclw=1.0_r_single + END IF + + tlwc=1000._r_single*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1._r_single-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0_r_single + qi(ip)=0.0_r_single + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (calw(j)-calw(j-1))*0.01_r_single+calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (cali(j)-cali(j-1))*0.01_r_single+cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100._r_single)* & + (catk(j)-catk(j-1))*0.01_r_single & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100._r_single)* & + (entr(j)-entr(j-1))*0.01_r_single & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! + RETURN +END SUBROUTINE get_sfm_1d + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE PCP_TYPE_3D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns 3D cloud and precipitation type field. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/1996 Based on the LAPS cloud analysis code developed by +! Steve Albers. +! +! This program modifies the most significant 4 bits of the integer +! array by inserting multiples of 16. +! +! MODIFICATION HISTORY: +! +! 05/16/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! 01/20/98 (J. Zhang) +! Fixed a bug that no precip. type was assigned for a +! grid point at the top of the radar echo with Tw +! falling in the range of 0 to 1.3 degree C. +! 01/21/98 (J. Zhang) +! Fixed a bug that does the freezing/refreezing test +! on ice precipitates. +! 02/17/98 (J. Zhang) +! Change the hail diagnose procedure. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind), intent(in) :: nx,ny,nz ! Model grid size + REAL(r_single), intent(in) :: temp_3d(nx,ny,nz) ! temperature (K) + REAL(r_single), intent(in) :: rh_3d(nx,ny,nz) ! relative humudity + REAL(r_single), intent(in) :: p_pa_3d(nx,ny,nz) ! pressure (Pascal) + REAL(r_kind), intent(in) :: radar_3d(nx,ny,nz) ! radar refl. (dBZ) +! +! OUTPUT: + INTEGER(i_kind), intent(out) :: istatus + INTEGER(i_kind), intent(out) :: cldpcp_type_3d(nx,ny,nz)! cld/precip type + LOGICAL :: l_mask(nx,ny) ! "Potential" Precip Type +! +! LOCAL functions: + REAL(r_kind) :: wb_melting_thres ! define melting temp. thresh. + REAL(r_kind) :: tw ! for wet-bulb temp calcl'n +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: itype ! cld/precip type index + INTEGER(i_kind) :: i,j,k,k_upper + REAL(r_kind) :: t_c,td_c,t_wb_c,temp_lower_c,temp_upper_c,tbar_c & + ,p_mb,thickns,frac_below_zero + INTEGER(i_kind) :: iprecip_type,iprecip_type_last,iflag_melt & + ,iflag_refreez + REAL(r_kind) :: zero_c,rlayer_refreez_max,rlayer_refreez + INTEGER(i_kind) :: n_zr,n_sl,n_last + REAL(r_kind) :: tmelt_c,x +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +!----------------------------------------------------------------------- +! + return + istatus=0 + wb_melting_thres = 1.3 ! Units are C +! +!----------------------------------------------------------------------- +! +! Stuff precip type into cloud type array +! 0 - No Precip +! 1 - Rain +! 2 - Snow +! 3 - Freezing Rain +! 4 - Sleet +! 5 - Hail +! +!----------------------------------------------------------------------- +! + zero_c = 273.15_r_kind + rlayer_refreez_max = 0.0_r_kind + + n_zr = 0 + n_sl = 0 + n_last = 0 + + DO j = 1,ny-1 + DO i = 1,nx-1 + + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + iprecip_type_last = 0 + + DO k = nz-1,1,-1 + + IF(radar_3d(i,j,k) >= 0._r_kind.OR. l_mask(i,j)) THEN +! +!----------------------------------------------------------------------- +! +! Set refreezing flag +! +!----------------------------------------------------------------------- +! + t_c = temp_3d(i,j,k) - zero_c +! compute dew point depression. +! td_c = dwpt(t_c,rh_3d(i,j,k)) + x = 1._r_kind-0.01_r_kind*rh_3d(i,j,k) + td_c =t_c-(14.55_r_kind+0.114_r_kind*t_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_c)*x**14 + + p_mb = 0.01_r_kind*p_pa_3d(i,j,k) + + tmelt_c = wb_melting_thres + t_wb_c = tw(t_c,td_c,p_mb) + + IF(t_wb_c < 0._r_kind) THEN + IF(iflag_melt == 1) THEN +! +!----------------------------------------------------------------------- +! +! Integrate below freezing temperature times column thickness +! - ONLY for portion of layer below freezing +! +!----------------------------------------------------------------------- +! + temp_lower_c = t_wb_c + k_upper = MIN(k+1,nz-1) +! +!----------------------------------------------------------------------- +! +! For simplicity and efficiency, the assumption is here made that +! the wet bulb depression is constant throughout the level. +! +!----------------------------------------------------------------------- +! + temp_upper_c = t_wb_c + ( temp_3d(i,j,k_upper) & + - temp_3d(i,j,k)) + IF(temp_upper_c <= 0._r_kind) THEN + frac_below_zero = 1.0_r_kind + tbar_c = 0.5_r_kind * (temp_lower_c + temp_upper_c) + + ELSE ! Layer straddles the freezing level + frac_below_zero = temp_lower_c & + / (temp_lower_c - temp_upper_c) + tbar_c = 0.5_r_kind * temp_lower_c + + END IF + + thickns = p_pa_3d(i,j,k_upper) - p_pa_3d(i,j,k) + rlayer_refreez = rlayer_refreez & + + ABS(tbar_c * thickns * frac_below_zero) + + IF(rlayer_refreez >= 25000._r_kind) THEN + iflag_refreez = 1 + END IF + + rlayer_refreez_max = & + MAX(rlayer_refreez_max,rlayer_refreez) + + END IF ! iflag_melt = 1 + + ELSE ! Temp > 0C + iflag_refreez = 0 + rlayer_refreez = 0.0 + + END IF ! T < 0.0c, Temp is below freezing +! +!----------------------------------------------------------------------- +! +! Set melting flag +! +!----------------------------------------------------------------------- +! + IF(t_wb_c >= tmelt_c) THEN + iflag_melt = 1 + END IF + + IF(t_wb_c >= tmelt_c) THEN ! Melted to Rain + iprecip_type = 1 + + ELSE ! Check if below zero_c (Refrozen Precip or Snow) + IF(t_wb_c < 0.0_r_kind) THEN + IF(iflag_melt == 1) THEN + IF(iprecip_type_last == 1 .OR.iprecip_type_last == 3) THEN + ! test if rain or zr freeze + IF(iflag_refreez == 0) THEN ! Freezing Rain + n_zr = n_zr + 1 + IF(n_zr < 30) THEN +! WRITE(6,5)i,j,k,t_wb_c,temp_3d(i,j,k) & +! ,rh_3d(i,j,k) + 5 FORMAT('zr',3I3,2F8.2,f8.1) + END IF + iprecip_type = 3 + + ELSE ! (iflag_refreez = 1) ! Sleet + n_sl = n_sl + 1 + iprecip_type = 4 + END IF ! iflag_refreez .eq. 0 + ELSE + iprecip_type = iprecip_type_last ! Unchanged + n_last = n_last + 1 + IF(n_last < 5) THEN +! WRITE(6,*)'Unchanged Precip',i,j,k,t_wb_c + END IF + END IF ! liquid precip. at upper level? + + ELSE ! iflag_melt =0 ! Snow + iprecip_type = 2 + + END IF ! iflag_melt = 1? + ELSE ! t_wb_c >= 0c, and t_wb_c < tmelt_c + + IF (iprecip_type_last == 0) THEN ! 1/20/98 + iprecip_type = 1 ! rain:at echo top and 0= tmelt_c + + ELSE ! radar_3d < 0dBZ; No Radar Echo + iprecip_type = 0 + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + END IF ! radar_3d(i,j,k).ge.0. .or. l_mask(i,j); Radar Echo? +! +!----------------------------------------------------------------------- +! +! Insert most sig 4 bits into array +! +!----------------------------------------------------------------------- +! + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + + iprecip_type_last = iprecip_type + + END DO ! k + END DO ! j + END DO ! i + + DO j = 1,ny-1 + DO i = 1,nx-1 + DO k = 1,nz-1 + IF(radar_3d(i,j,k) >= 50._r_kind) THEN + iprecip_type = 5 + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + END IF + END DO ! k + END DO ! j + END DO ! i + + istatus=1 + + RETURN +END SUBROUTINE pcp_type_3d + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SLWC1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine calls a subroutine "lwc_rep" which calculates +! the adiabatic liquid water content. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/13/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: iflag_slwc ! indicator for LWC scheme option + INTEGER(i_kind),intent(in) :: nk ! number of model vertical levels + REAL(r_single),intent(in) :: t_1d(nk) ! temperature (k) in one model column + REAL(r_single),intent(in) :: zs_1d(nk) ! heights (m) at grd pts in one model column + REAL(r_single),intent(in) :: p_pa_1d(nk) ! pressure (pa) in one model column + REAL(r_single),intent(in) :: cbase_m,ctop_m ! heights (m) of cloud base and top levels + INTEGER(i_kind),intent(in) :: kbase,ktop ! vertical index of cloud base and top levels +! +! OUTPUT: + REAL(r_single),intent(out) :: slwc_1d(nk) ! estimated adiabatic liquid water +! +! LOCAL: + INTEGER(i_kind) :: i_status1,i_status2 ! flag for subroutine calling +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind):: k + REAL(r_single) :: p_low,p_high,cbase_pa,cbase_k,ctop_k,frac_k & + ,grid_top_pa,grid_top_k + REAL(r_single) :: fraction,thickness,dlog_space + REAL(r_single) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize +! +!----------------------------------------------------------------------- +! + DO k = 1,nk + slwc_1d(k) = 0.0_r_single + END DO + + IF(ctop_m > cbase_m) THEN +! +!----------------------------------------------------------------------- +! +! Determine Lowest and Highest Grid Points within the cloud +! +!----------------------------------------------------------------------- +! + IF(ktop >= kbase .AND. kbase >= 2) THEN +! +!----------------------------------------------------------------------- +! +! Get cloud base pressure and temperature +! +!----------------------------------------------------------------------- +! + cbase_pa = -999._r_single ! Default value is off the grid + DO k = 1,nk-2 + IF(zs_1d(k+1) > cbase_m .AND. zs_1d(k) <= cbase_m) THEN + thickness = zs_1d(k+1) - zs_1d(k) + fraction = (cbase_m - zs_1d(k))/thickness + p_low = p_pa_1d(k) + p_high = p_pa_1d(k+1) + dlog_space = LOG(p_high/p_low) + cbase_pa = p_low * EXP(dlog_space*fraction) + END IF + END DO ! k + + frac_k=(cbase_m-zs_1d(kbase-1))/(zs_1d(kbase)-zs_1d(kbase-1)) + IF(frac_k /= fraction) & + PRINT*,' **GET_SLWC1D** frac=',fraction,' frac_k=',frac_k + + cbase_k = t_1d(kbase-1)*(1.0_r_single-frac_k) + t_1d(kbase)*frac_k +! +!----------------------------------------------------------------------- +! +! Get cloud top temperature +! +!----------------------------------------------------------------------- +! + frac_k = (ctop_m-zs_1d(ktop-1)) / (zs_1d(ktop)-zs_1d(ktop-1)) + ctop_k = t_1d(ktop-1)*(1.0_r_single - frac_k) + t_1d(ktop) * frac_k +! +!----------------------------------------------------------------------- +! +! Calculate SLWC at each vertical grid point. For each level +! we use an assumed cloud extending from the actual cloud base +! to the height of the grid point in question. +! +!----------------------------------------------------------------------- +! + DO k=kbase,ktop + grid_top_pa = p_pa_1d(k) + grid_top_k = t_1d(k) + + CALL slwc_revb(cbase_pa,cbase_k & + ,grid_top_pa,grid_top_k,ctop_k & + ,adiabatic_lwc,adjusted_lwc,adjusted_slwc & + ,i_status1,i_status2) +! + IF(i_status2 == 1) THEN + IF(iflag_slwc == 1) THEN + slwc_1d(k) = adiabatic_lwc + ELSE IF(iflag_slwc == 2) THEN + slwc_1d(k) = adjusted_lwc + ELSE IF(iflag_slwc == 3) THEN + slwc_1d(k) = adjusted_slwc + END IF + ELSE + WRITE(6,*)' Error Detected in SLWC' + END IF + END DO ! k + END IF ! ktop > kbase & kbase > 2, thick enough cloud exists + END IF ! ctop_m > cbase_m, cloud exists + + RETURN +END SUBROUTINE get_slwc1d + +SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & + adiabatic_lwc,adjusted_lwc,adjusted_slwc, & + i_status1,i_status2) +! +!.......................HISTORY............................. +! +! WRITTEN: CA. 1982 BY W. A. COOPER IN HP FORTRAN 4 +! +!....... CALCULATES TEMPERATURE T AND LIQUID WATER CONTENT FROM +!.. CLOUD BASE PRESSURE P0 AND TEMPERATURE T0, FOR ADIABATIC +!.. ASCENT TO THE PRESSURE P. +!.. -> INPUT: CLOUD BASE PRESSURE P0 AND TEMPERATURE T0 +!.. PRESSURE AT OBSERVATION LEVEL P +!.. -> OUTPUT: "ADIABATIC" TEMPERATURE T AND LIQUID WATER CONTENT +! +! MODIFIED: November 1989 by Paul Lawson for LAPS/WISP. Routine +! now calculates adiabatic liquid water content +! (ADIABATIC_LWC) using cloud base pressure and grid-top +! temperature and pressure. Also calculated are ADJUSTED_LWC, +! which adjusts ADIABATIC_LWC using an empirical cloud +! water depletion algorithm, and ADJUSTED_SLWC, which is +! ADIABATIC_LWC in regions where T < 0 C adjusted +! using an empirical algorithm by Marcia Politovich. +! +! Subroutine is now hardwired for stratiform cloud only. +! Can be modified to include Cu with input from LAPS main. +! +! revb: ca 12/89 Calculate adiabatic lwc by going from cloud +! base to LAPS grid level instead to cloud top, thus +! helping to better calculate in layer clouds. +! Add TG (grid temperature) to calcualtion. +! +! revc: 2/27/90 Correct error in code. Zero-out slwc when grid +! temperature (GT) > 0. +! +! J.Z.: 4/7/97 Correct error in code +! Grid temperature should be TG, not GT. +! +! +! OUTPUTS: ADIABATIC_LWC +! ADJUSTED_LWC +! ADJUSTED_SLWC +! I_STATUS1 - 1 when -20 < cld_top_temp < 0 for Stratus +! 0 Otherwise +! I_STATUS2 - 1 when valid input data provided from main +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE + + real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k + real(r_single), intent(out) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc + INTEGER(i_kind),intent(out) :: i_status1,i_status2 + + real(r_kind) :: eps,cpd,cw,rd,alhv + DATA eps/0.622_r_kind/,cpd/1.0042E3_r_kind/,cw/4.218E3_r_kind/,rd/287.05_r_kind/,alhv/2.501E6_r_kind/ + INTEGER(i_kind) :: cty,i + real(r_kind) :: p0,p,t0,tg,ctt,tk,e,r,cpt,t1,thetaq,rv,t,tw + real(r_kind) :: vapor +! +! + i_status1=1 + i_status2=1 +! 2 Print *,'ENTER: P-BASE(mb), T-BASE(C), P-TOP, T-TOP, CLD TYPE' +! READ(5,*) P0, T0, P, CTT, CTY +! If(CTY.ne.0.and.CTY.ne.1) Go to 2 +! +! Hardwire cloud type (CTY) for stratus for now +! + cty=0 +! +!.....Convert Pa to mb and Kelvin to Celcius +! + p0 = cb_pa/100._r_kind + p = gt_pa/100._r_kind + t0 = cb_k - 273.15_r_kind + tg = gt_k - 273.15_r_kind + ctt= ct_k - 273.15_r_kind +! Print *, 'CTT in Sub = ', CTT +! +! Check for valid input data... +! + IF(p0 > 1013._r_kind.OR.p0 < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(t0 > 50._r_kind.OR.t0 < -70._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(p > 1013._r_kind.OR.p < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! Set I_STATUS1 = F if 0 < cld top < -20 C (for stratus). +! + IF(tg >= 0._r_kind.OR.ctt < -20._r_kind) i_status1=0 +! + tk=t0+273.15_r_kind + e=vapor(t0) + r=eps*e/(p0-e) + cpt=cpd+r*cw + thetaq=tk*(1000._r_kind/(p0-e))**(rd/cpt)*EXP(alhv*r/(cpt*tk)) +! 1ST APPROX + t1=tk + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) +! SUCCESSIVE APPROXIMATIONS + DO i=1,10 + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=(thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) & + +t1)/2._r_kind + t=t1-273.15_r_kind +! Print *, P0,T0,P,T,E,RV,THETAQ + END DO +! GET LWC + e=vapor(t) + rv=eps*e/(p-e) + tw=r-rv + adiabatic_lwc=tw*p*28.9644_r_kind/(8.314E7_r_kind*t1)*1.e9_r_kind + IF(adiabatic_lwc < 0._r_kind) adiabatic_lwc=0._r_kind +! Print *, 'Adiabtic LWC = ', ADIABATIC_LWC + IF(tg >= 0._r_kind) THEN +! + adjusted_slwc=0._r_kind ! Added 2/27/90 +! + + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + END IF + ELSE + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + END IF + END IF +! Print *,'Adjusted LWC = ', ADJUSTED_LWC +! Print *,'Adjusted SLWC = ', ADJUSTED_SLWC +END SUBROUTINE slwc_revb + +! FUNCTION TO CALCULATE VAPOR PRESSURE: +! + + FUNCTION vapor(tfp) +! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF +! LESS THAN 0, ASSUMED TO BE FROST POINT. +! ROUTINE CODES GOFF-GRATCH FORMULA + use kinds, only: i_kind,r_kind + IMPLICIT NONE + + real(r_kind), intent(in) :: tfp + real(r_kind) :: vapor + +! + real(r_kind) :: tvap, e + + tvap=273.16_r_kind+tfp + IF(tfp > 0.) GO TO 1 +! THIS IS ICE SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-9.09718_r_kind*(273.16_r_kind/tvap-1._r_kind)- & + 3.56654_r_kind*LOG10(273.16_r_kind/tvap) & + +0.876793_r_kind*(1.-tvap/273.16_r_kind) + vapor=6.1071_r_kind*10._r_kind**e + RETURN + 1 CONTINUE +! THIS IS WATER SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-7.90298_r_kind*(373.16_r_kind/tvap-1._r_kind)+ & + 5.02808_r_kind*LOG10(373.16_r_kind/tvap) & + -1.3816E-7_r_kind*(10._r_kind**(11.344_r_kind*& + (1._r_kind-tvap/373.16_r_kind))-1._r_kind) & + +8.1328E-3_r_kind*(10._r_kind**(3.49149_r_kind& + *(1-373.16_r_kind/tvap))-1) + vapor=1013.246_r_kind*10._r_kind**e + RETURN + END FUNCTION vapor diff --git a/src/GSD/gsdcloud/BackgroundCld.f90 b/src/GSD/gsdcloud/BackgroundCld.f90 new file mode 100644 index 0000000000..f72a1b00bf --- /dev/null +++ b/src/GSD/gsdcloud/BackgroundCld.f90 @@ -0,0 +1,315 @@ +SUBROUTINE BackgroundCldgfs(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BackgroundCld Ingest gfs background fields for cloud analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine reads in background hydrometeor fields for cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2010-04-26 Hu delete the module gridmod and guess_grids. +! transfer information subroutine dummy variables +! +! +! input argument list: +! mype - processor ID +! lon2 - no. of lons on subdomain (buffer points on ends) +! lat2 - no. of lats on subdomain (buffer points on ends) +! nsig - no. of vertical levels +! tbk - 3D background potential temperature (K) +! psbk - 2D background surface pressure (hPa) +! q - 3D moisture (water vapor mixing ratio kg/kg) +! pbk - 3D background pressure (hPa) +! +! output argument list: +! hbk - 3D height above the ground (not the sea level) +!!!! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + use constants, only: rd_over_cp, h1000 + use constants, only: rd, grav, half, rad2deg + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: lon2 + integer(i_kind),intent(in):: lat2 + integer(i_kind),intent(in):: nsig + +! background +! +! read in from WRF +! + real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature + real(r_single),intent(in) :: psbk(lon2,lat2) ! surface pressure + real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture + real(r_single),intent(in) :: pbk(lon2,lat2,nsig) ! pressure hPa +! +! derived fields +! + real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height +! +! misc. +! + INTEGER :: i,j,k + + REAL(r_single) :: rdog, h, dz + REAL(r_single) :: height(nsig+1) + +! +!================================================================ +! + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) + enddo + enddo + enddo + +! +! Compute geopotential height above the ground at midpoint of each layer +! + rdog = rd/grav + do j=1,lat2 + do i=1,lon2 + k = 1 + h = rdog * tbk(i,j,k) + dz = h * log(psbk(i,j)/pbk(i,j,k)) + height(k) = dz + + do k=2,nsig + h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) + dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) + height(k) = height(k-1) + dz + end do + + do k=1,nsig + hbk(i,j,k)=height(k) + end do + end do + end do + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp + enddo + enddo + enddo + +END SUBROUTINE BackgroundCldgfs + +SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & + zh,pt_ll,eta1_ll,aeta1_ll,eta2_ll,aeta2_ll,regional,wrf_mass_regional) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BackgroundCld Ingest background fields for cloud analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine reads in background hydrometeor fields for cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2010-04-26 Hu delete the module gridmod and guess_grids. +! transfer information subroutine dummy variables +! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS +! core +! +! +! input argument list: +! mype - processor ID +! lon2 - no. of lons on subdomain (buffer points on ends) +! lat2 - no. of lats on subdomain (buffer points on ends) +! nsig - no. of vertical levels +! tbk - 3D background potential temperature (K) +! psbk - 2D background surface pressure (hPa) +! q - 3D moisture (water vapor mixing ratio kg/kg) +! zh - terrain +! pt_ll - vertical coordinate +! eta1_ll - vertical coordinate +! aeta1_ll - vertical coordinate +! regional - if regional +! wrf_mass_regional - if mass core +! +! output argument list: +! pbk - 3D background pressure (hPa) +! hbk - 3D height above the ground (not the sea level) +!!!! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + use constants, only: rd_over_cp, h1000 + use constants, only: rd, grav, half, rad2deg + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: lon2 + integer(i_kind),intent(in):: lat2 + integer(i_kind),intent(in):: nsig + + real(r_kind), intent(in) :: pt_ll + real(r_kind), intent(in) :: eta1_ll(nsig+1) ! + real(r_kind), intent(in) :: aeta1_ll(nsig) ! + real(r_kind), intent(in) :: eta2_ll(nsig+1) ! + real(r_kind), intent(in) :: aeta2_ll(nsig) ! + logical, intent(in) :: regional ! .t. for regional background/analysis + logical, intent(in) :: wrf_mass_regional ! + + +! background +! +! read in from WRF +! + real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature + real(r_single),intent(inout) :: psbk(lon2,lat2) ! surface pressure + real(r_single),intent(in) :: zh(lon2,lat2) ! terrain elevation + real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture +! +! derived fields +! + real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height + real(r_single),intent(out) :: pbk(lon2,lat2,nsig)! pressure hPa +! real(r_single),intent(out) :: z_lcl(lon2,lat2) ! lifting condensation level +! +! misc. +! + INTEGER :: i,j,k + + REAL(r_single) :: rdog, h, dz + REAL(r_single) :: height(nsig+1) + real(r_single) :: q_integral(lon2,lat2),q_integralc4h(lon2,lat2) + real(r_single) :: deltasigma, deltasigmac4h,psfc_this + +! +!================================================================ +! + q_integral=1 + q_integralc4h=0.0 + do k=1,nsig + deltasigma=eta1_ll(k)-eta1_ll(k+1) + deltasigmac4h=eta2_ll(k)-eta2_ll(k+1) + do j=1,lat2 + do i=1,lon2 + q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) + q_integral(i,j)=q_integral(i,j)+deltasigma*q(i,j,k) + q_integralc4h(i,j)=q_integralc4h(i,j)+deltasigmac4h*q(i,j,k) + enddo + enddo + enddo + do j=1,lat2 + do i=1,lon2 + psfc_this=pt_ll+(psbk(i,j)-pt_ll)/q_integral(i,j) + psbk(i,j)= psfc_this + enddo + enddo + +! +! assign CAPE as 0, this part needs more work +! +! gsfc(:,:,3)=0.0 ! CAPE, we need but not included in wrf_inout +! 1: land use; 2: sfc soil T; 3: CAPE +! +! get land use and convert latitude and longitude back to degree +! xland=gsfc(:,:,1) +! soil_tbk=gsfc(:,:,2) +! +! get virtual potential temperature (thv) +! +! thv=0.0 +! do k=1,nsig +! do j=1,nlat +! do i=1,nlon +! rl=qr(i,j,k)+qs(i,j,k)+qg(i,j,k)+qc(i,j,k)+qi(i,j,k) +! thv(i,j,k)=tbk(i,j,k)*(1.0+0.61*q(i,j,k)-rl) +! ENDDO +! ENDDO +! ENDDO +!! +! +! now get pressure (pbk) and height (hbk) at each grid point +! + if(regional .and. wrf_mass_regional ) then + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + pbk(i,j,k)=aeta1_ll(k)*(psbk(i,j)-pt_ll)+pt_ll + aeta2_ll(k) + end do + end do + end do + +! Compute geopotential height at midpoint of each layer + rdog = rd/grav + do j=1,lat2 + do i=1,lon2 + k = 1 + h = rdog * tbk(i,j,k) + dz = h * log(psbk(i,j)/pbk(i,j,k)) + height(k) = zh(i,j) + dz + + do k=2,nsig + h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) + dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) + height(k) = height(k-1) + dz + end do + + do k=1,nsig + hbk(i,j,k)=height(k) - zh(i,j) + end do + end do + end do + else + write(6,*) ' Only wrf mass grid is done for cloud analysis ' + write(6,*) ' You are choosing grid that is not recoginzed by cloud analysis' + call stop2(114) + endif + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp + enddo + enddo + enddo + +END SUBROUTINE BackgroundCld diff --git a/src/GSD/gsdcloud/BckgrndCC.f90 b/src/GSD/gsdcloud/BckgrndCC.f90 new file mode 100644 index 0000000000..c5e8bc6d69 --- /dev/null +++ b/src/GSD/gsdcloud/BckgrndCC.f90 @@ -0,0 +1,158 @@ +SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & + cv_bk,t_k,z_lcl) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BckgrndCC generate background field for +! fractional cloud cover based on RH +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine calculate cloud field based on background fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! tbk - 3D background potentional temperature (K) +! pbk - 3D background pressure (hPa) +! q - 3D moisture (kg/kg) +! hbk - 3D height +! zh - terrain +! +! output argument list: +! cv_bk - 3D background cloud cover +! t_k - 3D temperature in K +! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_single,i_kind,r_kind + use constants, only: h1000, rd_over_cp, g_over_rd + + implicit none + + integer(i_kind),intent(in):: nlon,nlat,nsig +! background +! +! read in from WRF +! + real(r_single),intent(in) :: tbk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain elevation + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture + real(r_single),intent(in) :: hbk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure + + real(r_single),intent(out) :: t_k(nlon,nlat,nsig) ! temperature in K + real(r_single),intent(out) :: z_lcl(nlon,nlat) ! lifting condensation level + real(r_single),intent(out) :: cv_bk(nlon,nlat,nsig)! cloud cover + +! CONSTANTS: + real(r_single) :: gamma_d ! dry adiabatic lapse rate (K/m) + real(r_single) :: z_ref_lcl + PARAMETER(z_ref_lcl = 180.0_r_single) + +! misc. +! + real(r_single) :: rhbk(nlon,nlat,nsig) ! rh + + INTEGER :: i,j,k + + + REAL(r_kind) :: f_qvsat + REAL(r_kind) :: qvsat + REAL(r_kind) :: rh_to_cldcv + + REAL(r_kind) :: z_ref,x + REAL(r_kind) :: arg,arg2, t_ref_c, td_ref_c + REAL(r_kind) :: frac_z, t_ref_k,rh_ref + +! +!================================================================ +! + gamma_d = g_over_rd/rd_over_cp +! +! get the RH +! + do k=1,nsig + do j=2,nlat-1 + do i=2,nlon-1 + t_k(i,j,k)=tbk(i,j,k)*(pbk(i,j,k)/h1000)**rd_over_cp + qvsat=f_qvsat(pbk(i,j,k)*100.0_r_kind,t_k(i,j,k)) + ! Saturation water vapor specific humidity + qvsat = qvsat/(1.0 - qvsat) ! convert to saturation mixing ratio (kg/kg) + rhbk(i,j,k)=100._r_kind*MIN(1._r_kind,MAX(0._r_kind,(q(i,j,k)/qvsat))) + ! q is mixing ration kg/kg + enddo + enddo + enddo +! +! Find the lifting condensation level +! + z_lcl = -99999.0_r_kind + do j=2,nlat-1 + do i=2,nlon-1 + z_ref = z_ref_lcl + zh(i,j) + IF (z_ref <= hbk(i,j,2) .OR. z_ref > hbk(i,j,nsig-1)) THEN + write(6,*) 'Error, ref.level is out of bounds at pt:' & + ,i,j,z_ref,hbk(i,j,2),hbk(i,j,nsig-1) + call STOP2(114) + END IF + + DO k = 3,nsig-1 + IF ( z_ref < hbk(i,j,k) .and. z_ref >= hbk(i,j,k-1)) THEN + frac_z = (z_ref-hbk(i,j,k-1))/(hbk(i,j,k)-hbk(i,j,k-1)) + t_ref_k = t_k(i,j,k-1)+ frac_z*(t_k(i,j,k)-t_k(i,j,k-1)) + t_ref_c = t_ref_k - 273.15_r_kind +! + rh_ref = rhbk(i,j,k-1)+ frac_z*(rhbk(i,j,k)-rhbk(i,j,k-1)) +! compute dew point depression. +! td_ref_c = dwpt(t_ref_c,rh_ref) + x = 1._r_kind-0.01_r_kind*rh_ref + td_ref_c =t_ref_c-(14.55_r_kind+0.114_r_kind*t_ref_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_ref_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_ref_c)*x**14 + + END IF + END DO ! k = 2,nz-1 +! + z_lcl(i,j) = z_ref + (t_ref_c - td_ref_c)/gamma_d + z_lcl(i,j) = min(hbk(i,j,nsig-1),max(z_lcl(i,j),hbk(i,j,2))) + enddo + enddo +! +! get background cloud cover +! + cv_bk=0.0_r_kind + do k=1,nsig + do j=2,nlat-1 + do i=2,nlon-1 + IF (hbk(i,j,k) >= z_lcl(i,j)) THEN + arg = hbk(i,j,k) - zh(i,j) + arg2=rhbk(i,j,k)*0.01_r_kind + cv_bk(i,j,k) = rh_to_cldcv(arg2,arg) + ENDIF + enddo + enddo + enddo +! + +END SUBROUTINE BckgrndCC diff --git a/src/GSD/gsdcloud/CMakeLists.txt b/src/GSD/gsdcloud/CMakeLists.txt new file mode 100644 index 0000000000..3b2ca84f12 --- /dev/null +++ b/src/GSD/gsdcloud/CMakeLists.txt @@ -0,0 +1,7 @@ +cmake_minimum_required(VERSION 2.6) +if(BUILD_GSDCLOUD_ARW) + file(GLOB GSDCLOUD_SRC ${GSDCLOUD_DIR}/*.f90) + set_source_files_properties( ${GSDCLOUD_SRC} COMPILE_FLAGS ${GSDCLOUD_Fortran_FLAGS}) + add_library( ${gsdcloud} STATIC ${GSDCLOUD_SRC} ) + set_target_properties( ${gsdcloud} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) +endif() diff --git a/src/GSD/gsdcloud/PrecipMxr_radar.f90 b/src/GSD/gsdcloud/PrecipMxr_radar.f90 new file mode 100644 index 0000000000..13f3fff7d8 --- /dev/null +++ b/src/GSD/gsdcloud/PrecipMxr_radar.f90 @@ -0,0 +1,213 @@ +SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & + t_bk,p_bk,ref_mos_3d, & + cldpcp_type_3d,qr_cld,qnr_3d,qs_cld,qg_cld,cldqropt) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipMxR_radar find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This is the driver to call subroutines that calculate liquid water content based on +! radar reflectivity and hydrometeor type diagnosed from radar +! and background 3-D temperature fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! ref_mos_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D hydrometeor type +! cldqropt - scheme used to retrieve +! mixing ratios for hydrometeors related to precipitation (qr, qs, qg) +! 1=Kessler 2=Lin 3=Thompson +! +! output argument list: +! qr_cld - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration +! qs_cld - snow mixing ratio (g/kg) +! qg_cld - graupel mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype +!mhu integer(i_kind),intent(in) :: regional_time(6) +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! height +! + real(r_kind),intent(in) :: ref_mos_3d(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + integer(i_kind),intent(in) :: cldpcp_type_3d(nlon,nlat,nsig) +! +! hydrometeors +! + REAL(r_single),intent(out) :: qr_cld(nlon,nlat,nsig) ! rain + REAL(r_single),intent(out) :: qnr_3d(nlon,nlat,nsig) ! rain number concentration(/kg) + REAL(r_single),intent(out) :: qs_cld(nlon,nlat,nsig) ! snow + REAL(r_single),intent(out) :: qg_cld(nlon,nlat,nsig) ! graupel + +!----------------------------------------------------------- +! +! temp. +! + + REAL(r_single) :: t_3d(nlon,nlat,nsig) + REAL(r_single) :: p_3d(nlon,nlat,nsig) +! REAL(r_kind) :: qs_max + + INTEGER(i_kind) :: cldqropt + INTEGER(i_kind) :: istatus_pcp + INTEGER(i_kind) :: i,j,k +! INTEGER(i_kind) :: k_qs_max +! REAL(r_kind) :: threshold_t_1st + +! +!==================================================================== +! Begin +! +! cldqropt = 2 + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + t_3d(i,j,k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + p_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO + END DO + END DO + +!----------------------------------------------------------------------- +! +! Calculate 3D precipitation hydrometeor mixing ratios +! from radar reflectivity in g/kg. +! Note that qr_cld, qs_cld, and qg_cld are diagnosed +! qr, qs and qg in g/kg, respectively. +! +!----------------------------------------------------------------------- +! + IF (cldqropt == 1) THEN +! +! Kessler's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Kessler radar reflectivity equations...' + endif + CALL pcp_mxr (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp) + + ELSE IF (cldqropt == 2) THEN +! +! Ferrier's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Ferrier radar reflectivity equations...' + endif + CALL pcp_mxr_ferrier (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp,mype) + + ELSE IF (cldqropt == 3) THEN +! +! Thompson's scheme +! + if(mype==0) then + WRITE(6,'(a)') ' PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Thompson RUC radar reflectivity equations...' + endif +! call pcp_mxr_thompsonRUC(qr_cld,qs_cld,qg_cld, & +! p_3d,t_3d, & +! ref_mos_3d,nlon,nlat,nsig,cldpcp_type_3d) + call hydro_mxr_thompson (nlon,nlat,nsig, t_3d, p_3d, ref_mos_3d, & + qr_cld,qnr_3d,qs_cld, istatus_pcp,mype) + + END IF !cldqropt=1 or 2 or 3 +! +! +! Set qs to radar retrieved snow mixing ratio at all levels +! within 150 hPa above surface in all seasons (this condition +! should occur rarely in summer in the US lower 48 states). +! +! If there is no reflectivity at all below (for qs) +! within 150 hPa of surface in a column, but there is radar-qs > 0 +! above, then apply radar-qs to model-qs at 2 levels with +! maximum radar-qs in the column but for no other levels. +! +! move this function out of this subroutine to main driver. Feb.4 2013 +! +! If the 1st level temperature is less than 5 degree, then keep +! snow. Otherwise, keep a sinlge layer (maximum) of snow. +! +! if(l_cleanSnow_WarmTs) then +! threshold_t_1st=r_cleanSnow_WarmTs_threshold +! DO j = 2,nlat-1 +! DO i = 2,nlon-1 +! +! k_qs_max=2 +! qs_max=0.0_r_kind +! DO k = 2,nsig +! if(qs_max < qs_cld(i,j,k) ) then +! qs_max = qs_cld(i,j,k) +! k_qs_max=k +! endif +! END DO +! +! if((t_3d(i,j,1)-273.15_r_kind) < threshold_t_1st) then +!! keep snow falling +! else +! if(qs_max > 1.0e-7_r_kind) then +! DO k = 1,nsig +!! if(k==k_qs_max) then +!! do nothing to keep snow mixing ratio +! else +! qs_cld(i,j,k)=0.0_r_kind +! endif +! END DO +! endif +! endif +! END DO !i +! END DO ! j +! endif ! l_cleanSnow_WarmTs + +END SUBROUTINE PrecipMxR_radar + diff --git a/src/GSD/gsdcloud/PrecipType.f90 b/src/GSD/gsdcloud/PrecipType.f90 new file mode 100644 index 0000000000..beb00dcd84 --- /dev/null +++ b/src/GSD/gsdcloud/PrecipType.f90 @@ -0,0 +1,118 @@ +SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & + wthr_type,cldpcp_type_3d) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipType decide precipitation type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates precipitation type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! q_bk - 3D moisture +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! wthr_type - weather type +! +! output argument list: +! cldpcp_type_3d - 3D precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN):: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),INTENT(IN) :: q_bk(nlon,nlat,nsig) ! moisture +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! +! Variables for cloud analysis +! + integer(i_kind),INTENT(out) :: cldpcp_type_3d(nlon,nlat,nsig) + integer(i_kind),INTENT(in) :: wthr_type(nlon,nlat) + LOGICAL :: l_mask(nlon,nlat) ! "Potential" Precip Type + +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind):: i,j,k + real(r_single) :: temp_3d(nlon,nlat,nsig) ! temperature (C) + real(r_single) :: rh_3d(nlon,nlat,nsig) ! relative humidity + real(r_single) :: p_pa_3d(nlon,nlat,nsig) ! + REAL(r_single) :: qvsat + REAL(r_single) :: f_qvsat + INTEGER :: istatus +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 1,nlat + DO i = 1,nlon +! + DO k = 1,nsig ! Initialize + temp_3d(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to K + qvsat=f_qvsat(p_bk(i,j,k)*100.0_r_single,temp_3d(i,j,k)) + qvsat = qvsat/(1.0_r_single-qvsat) ! convert to mixing ratio (kg/kg) + rh_3d(i,j,k)=100._r_single*MIN(1.,MAX(0._r_single,(q_bk(i,j,k)/qvsat))) + p_pa_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO +!----------------------------------------------------------------------- + + ENDDO ! i + ENDDO ! j + + l_mask = .false. + + call pcp_type_3d (nlon,nlat,nsig,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + + +END SUBROUTINE precipType + diff --git a/src/GSD/gsdcloud/TempAdjust.f90 b/src/GSD/gsdcloud/TempAdjust.f90 new file mode 100644 index 0000000000..a7f0802750 --- /dev/null +++ b/src/GSD/gsdcloud/TempAdjust.f90 @@ -0,0 +1,199 @@ +SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & + qc,qi,ctmp_bk) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: TempAdjust temperature adjustment +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-26 +! +! ABSTRACT: +! This subroutine adjusts the perturbation potential temperature field to account +! for the latent heating release. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! cldptopt - schemes of adjustment +! 3=latent heat, 4,5,6 = adiabat profile +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! w_bk - 3D background vertical velocity +! q_bk - 3D moisture (water vapor mixing ratio) +! qc - 3D cloud water mixing ratio (kg/kg) +! qi - 3D cloud ice mixing ratio (kg/kg) +! ctmp_bk - 3D cloud temperature +! +! output argument list: +! t_bk - 3D background potential temperature (K) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: cp,rd_over_cp, h1000, hvap + use kinds, only: r_single,i_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype + +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: w_bk(nlon,nlat,nsig) ! terrain + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture - water vapor mixing ratio +! +! real(r_single) :: t_bk_check(nlon,nlat,nsig) ! temperature +! +! +! cloud water and cloud ice mixing ratios +! + real (r_single),intent(in) :: qc(nlon,nlat,nsig) + real (r_single),intent(in) :: qi(nlon,nlat,nsig) + real (r_single),intent(in) :: ctmp_bk(nlon,nlat,nsig) +! +! constant + REAL :: p0 +! +! +! temp. +! + INTEGER :: i,j,k + INTEGER(i_kind),intent(in) :: cldptopt + REAL :: frac_qc_2_lh, max_lh_2_pt + REAL :: max_pt_adj + REAL :: p0inv,arg,ptdiff + REAL :: ppi,wratio,ptcld +! +! +!----------------------------------------------------------- +! +! t_bk_check=0.0 + + p0=h1000 +! + wratio=1.0 +! cldptopt=3 + frac_qc_2_lh =1.0 + max_lh_2_pt=20.0 +! + IF (cldptopt == 3) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating.' + WRITE(6,'(a,f10.4,a,f10.4)') & + 'TempAdjust: frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + p0inv=1./p0 + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + arg=max(0.0,qc(i,j,k)) + max(0.0,qi(i,j,k)) + if( arg > 0.0 ) then + ppi = (p_bk(i,j,k)*p0inv) ** rd_over_cp + arg = hvap*frac_qc_2_lh*arg*0.001/(cp*ppi) + max_pt_adj = MAX(max_pt_adj,arg) + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + endif + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 4) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating in w.' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k) > 0.0) THEN + wratio=1.0 + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 5) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>-0.2' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF( ctmp_bk(i,j,k) > 0.0) THEN + wratio=min(max(0.,(5.0*(w_bk(i,j,k)+0.2))),1.0) + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + ENDIF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + ELSE IF (cldptopt == 6) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>0.0' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k)>0.0 ) THEN + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) +! t_bk_check(i,j,k) = MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + END IF ! cldptopt=3? + +! t_bk = t_bk_check + +END SUBROUTINE TempAdjust diff --git a/src/GSD/gsdcloud/adaslib.f90 b/src/GSD/gsdcloud/adaslib.f90 new file mode 100644 index 0000000000..555e7ec6a0 --- /dev/null +++ b/src/GSD/gsdcloud/adaslib.f90 @@ -0,0 +1,474 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines related to cloud analysis in ADAS (CAPS) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION RH_TO_CLDCV ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION rh_to_cldcv(rh,hgt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Obtain first guess cloud cover field from relative humidity. +! +! +! AUTHOR: Jian Zhang +! 07/95 +! +! MODIFICATION HISTORY +! +! 04/08/97 J. Zhang +! Added the empirical relationship between RH and +! cloud cover used by Koch et al. (1997). +! Reference: +! Reference: +! Koch, S.E., A. Aksakal, and J.T. McQueen, 1997: +! The influence of mesoscale humidity and evapotranspiration +! fields on a model forecast of a cold-frontal squall line. +! Mon. Wea. Rev., Vol.125, 384-409 +! 09/10/97 J. Zhang +! Modified the empirical relationship between cloud +! fraction and relative humidity from quadratic +! to one-fourth-power. +! +! +!----------------------------------------------------------------------- +! +! INPUT: +! rh ! relative humidity +! hgt ! height (AGL) +! +! OUTPUT: +! rh_to_cld_cv ! cloud fractional cover value +! +! LOCAL: +! rh0 ! the critical RH value that seperate clear + ! air condition and cloudy condition +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + + IMPLICIT NONE + + INTEGER(i_kind) :: rh2cform + PARAMETER (rh2cform=2) + + REAL(r_kind), intent(in) :: rh,hgt + REAL(r_kind) :: rh_to_cldcv + REAL(r_kind) :: rh0 + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! + IF(rh2cform == 1) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600.0_r_kind) THEN + rh0 = 0.9_r_kind + ELSE IF (hgt < 1500.0_r_kind) THEN + rh0 = 0.8_r_kind + ELSE IF (hgt < 2500.0_r_kind) THEN + rh0 = 0.6_r_kind + ELSE + rh0 = 0.5_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = (rh - rh0)/(1.0_r_kind - rh0) + rh_to_cldcv = rh_to_cldcv*rh_to_cldcv + END IF + + ELSE IF(rh2cform == 2) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover with fixed rh0=0.75 +! +!----------------------------------------------------------------------- +! +! + IF (rh < 0.75_r_kind) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 16._r_kind*(rh - 0.75_r_kind)*(rh - 0.75_r_kind) + END IF + + ELSE +! +!-----------------------------------------------------------------------! +! A modified version of the sqrt relationship between +! relative humidity and cloud fractional cover used in Eta model. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600._r_kind) THEN + rh0 = 0.8_r_kind + ELSE + rh0 = 0.75_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 1.0_r_kind - SQRT((1.0_r_kind - rh)/(1.0_r_kind - rh0)) + END IF + + END IF + + RETURN + END FUNCTION rh_to_cldcv +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_ES ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_es( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_es Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_es ! Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_esl, f_esi + +!fpp$ expand (f_esl) +!fpp$ expand (f_esi) +!!dir$ inline always f_esl, f_esi +!*$* inline routine (f_esl, f_esi) + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + IF ( t >= 273.15 ) THEN ! for water + f_es = f_esl( p,t ) + ELSE ! for ice + f_es = f_esi( p,t ) + END IF + + RETURN +END FUNCTION f_es + +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over liquid water using +! enhanced Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esl( p, t ) + + IMPLICIT NONE + +! constant + REAL :: satfwa, satfwb + PARAMETER ( satfwa = 1.0007 ) + PARAMETER ( satfwb = 3.46E-8 ) ! for p in Pa + + REAL :: satewa, satewb, satewc + PARAMETER ( satewa = 611.21 ) ! es in Pa + PARAMETER ( satewb = 17.502 ) + PARAMETER ( satewc = 32.18 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esl ! Saturation water vapor pressure over liquid water + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfwa + satfwb * p + f_esl = f * satewa * EXP( satewb*(t-273.15)/(t-satewc) ) + + RETURN +END FUNCTION f_esl +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over ice using enhanced +! Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esi( p, t ) + + IMPLICIT NONE + +! + REAL :: satfia, satfib + PARAMETER ( satfia = 1.0003 ) + PARAMETER ( satfib = 4.18E-8 ) ! for p in Pa + + REAL :: sateia, sateib, sateic + PARAMETER ( sateia = 611.15 ) ! es in Pa + PARAMETER ( sateib = 22.452 ) + PARAMETER ( sateic = 0.6 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esi ! Saturation water vapor pressure over ice (Pa) + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfia + satfib * p + f_esi = f * sateia * EXP( sateib*(t-273.15)/(t-sateic) ) + + RETURN +END FUNCTION f_esi +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_QVSAT ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_qvsat( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_qvsat Saturation water vapor specific humidity (kg/kg). +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_qvsat ! Saturation water vapor specific humidity (kg/kg) +! +!----------------------------------------------------------------------- +! +! Include files: +! +!----------------------------------------------------------------------- +! +! + + REAL :: rd ! Gas constant for dry air (m**2/(s**2*K)) + PARAMETER( rd = 287.0 ) + + REAL :: rv ! Gas constant for water vapor (m**2/(s**2*K)). + PARAMETER( rv = 461.0 ) + + REAL :: rddrv + PARAMETER( rddrv = rd/rv ) + +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_es +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f_qvsat = rddrv * f_es(p,t) / (p-(1.0-rddrv)*f_es(p,t)) + + RETURN +END FUNCTION f_qvsat + +SUBROUTINE getdays(nday,iyear,imonth,iday) + + use kinds, only: i_kind + implicit none +! + INTEGER(i_kind), intent(in) :: iyear,imonth,iday + INTEGER(i_kind), intent(out) :: nday +! + + nday=0 + if(imonth==1) then + nday=iday + elseif(imonth==2) then + nday=31+iday + elseif(imonth==3) then + nday=59+iday + elseif(imonth==4) then + nday=90+iday + elseif(imonth==5) then + nday=120+iday + elseif(imonth==6) then + nday=151+iday + elseif(imonth==7) then + nday=181+iday + elseif(imonth==8) then + nday=212+iday + elseif(imonth==9) then + nday=243+iday + elseif(imonth==10) then + nday=273+iday + elseif(imonth==11) then + nday=304+iday + elseif(imonth==12) then + nday=334+iday + endif + if(mod(iyear,4) == 0 .and. imonth > 2 ) nday=nday+1 + +END SUBROUTINE getdays diff --git a/src/GSD/gsdcloud/build_missing_REFcone.f90 b/src/GSD/gsdcloud/build_missing_REFcone.f90 new file mode 100644 index 0000000000..97b7c6863e --- /dev/null +++ b/src/GSD/gsdcloud/build_missing_REFcone.f90 @@ -0,0 +1,245 @@ +SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk,pblh) +! +! radar observation +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: build_missing_REFcone build missing reflectivity area +! below cone down to assumed cloud base +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-26 +! +! ABSTRACT: +! This subroutine sets reflectivity values at missing reflectivity volumes +! below the radar "data cone" down to an assumed cloud base +! As of March 2010, this code code not yet use the local PBL base +! as used in the RUC cloud/hydrometeor analysis since summer 2009. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2011-04-08 Hu Clean the reflectivity below PBL height or level 7 +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! krad_bot - radar bottom level +! ref_mos_3d - 3D radar reflectivity +! h_bk - 3D background height +! pblh - PBL height in grid +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single), intent(in) :: pblh(nlon,nlat) ! PBL height + real(r_single), intent(in) :: krad_bot_in +! + integer(i_kind) :: krad_bot,ifmissing +! + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile(km) + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-35 dbz + DATA refprofile_winter(:,1) / & + 0.999,0.938,0.957,0.975,0.983,0.990,0.995,0.999,1.000,1.000, & + 0.994,0.985,0.957,0.926,0.892,0.854,0.819,0.791,0.770,0.747, & + 0.729,0.711,0.705,0.685,0.646,0.631,0.649,0.711,0.828,0.931, & + 0.949/ +! max reflectivity 25-30 dbz + DATA refprofile_winter(:,2) / & + 0.965,0.937,0.954,0.970,0.984,0.991,0.996,1.000,0.997,0.988, & + 0.973,0.954,0.908,0.856,0.808,0.761,0.718,0.684,0.659,0.631, & + 0.607,0.586,0.570,0.550,0.523,0.512,0.531,0.601,0.711,0.813, & + 0.870/ +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,3) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,4) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,5) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,6) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + + real(r_kind) :: refprofile_summer(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-25 dbz + DATA refprofile_summer(:,1) / & + 0.883,0.870,0.879,0.892,0.904,0.912,0.913,0.915,0.924,0.936, & + 0.946,0.959,0.984,0.999,1.000,0.995,0.988,0.978,0.962,0.940, & + 0.916,0.893,0.865,0.839,0.778,0.708,0.666,0.686,0.712,0.771, & + 0.833/ +! max reflectivity 25-30 dbz + DATA refprofile_summer(:,2) / & + 0.836,0.874,0.898,0.915,0.927,0.938,0.945,0.951,0.960,0.970, & + 0.980,0.989,1.000,0.995,0.968,0.933,0.901,0.861,0.822,0.783, & + 0.745,0.717,0.683,0.661,0.614,0.564,0.538,0.543,0.578,0.633, & + 0.687/ +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,3) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,4) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,5) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,6) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl + REAL(r_kind) :: lowest,highest,tempref(nsig), tempprofile(maxlvl) + REAL(r_kind) :: maxref + + INTEGER(i_kind) :: i,j, k2, k, mref + +! +! vertical reflectivity distribution +! + season=1 + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO +! + DO j=2,nlat-1 + DO i=2,nlon-1 + ifmissing=0 + maxref=-9999.0_r_kind +!mhu krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! Here, we only use PBL height to build missing corn and clean the reflectivity lower than +! PBL height. The krad_bot_in will be used when calculate the radar tten but not the hydrometer retrieval. +! Nov 21, 2011. Ming Hu + krad_bot= int( pblh(i,j) + 0.5_r_single ) ! consider PBL height +! +! in our case, -99 is no echo +! + DO k2=int(nsig/2),krad_bot,-1 + if(ref_mos_3d(i,j,k2+1)>=20._r_kind .and. & + ref_mos_3d(i,j,k2) < -100._r_kind ) ifmissing=k2 + if(ref_mos_3d(i,j,k2)>=maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO + IF(ifmissing > 1 ) then + DO k2=krad_bot,1,-1 + if(ref_mos_3d(i,j,k2) >maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO + if(maxref < 19.0_r_kind) then + write(6,*) 'build_missing_REFcone:',ifmissing,i,j,ifmissing + write(6,*) (ref_mos_3d(i,j,k2),k2=1,nsig) + endif + endif + IF(ifmissing > 1 .and. maxref > 19.0_r_kind ) then + mref = min(6,(int((maxref - 20.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*maxref + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*maxref + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif +! make a ref profile + tempref=-9999.9_r_kind + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. & + heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref(k2)=(1-wght)*downref + wght*upref + endif + ENDDO +! build missing volumes down to krad_bot level +! NOTE: no use of PBL base yet, as done in RUC analysis since summer 2009 + maxref=ref_mos_3d(i,j,ifmissing+1)-tempref(ifmissing+1) + if(abs(maxref) < 10.0_r_kind ) then + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = tempref(k2) + maxref + ENDDO + else + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = ref_mos_3d(i,j,ifmissing+1) + ENDDO + endif +! + ENDIF +! clean echo less than PBL height and level 7 + DO k2=1,krad_bot + ref_mos_3d(i,j,k2) = -99999.0_r_kind + ENDDO + ENDDO + ENDDO + +END SUBROUTINE build_missing_REFcone diff --git a/src/GSD/gsdcloud/cloudCover_NESDIS.f90 b/src/GSD/gsdcloud/cloudCover_NESDIS.f90 new file mode 100644 index 0000000000..68ea71b9e7 --- /dev/null +++ b/src/GSD/gsdcloud/cloudCover_NESDIS.f90 @@ -0,0 +1,713 @@ +SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& + xlong,xlat,t_bk,p_bk,h_bk,xland, & + soil_tbk,sat_ctp,sat_tem,w_frac,& + l_cld_bld,cld_bld_hgt,build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & + cld_cover_3d,cld_type_3d,wthr_type,Osfc_station_map) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_NESDIS cloud cover analysis using NESDIS cloud products +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine determines cloud_cover (fractional) field using NESDIS cloud products +! Based on RUC assimilation code - (Benjamin, Weygandt, Kim, Brown) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! regional_time - analysis time +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! xlong - 2D longitude in each grid +! xlat - 2D latitude in each grid +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! h_bk - 3D background height +! xland - surface type (water, land) +! soil_tbk - background soil temperature +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! l_cld_bld - logical for turning on GOES cloud building +! cld_bld_hgt - Height below which cloud building is done +! build_cloud_frac_p - Threshold above which we build clouds +! clear_cloud_frac_p - Threshold below which we clear clouds +! +! output argument list: +! nlev_cld - cloud status +! cld_cover_3d- 3D cloud cover (fractional cloud) +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: xlong(nlon,nlat) ! longitude + real(r_single),intent(in) :: xlat(nlon,nlat) ! latitude + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potentional temperature + real(r_single),intent(inout) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: xland(nlon,nlat) ! surface + real(r_single),intent(in) :: soil_tbk(nlon,nlat) ! soil tmperature +! real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) +! +! Observation +! + real(r_single),intent(inout) :: sat_ctp(nlon,nlat) + real(r_single),intent(inout) :: sat_tem(nlon,nlat) + real(r_single),intent(inout) :: w_frac(nlon,nlat) + integer(i_kind),intent(out) :: nlev_cld(nlon,nlat) + integer(i_kind),intent(in) :: Osfc_station_map(nlon,nlat) +! +! Turn on cloud building and height limit + logical, intent(in) :: l_cld_bld + real(r_kind), intent(in) :: cld_bld_hgt + real(r_kind), intent(in) :: build_cloud_frac_p + real(r_kind), intent(in) :: clear_cloud_frac_p +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! +!------------------------------------------------------------------------- +! --- Key parameters +! Min_cloud_lev_p = 3 Lowest model level to check for cloud +! Sat_cloud_pthick_p= 50. Depth (mb) of new sat-sensed cloud layer +! Cloud_up_p = 10 Pressure thickness for +! Upward extrapolation of cloud +! (if model level is within cloud_up_p +! mb of sat cloud level) +! min_cloud_p_p = 960. Max pressure at which NESDIS cloud +! info is considered reliable +! (i.e., not reliable at low levels) + +! zen_limit = 0.20 Solar zenith angle - lower limit +! at which sun is considered +! high enough to trust the +! GOES cloud data + + integer(i_kind) :: min_cloud_lev_p + real(r_kind) :: sat_cloud_pthick_p + real(r_kind) :: cloud_up_p + real(r_kind) :: min_cloud_p_p + real(r_kind) :: co2_preslim_p + real(r_kind) :: zen_limit + real(r_kind) :: dt_remap_pcld_limit_p + +! --- Key parameters + data Min_cloud_lev_p / 1_i_kind / ! w/ sfc cld assim +! data Min_cloud_lev_p / 3_i_kind / ! w/ sfc cld assim + data Sat_cloud_pthick_p / 30._r_kind/ +! data Sat_cloud_pthick_p / 50._r_kind/ + data cloud_up_p / 0._r_kind / + data min_cloud_p_p / 1080._r_kind/ ! w/ sfc cld assim + data co2_preslim_p / 620._r_kind/ +! -- change to 82 deg per Patrick Minnis - 4 Nov 09 + data zen_limit / 0.14_r_kind/ +! data zen_limit / 0.20_r_kind / + data dt_remap_pcld_limit_p / 3.5_r_kind / +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: null_p + REAL(r_kind) :: spval_p + PARAMETER ( null_p = -1 ) + PARAMETER ( spval_p = 99999.0 ) + + INTEGER(i_kind) :: i,j,k,k1,i1,j1,jp1,jm1,ip1,im1 + INTEGER(i_kind) :: gmt,nday,iyear,imonth,iday + REAL(r_kind) :: declin + real(r_kind) :: hrang,xxlat + real(r_single) :: csza(nlon,nlat) + + INTEGER(i_kind) :: ndof_tot, npts_clear, npts_build, npts_bel650 + INTEGER(i_kind) :: npts_warm_cld_flag, npts_tskin_flag, npts_stab_flag, npts_ptly_cloudy + real (r_single) :: tbk_k(nlon,nlat,nsig) + + INTEGER(i_kind) :: npts_ctp_change, npts_ctp_delete, npts_ctp_nobuddy + INTEGER(i_kind) :: npts_clr_nobuddy,npts_ctp_marine_remap + real (r_single) :: dctp, dctpabs + + real(r_single) :: tsmin + + INTEGER(i_kind) :: kisotherm, ibuddy, ktempmin + real(r_kind) :: tempmin,dth2dp2, stab, stab_threshold + + real(r_kind) :: firstcloud, pdiff,pdiffabove + + INTEGER(i_kind) :: k_closest, cld_warm_strat(nlon,nlat) + REAL(r_kind) :: tdiff + +! +!==================================================================== +! Begin +! +! calculation solar declination +! + iyear=regional_time(1) + imonth=regional_time(2) + iday=regional_time(3) + call getdays(nday,iyear,imonth,iday) + declin=deg2rad*23.45_r_kind*sin(2.0_r_kind*pi*(284+nday)/365.0_r_kind) + + cld_warm_strat=-1 +! +! from mb to Pa +! + do k = 1,nsig + do j = 1,nlat + do i = 1,nlon +! qw=q_bk(i,j,k)/(1. + q_bk(i,j,k)) ! convert to specific humidity + tbk_k(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to temperature(K) + p_bk(i,j,k) = p_bk(i,j,k)*100._r_kind + end do + end do + end do + + if( p_bk(nlon/2,nlat/2,2) < 5000.0_r_kind ) then + write(6,*) 'cloudCover_NESDIS: pressure unit check failed', p_bk(nlon/2,nlat/2,2) + call stop2(114) + endif + if( tbk_k(nlon/2,nlat/2,nsig-2) > 300._r_kind) then + write(6,*) 'cloudCover_NESDIS: temperature unit check failed', & + tbk_k(nlon/2,nlat/2,nsig-2) + call stop2(114) + endif + +! +! csza = fraction of solar constant (cos of zenith angle) + gmt = regional_time(4) ! UTC + do j=2,nlat-1 + do i=2,nlon-1 + hrang= (15._r_kind*gmt + xlong(i,j) - 180._r_kind )*deg2rad + xxlat=xlat(i,j)*deg2rad + csza(i,j)=sin(xxlat)*sin(declin) & + +cos(xxlat)*cos(declin)*cos(hrang) + end do + end do + +! +! start checking the data +! + ndof_tot = 0 !counting total number of grids of sat info + npts_clear = 0 + npts_build = 0 + npts_bel650 = 0 + npts_tskin_flag = 0 + npts_stab_flag = 0 + npts_ptly_cloudy = 0 + + do j=2,nlat-1 + do i=2,nlon-1 + jp1 = min(j+1,nlat) + jm1 = max(j-1,1 ) + ip1 = min(i+1,nlon) + im1 = max(i-1,1 ) + tsmin = soil_tbk(i,j) +! --- Determine min skin temp in 3x3 around grid point. +! This is to detect nearby presence of coastline. + do j1 = jm1,jp1 + do i1 = im1,ip1 + tsmin = min(tsmin,soil_tbk(i1,j1) ) + end do + end do + + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-soil_tbk(i,j)) > 4._r_kind & + .and. soil_tbk(i,j) < 263._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. abs(xland(i,j))>0.0001_r_single & + .and. p_bk(i,j,1)/100. >=850._r_kind ) then +! w_frac(i,j) = -99999._r_kind +! sat_tem(i,j) = 99999._r_kind +! sat_ctp(i,j) = 0._r_kind +! nlev_cld(i,j) = -999 + npts_warm_cld_flag = npts_warm_cld_flag + 1 + cld_warm_strat(i,j)=5 + end if +! PH changed condition to match RUC: Tcld-Tskin(bkg) < 4, > -2 + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-tsmin) > -2._r_kind & + .and. (sat_tem(i,j)-tsmin) <= 4._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. abs(xland(i,j)) > 0.0001_r_single & + .and. p_bk(i,j,1)/100._r_kind>= 950._r_kind ) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_tskin_flag = npts_tskin_flag + 1 + cld_warm_strat(i,j)=4 + end if + if (w_frac(i,j)<=clear_cloud_frac_p .and. & + w_frac(i,j)>-1._r_kind) then + sat_ctp(i,j) = 1013.0_r_kind + npts_clear = npts_clear + 1 + cld_warm_strat(i,j)=0 + end if + if (w_frac(i,j) > clear_cloud_frac_p.and. & + w_frac(i,j) < build_cloud_frac_p) then +! w_frac(i,j) = -99999._r_kind + sat_tem(i,j)= 99999._r_kind +! mhu: this can cause problem: a miss line between cloud and clean, set it to clean +! PH: for CLAVR data, just set sat_ctp = 0. + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_ptly_cloudy = npts_ptly_cloudy + 1 + cld_warm_strat(i,j)=1 + end if + if (w_frac(i,j) >= build_cloud_frac_p.and. & + sat_ctp(i,j) < 1050) then + npts_build = npts_build + 1 + cld_warm_strat(i,j)=2 + end if + if (sat_ctp(i,j)>co2_preslim_p .and. sat_ctp(i,j)<1010._r_kind) & + npts_bel650 = npts_bel650 + 1 + +! -- nlev_cld = 1 if cloud info is present +! -- nlev_cld = 0 if no cloud info is at this grid point + + if(nlev_cld(i,j) >= 1) ndof_tot = ndof_tot + 1 + end do ! i + end do ! j +! + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: TOTAL NUMBER OF GRID pts w/ GOES CLOUD data =',ndof_tot + write(6,*) 'cloudCover_NESDIS: CLEAR NUMBER OF GRID pts w/ GOES CLOUD data =',npts_clear + write(6,*) 'cloudCover_NESDIS: BUILD NUMBER OF GRID pts w/ GOES CLOUD data =',npts_build + write(6,*) 'cloudCover_NESDIS: PTCLDY NUMBER OF GRID pts w/ GOES CLOUD data =',npts_ptly_cloudy + write(6,*) 'cloudCover_NESDIS: > 650mb - no OF GRID pts w/ GOES CLOUD data =',npts_bel650 + write(6,*) 'cloudCover_NESDIS: Flag CTP - skin temp too close to TB, no=',npts_tskin_flag + write(6,*) 'cloudCover_NESDIS: Clear -> cloud frac < clear frac' + write(6,*) 'cloudCover_NESDIS: Build -> cloud frac > build frac' + endif + +! +!! +! + npts_ctp_change = 0 + npts_ctp_delete = 0 + npts_ctp_nobuddy = 0 + npts_clr_nobuddy = 0 + npts_ctp_marine_remap = 0 + dctp = 0. + dctpabs = 0. + +! - stability threshold for building cloud - 3K / 100 mb (10000 Pa) + + stab_threshold = 3._r_kind/10000._r_kind + do j=2,nlat-1 + do i=2,nlon-1 + +! -- GOES indicates clouds in the lower troposphere + if (sat_ctp(i,j) < 1010._r_kind .and. sat_ctp(i,j) > co2_preslim_p) then + + tdiff = 999. + k_closest = -1 + do k=3,nsig-1 +! Attempt remapping if within 75 hPa (arbitrary) + if ((sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind)< 75._r_kind) then + if (abs(sat_tem(i,j)-tbk_k(i,j,k)) < tdiff) then + k_closest = k + tdiff = abs(sat_tem(i,j)-tbk_k(i,j,k)) + end if + end if + end do ! k loop + + if (k_closest <= 0 .and. abs(xland(i,j)) > 0.0001_r_single) then + npts_ctp_delete = npts_ctp_delete + 1 + write (6,*) i,j,sat_tem(i,j),tdiff,k_closest,xland(i,j) + go to 111 + end if + + k = k_closest + + if( abs(xland(i,j)) >0.0001_r_single ) then +! PH: dt_limit was hardwired to 1.5K, changed it to 3.5K to match RUC + if ((tdiff < dt_remap_pcld_limit_p) .or. & + (cld_warm_strat(i,j) == 5 .and. tdiff < 4._r_kind )) then + dctpabs = dctpabs + abs(sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + dctp = dctp+ (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + k1 = k + +1115 continue + +! --- This stability check only for reassigining CTP using RUC bkg profile. +! There is a later general check also. + stab = (t_bk(i,j,k1+1)-t_bk(i,j,k1)) & + /(p_bk(i,j,k1)-p_bk(i,j,k1+1)) + if (stab < stab_threshold) then + k1 = k1 + 1 + if ((p_bk(i,j,k)-p_bk(i,j,k1)) > 5000._r_kind) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_stab_flag= npts_stab_flag + 1 + go to 111 + end if + go to 1115 + end if + + sat_ctp(i,j) = p_bk(i,j,k)/100._r_kind + npts_ctp_change = npts_ctp_change + 1 + go to 111 + else + npts_ctp_delete = npts_ctp_delete + 1 +! write (6,*) i,j,sat_tem(i,j),tdiff + go to 111 + end if + + else ! xland==0: over water + +! --- Remap marine cloud to min temp level below 880 mb +! if no matching RUC temp already found + + if (sat_ctp(i,j)>880._r_kind)then + tempmin = -500._r_kind + +! --- Look thru lowest 15 levels for lowest temp for +! level to put marine cloud at. +! --- Start at level 3 + kisotherm = 20 + ktempmin = 20 + do k=min_cloud_lev_p+2,15 + if (p_bk(i,j,k)/100._r_kind .lt. 880._r_kind) go to 1101 + dth2dp2 = t_bk(i,j,k+1)+t_bk(i,j,k-1)-2._r_kind*t_bk(i,j,k) + if (kisotherm==0 .and. & + tbk_k(i,j,k) < tbk_k(i,j,k+1)) kisotherm = k + if (dth2dp2>tempmin) then + ktempmin = k + tempmin = max(dth2dp2,tempmin) + end if + end do +1101 continue + ktempmin = min(ktempmin,kisotherm) + sat_ctp(i,j) = p_bk(i,j,ktempmin)/100._r_kind + npts_ctp_marine_remap = npts_ctp_marine_remap + 1 + end if ! sat_ctp(i,j)>880._r_kind + endif ! xland == 0 + end if +111 continue + enddo ! i + enddo ! j + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - unstable w/i 50mb of CTP, no=', npts_stab_flag + write(6,*) 'cloudCover_NESDIS: Flag CTP - can''t remap CTP, no=', npts_ctp_delete + write(6,*) 'cloudCover_NESDIS: Flag CTP -remap marine cloud, no=', npts_ctp_marine_remap + endif + + if (npts_ctp_change > 0) then + if(mype==0) write (6,1121) npts_ctp_change, dctp/float(npts_ctp_change), & + dctpabs/float(npts_ctp_change) +1121 format (/'No. of pts w/ cloud-top pres change = ',i6 & + /'Mean cloud-top pres change (old-new)= ',f8.1 & + /'Mean abs cloud-top pres change = ',f8.1/) + end if +! +! --- Make sure that any cloud point has another cloud point nearby. +! Otherwise, get rid of it. + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j)< 1010._r_kind .and. sat_ctp(i,j)>50._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1)<1010._r_kind .and. sat_ctp(i1,j1)>50._r_kind) ibuddy = 1 + end do + end do + if (ibuddy==0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_ctp_nobuddy = npts_ctp_nobuddy + 1 + end if + end if + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j) <1100._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1) > 1010._r_kind .and. sat_ctp(i1,j1) <1100._r_kind) ibuddy = 1 + end do + end do + if (ibuddy == 0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_clr_nobuddy = npts_clr_nobuddy + 1 + end if + end if + enddo + enddo + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ cloud, no=', & + npts_ctp_nobuddy + + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ clear, no=', & + npts_clr_nobuddy + endif + +! +! ***************************************************************** +! ***************************************************************** +! Start to adjust to GOES cloud top pressure +! ***************************************************************** +! ***************************************************************** + +! --- clear where GOES shows clear down to the surface +! or down to the GOES cloud top level + +! ============================================= +! - clear down to surface in fully clear column (according to GOES) +! ============================================= +! Only trust 'clear' indication under following conditions +! - over ocean +! - or over land only if p<620 mb overnight +! - or at any level in daytime (zenith angle +! greater than zen_limit threshold) +! +! mhu Nov. 26, 2014: Add a metar station map: Osfc_station_map +! when Osfc_station_map=1, it is a grid point around a metar station +! Then the satellite clean step will skip this metar station point. +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind) then !clear + do k=1,nsig + if ((csza(i,j)=zen_limit) then + if(Osfc_station_map(i,j) == 1 .and. & + cld_cover_3d(i,j,k) > 0.0001_r_kind) then + else + cld_cover_3d(i,j,k) = 0.0_r_single + wthr_type(i,j) = 0 + endif +! +!mhu Nov 15 2014: don't let metar build cloud if +! - over land +! - during night +! - lower than co2_preslim_p +! - clear from satellite + else ! mhu Dec 2016: turn off this night low cloud check + if(Osfc_station_map(i,j) == 1 .and. & + cld_cover_3d(i,j,k) >0.0001_r_kind) then + else + cld_cover_3d(i,j,k) = 0.0_r_single + wthr_type(i,j) = 0 + endif +!mhu elseif( (csza(i,j)=co2_preslim_p) .and. & +!mhu abs(xland(i,j)-0._r_single) > 0.0001_r_single .and. & +!mhu cld_cover_3d(i,j,k) >0.0001_r_kind) then +!mhu if(Osfc_station_map(i,j) == 1) then +!mhu else +!mhu cld_cover_3d(i,j,k) = - 77777.0_r_single ! set to unknown +!mhu endif + end if + end do +!mhu: use 1060hps cloud top pressure to clean above the low cloud top + elseif (abs(sat_ctp(i,j)-1060.0_r_kind) < 1.0_r_kind) then !clear since the low cloud top + do k=1,nsig + cld_cover_3d(i,j,k) = 0.0_r_single + wthr_type(i,j) = 0 +!mhu mhu Dec 2016: turn off this night low cloud check +!mhu if (csza(i,j)=zen_limit) then +!mhu if( abs(cld_cover_3d(i,j,k)) > 2.0_r_single ) then +!mhu cld_cover_3d(i,j,k) = 0.0_r_single +!mhu wthr_type(i,j) = 0 +!mhu endif +!mhu end if + end do + end if + enddo + enddo +! ============================================= +! - clearing above cloud top +! ============================================= + + do j=2,nlat-1 + do i=2,nlon-1 + do k=1,nsig-1 + if (sat_ctp(i,j)<1010._r_kind .and. & + sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then + if(sat_ctp(i,j) >= 800.0_r_kind .and. Osfc_station_map(i,j) == 1) then + cld_cover_3d(i,j,k+1) = & + max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0.0_r_single + endif + endif + +! - return to previous (but experimental) version - 12 Oct 04 +!mhu if (csza(i,j) < zen_limit & +!mhu .and. p_bk(i,j,k)/100._r_kind=zen_limit) then +! --- since we set GOES to nearest RUC level, only clear at least +! 1 RUC level above cloud top +!mhu if (sat_ctp(i,j)<1010._r_kind .and. & +!mhu sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then +! +! mhu, some low cloud top press (> 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! +!mhu if(sat_ctp(i,j) >= 800.0_r_kind ) then +!mhu cld_cover_3d(i,j,k+1) = & +!mhu max(0.0_r_single, cld_cover_3d(i,j,k+1)) +!mhu else +!mhu cld_cover_3d(i,j,k+1) = 0.0_r_single +!mhu endif +!mhu endif +!mhu end if + end do + enddo + enddo + +! print *, 'h_bk max: ', maxval(h_bk(:,:,1)), ' min: ', minval(h_bk(:,:,1)) + +! ============================================= +! - start building where GOES indicates so +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + + if ((w_frac(i,j)>= build_cloud_frac_p) .and. & + (w_frac(i,j)< 99999._r_kind) )then !Dongsoo added + +! --- Cloud info below MIN_CLOUD_P not reliable + firstcloud = 0 +! - pdiff (diff between sat cloud top and model sfc pres) in mb + do k=nsig-1,min_cloud_lev_p,-1 + pdiff = (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) +! --- set closest RUC level w/ cloud + if (pdiff<=0. .and. firstcloud==0) then + pdiffabove = sat_ctp(i,j)-p_bk(i,j,k+1)/100._r_kind + if (abs(pdiffabove) 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! + if(sat_ctp(i,j) >= 800.0_r_kind ) then + cld_cover_3d(i,j,k+1) = max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0.0_r_single + endif + firstcloud = 1 + end if + end if + +! no cloud above cloud top + +! +! --- Add 50mb thick (at least 1 level) of cloud where GOES +! indicates cloud top + if (abs(xland(i,j)) > 0.0001_r_single) then + if (sat_ctp(i,j)< min_cloud_p_p .and. & + pdiff<=cloud_up_p ) then + if (firstcloud==0.or. firstcloud==1 & + .and.pdiff >= -1.*sat_cloud_pthick_p) then +! sgb - 2/7/2012 - remove this condition +! Allow cloud building below CO2_preslim and at night and over land +! if (p_bk(i,j,k)/100._r_kind= -1.*sat_cloud_pthick_p) then +! xland ==0 if (p_bk(i,j,k)/100..lt.co2_preslim_p) then + if (l_cld_bld .and. h_bk(i,j,k+1) < cld_bld_hgt) then + cld_cover_3d(i,j,k)=1.0_r_single + else + cld_cover_3d(i,j,k)=-99998.0_r_single + end if + firstcloud = 1 + end if + end if + end if + + end do + end if + enddo ! j + enddo + +! go from pa to mb + do k = 1,nsig + do j = 2,nlat-1 + do i = 2,nlon-1 + p_bk(i,j,k) = p_bk(i,j,k)/100._r_kind + end do + end do + end do +! +END SUBROUTINE cloudCover_NESDIS + diff --git a/src/GSD/gsdcloud/cloudCover_Surface.f90 b/src/GSD/gsdcloud/cloudCover_Surface.f90 new file mode 100644 index 0000000000..55ba970556 --- /dev/null +++ b/src/GSD/gsdcloud/cloudCover_Surface.f90 @@ -0,0 +1,427 @@ +SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& + cld_bld_hgt,t_bk,p_bk,q,h_bk,zh, & + mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,Odist,& + cld_cover_3d,cld_type_3d,wthr_type,pcp_type_3d, & + watericemax, kwatericemax,vis2qc) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_Surface cloud cover analysis using surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine determines 3D cloud fractional cover using surface observations +! Code based on RUC assimilation code (hybfront/hybcloud.f) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! r_radius - influence radius of the cloud observation +! thunderRadius - +! cld_bld_hgt - Height below which cloud building is done +! +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! q - 3D moisture (water vapor mixing ratio) +! h_bk - 3D background height (m) +! zh - terrain (m) +! +! mxst_p - maximum observation number +! NVARCLD_P - first dimension of OLCD +! numsao - observation number +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! pcp_type_3d - 3D weather precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + REAL(r_single), intent(in) :: r_radius + integer(i_kind),intent(in) :: nlat,nlon,nsig + real(r_single), intent(in) :: thunderRadius + real(r_kind), intent(in) :: cld_bld_hgt +! +! surface observation +! + INTEGER(i_kind),intent(in) :: mxst_p,NVARCLD_P + +! PARAMETER (LSTAID_P=9) + + INTEGER(i_kind),intent(in) :: numsao + real(r_single), intent(in) :: OI(mxst_p) ! x location + real(r_single), intent(in) :: OJ(mxst_p) ! y location + INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(in) :: OWX(mxst_p) ! weather + real(r_single), intent(in) :: Oelvtn(mxst_p) ! elevation + real(r_single), intent(in) :: Odist(mxst_p) ! distance from the nearest station + +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height +! + REAL(r_single),intent(in) :: watericemax(mxst_p) ! max of background total liquid water in station + INTEGER(i_kind),intent(in):: kwatericemax(nlon,nlat) ! lowest level of background total liquid water in grid +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) + integer(i_kind),intent(inout) :: pcp_type_3d(nlon,nlat,nsig) + real (r_single),intent(inout) :: vis2qc(nlon,nlat) +! +! local +! + real (r_single) :: cloud_zthick_p + data cloud_zthick_p /300._r_kind/ +! + REAL (r_kind) :: spval_p + PARAMETER ( spval_p = 99999.0_r_kind ) + + INTEGER(i_kind) :: i,j,k + INTEGER(i_kind) :: i1,j1,ic + INTEGER(i_kind) :: nx_p, ny_p, nztn_p + INTEGER(i_kind) :: ista + INTEGER(i_kind) :: ich !, iob,job + + REAL(r_kind) :: min_dist !, dist + REAL(r_kind) :: zdiff + REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav +! +! +! + real(r_single):: tbk_k(nlon,nlat,nsig) + real(r_single):: cv_bk(nlon,nlat,nsig) + real(r_single):: z_lcl(nlon,nlat) + REAL(r_kind) :: cf_model_base,t_model_base, ht_base + REAL(r_kind) :: t_dry_adiabat,t_inversion_strength + + LOGICAL :: l_cf,l_inversion + LOGICAL :: if_cloud_exist + + integer(i_kind) :: firstcloud,cl_base_broken_k + real(r_single) :: underlim + integer(i_kind) :: npts_near_clr + + +!==================================================================== +! Begin +! +! set constant names consistent with original RUC code +! + nx_p=nlon + ny_p=nlat + nztn_p=nsig + + vis2qc=-9999.0_r_kind + npts_near_clr=0 + zlev_clr = 3650. +! +! +!***************************************************************** +! analysis of surface/METAR cloud observations +! ***************************************************************** + + loopstation: DO ista=1,numsao + i1 = int(oi(ista)+0.0001_r_kind) + j1 = int(oj(ista)+0.0001_r_kind) + min_dist = Odist(ista) + +!mh - grid point has the closest cloud station + +! -- find out if any precip is present + do ich=1,1 + if ( owx(ista)(ich:ich+1)=='SH' ) wthr_type(i1,j1)=16 + if ( owx(ista)(ich:ich+1)=='TH' .and. & + min_dist < thunderRadius) wthr_type(i1,j1)=1 + if ( owx(ista)(ich:ich+1)=='RA' ) wthr_type(i1,j1)=11 + if ( owx(ista)(ich:ich+1)=='SN' ) wthr_type(i1,j1)=12 + if ( owx(ista)(ich:ich+1)=='PL' ) wthr_type(i1,j1)=13 + if ( owx(ista)(ich:ich+1)=='DZ' ) wthr_type(i1,j1)=14 + if ( owx(ista)(ich:ich+1)=='UP' ) wthr_type(i1,j1)=15 + if ( owx(ista)(ich:ich+1)=='BR' ) wthr_type(i1,j1)=21 + if ( owx(ista)(ich:ich+1)=='FG' ) wthr_type(i1,j1)=22 + enddo + +! Consider clear condition case +! ----------------------------- + if (ocld(1,ista)==0) then + + do ic=1,6 + if(float(abs(ocld(6+ic,ista))) < 55555) then + write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' + write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' + write(6,*) 'cloudCover_Surface: check the station no.', ista, 'at process ', mype + write(6,*) ic,OI(ista),OJ(ista) + write(6,*) (ocld(k,ista),k=1,12) + cycle loopstation + endif + enddo +! clean the whole column up to ceilometer height (12 kft) if ob is CLR +! h_bk is AGL, not ASL (per Ming Hu's notes below +! +! zlev_clr = Oelvtn(ista)+3650. +! Upcoming mods commented out below for this commit - 4/3/2010 +! PH: added in column cleaning up to ceilometer height if ob is CLR +! move this check out of this if block. Because it will be used later. +! zlev_clr = 3650. + + do k=1,nztn_p + if (h_bk(i1,j1,k) < zlev_clr) then + cld_cover_3d(i1,j1,k)=0.0_r_kind + pcp_type_3d(i1,j1,k)=0 + endif + end do + + wthr_type(i1,j1)=0 + +! -- Now consider non-clear obs +! -------------------------- + else + +! increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) + cloud_dz = cloud_zthick_p + cl_base_broken_k = -9 +! ????? check with Stan O(h_p) if (Oelvtn(ista).lt.900.) cloud_dz = cloud_zthick_p * 2 + + do ic = 1,6 + if (ocld(ic,ista)>0 .and. ocld(ic,ista)<50) then +! if ( csza(i,j)>=0.10 .and. sat_ctp(i1,j1)>1010.0 & +! .and. sat_ctp(i1,j1)<1050.) go to 1850 +! +! New tweak - 11/07/2009 +! If there was cloud in background over station but if there +! was partial cloudiness within volume and this is one of the +! clear columns within the polygonal area for this METAR, +! then leave it that way and skip. +! if (watericemax(iob,job).gt.0. .and. +! 1 kwatericemax(iob,job).gt.0 .and. +! 1 kwatericemax(iob,job).le.12) then +! npts_cld_match = npts_cld_match + 1 +! dzbase = cl_base_ista - g3(iob,job,kwatericemax(iob,job),h_p) +! sum_dzbase = sum_dzbase + dzbase +! sum_dzbase_abs = sum_dzbase_abs + abs(dzbase) +! end if + +! mhu, Aug. 28, 2013: comment out patial cloudiness. It causes the degradation +! in 3000' ceiling 1-h forecast. +! if(watericemax(ista) > 0._r_single .and. kwatericemax(i1,j1)==-1) then +! !PH 2/28/2013: ensure cloud building at 4 neighboring +! !gridpoints (Odist < 1), regardless of background +! if(Odist(ista) >= 1.0_r_kind) then +! npts_near_clr = npts_near_clr + 1 +! cycle ! skip cloud build at point (i,j) because +! ! background is clear +! endif +! endif + + if(ocld(ic,ista) == 4) then + if(wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) cloud_dz = 1000._r_kind + ! precipitation + highest level + if(wthr_type(i1,j1) == 1) cloud_dz = 10000._r_kind ! thunderstorm + endif + +! --- calculate cloud ceiling level, not exactly, FEW SCT are also considered now +! iob = int(oi(ista)-idw+0.5) +! job = int(oj(ista)-ids+0.5) +! cl_base_ista = (float(ocld(6+ic,ista))+zh(iob,job)) +! cl_base_ista = (float(ocld(6+ic,ista))+Oelvtn(ista)) +! the h_bk is AGL. So observation cloud base should be AGL too, delete Oelvtn(ista) +! cover cloud base observation from AGL to ASL + cl_base_ista = float(ocld(6+ic,ista)) + Oelvtn(ista) - zh(i1,j1) + if(zh(i1,j1) < 1.0_r_kind .and. Oelvtn(ista) > 20.0_r_kind & + .and. float(ocld(6+ic,ista)) < 250.0_r_kind) then + cycle ! limit the use of METAR station over oceas for low cloud base + endif + + firstcloud = 0 + underlim = 10._r_kind ! + + do k=1,nztn_p + zdiff = cl_base_ista - h_bk(i1,j1,k) +! Must be within cloud_dz meters (300 or 1000 currently) +! ------------------------------------------------------------------- +! -- Bring in the clouds if model level is within 10m under cloud level. + if(k==1) underlim=(h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.5_r_kind + if(k==2) underlim=10.0_r_kind ! 100 feet + if(k==3) underlim=20.0_r_kind ! 300 feet + if(k==4) underlim=15.0_r_kind ! 500 feet + if(k==5) underlim=33.0_r_kind ! 1000 feet + if (k>=6 .and. k <= 7) underlim = (h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.6_r_kind + if(k==8) underlim=95.0_r_kind ! 3000 feet + if(k>=9 .and. k= 1.0 .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type(i1,j1) < 20) then +! cld_type_3d(i1,j1,k)=5 + pcp_type_3d(i1,j1,k)=1 + endif + else + write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' + cycle loopstation + endif + endif + firstcloud = firstcloud + 1 + end if ! zdiff < cloud_dz + else +! ---- Clear up to cloud base of first cloud level + if (ic==1) cld_cover_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 1) pcp_type_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 3 .or. ocld(ic,ista) == 4) then + if( (wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) & + .or. wthr_type(i1,j1) == 1 ) then + pcp_type_3d(i1,j1,k)=1 + endif + endif + end if ! underlim + end do ! end K loop +! ----clean cloud above stratusphere + do k=1,nztn_p + if( h_bk(i1,j1,k) > 18000 ) cld_cover_3d(i1,j1,k)=0 + enddo +! + end if ! end if ocld > 0 + end do ! end IC loop +! +! clean up to broken (3) or if cloud cover less than 2, clean to cloud top +! + if(cl_base_broken_k > 0 .and. cl_base_broken_k < nztn_p) then + do k=1, cl_base_broken_k + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + enddo + else + if(ocld(1,ista) == 1 .or. ocld(1,ista) == 2 ) then + do k=1, nztn_p + if (h_bk(i1,j1,k) < zlev_clr) then + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + endif + enddo + endif + endif + + end if ! end if cloudy ob ocld(1,ista) > 0 + +! -- Use visibility for low-level cloud whether + if (wthr_type(i1,j1) < 30 .and. wthr_type(i1,j1) > 20 .and. & + ocld(13,ista) < 5000 .and. ocld(13,ista) > 1 .and. & + min_dist < 20.0_r_single) then + cld_type_3d(i1,j1,1) = 2 + cld_type_3d(i1,j1,2) = 2 + betav = 3.912_r_kind / (float(ocld(13,ista)) / 1000._r_kind) + vis2qc(i1,j1) = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind + endif ! cloud or clear + + ENDDO loopstation ! ista + + +! Determine if the layer is dry or it has inversion. +! (in either case, the cloud will be cleared out) +! + IF(.false.) THEN ! Set inversion strength flag + call BckgrndCC(nlon,nlat,nsig, & + t_bk,p_bk,q,h_bk,zh, & + cv_bk,tbk_k,z_lcl) ! out + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + + if_cloud_exist=.false. + do k=nsig-1,2,-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + cf_model_base = cv_bk(i,j,k) + t_model_base = tbk_k(i,j,k) + ht_base=h_bk(i,j,k) + if_cloud_exist=.true. + endif + enddo +! +! note, do we need to consider cloud base from background + if(if_cloud_exist) then + do k=2, nsig-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + l_cf=.false. + l_inversion=.false. + t_dry_adiabat = tbk_k(i,j,2) -.0098_r_kind * (h_bk(i,j,k) - h_bk(i,j,2)) + t_inversion_strength = tbk_k(i,j,k) - t_dry_adiabat + + IF( (tbk_k(i,j,k) > t_model_base) .and. & + (tbk_k(i,j,k) > 283.15_r_kind) .and. & ! temp check + (t_inversion_strength > 4._r_kind) ) then ! delta theta chk + l_inversion = .true. ! Inversion exists + endif + IF( (cv_bk(i,j,k) < cf_model_base - 0.3_r_kind) .and. & + (h_bk(i,j,k) - ht_base >= 500._r_kind) ) THEN + l_cf = .true. ! Dry layer exists + ENDIF + if(l_inversion) then + cld_cover_3d(i,j,k) =0.0_r_kind + endif + endif ! in cloud + enddo ! k + endif ! if_cloud_exist = true + + ENDDO ! i + ENDDO ! j + + END IF ! .true. for dry-inversion check. + +END SUBROUTINE cloudCover_Surface + diff --git a/src/GSD/gsdcloud/cloudCover_radar.f90 b/src/GSD/gsdcloud/cloudCover_radar.f90 new file mode 100644 index 0000000000..97be8759c5 --- /dev/null +++ b/src/GSD/gsdcloud/cloudCover_radar.f90 @@ -0,0 +1,131 @@ +SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,grid_ref, & + cld_cover_3d,wthr_type) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_radar cloud cover analysis using radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine find cloud cover using radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! grid_ref - radar reflectivity in analysis grid +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig+1) ! height +! +! Observation +! + real(r_kind), intent(in) :: grid_ref(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! + REAL(r_kind) :: ref_base ! "significant" radar echo at upper levels +! + REAL(r_kind) :: cloud_base +! +!----------------------------------------------------------- +! +! threshold +! + + REAL(r_kind) :: radar_cover + PARAMETER(radar_cover=1.02) + REAL(r_kind) :: thresh_cvr ! lower radar echo threshold for cloud filling + PARAMETER (thresh_cvr = 0.9) +! +! temp. +! + INTEGER(i_kind) :: i,j,k + REAL(r_kind) :: zs_1d(nsig) + +! +!==================================================================== +! Begin +! + ref_base = 10.0 +! +!----------------------------------------------------------------------- +! +! Essentially, this go downward to detect radar tops in time +! to search for a new cloud base +! +!----------------------------------------------------------------------- +! + + DO i = 2,nlon-1 + DO j = 2,nlat-1 + + DO k=1,nsig + zs_1d(k) = h_bk(i,j,k) + END DO + + cloud_base = 200000._r_kind +! + DO k = nsig-1,1,-1 + IF( (cld_cover_3d(i,j,k) < thresh_cvr) .and. & + (cld_cover_3d(i,j,k+1) >= thresh_cvr .and. & + cld_cover_3d(i,j,k+1) < 2.0_r_kind) ) THEN + cloud_base = 0.5_r_kind * (zs_1d(k) + zs_1d(k+1)) + END IF + END DO ! k + + + DO k = 2, nsig-1 + if(grid_ref(i,j,k) > ref_base ) then + if( zs_1d(k) > cloud_base .and. cld_cover_3d(i,j,k) < thresh_cvr ) then + cld_cover_3d(i,j,k)=radar_cover + endif + endif + ENDDO ! k + + ENDDO ! i + ENDDO ! j +! + +END SUBROUTINE cloudCover_radar + diff --git a/src/GSD/gsdcloud/cloudLWC.f90 b/src/GSD/gsdcloud/cloudLWC.f90 new file mode 100644 index 0000000000..92c908b73b --- /dev/null +++ b/src/GSD/gsdcloud/cloudLWC.f90 @@ -0,0 +1,419 @@ +SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_stratiform find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt + real(r_single) :: p_pa_1d(nsig), thv(nsig) + real(r_single) :: cloudqvis(nlon,nlat,nsig) + real(r_single) :: rh(nlon,nlat,nsig) + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice + + real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio + real(r_single) auto_conver + real(r_single) rh_clear_p + data Cloud_q_qvis_rat_p/ 0.05_r_single/ + data auto_conver /0.0002_r_single/ + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) stab, stab_threshold + INTEGER(i_kind) :: kp3,km3 + + REAL(r_kind) :: q, Temp, tv, evs, qvs1, eis, qvi1, watwgt, qavail +! +!==================================================================== +! Begin +! + cldwater_3d=-99999.9_r_kind + cldice_3d=-99999.9_r_kind + cloudtmp_3d=-99999.9_r_kind +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + rh=0.0 + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 2,nsig-1 + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + q = q_bk(i,j,k)/(1._r_single+q_bk(i,j,k)) ! Q = water vapor specific humidity + ! q_bk = water vapor mixing ratio + tv = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp +! now, tmperature from GSI s potential temperature + Temp = tv ! temperature +! evs, eis in mb + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line +! qvs1 = qvs1/(1.0-qvs1) + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloudtmp_3d(i,j,k)= Temp + cloudqvis(i,j,k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) +! qvis(i,j,k)= (watwgt*qvs1 + (1.-watwgt)*qvi1) + rh(i,j,k) = q_bk(i,j,k)/cloudqvis(i,j,k) + enddo + enddo ! i + enddo ! j + + stab_threshold = 3._r_kind/10000._r_kind + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_kind + thv(k) = t_bk(i,j,k)*(1.0_r_kind + 0.6078_r_kind*q_bk(i,j,k)) + ENDDO + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + DO k = kb,kt + +! -- change these to +/- 3 vertical levels + kp3 = min(nsig,k+5) + km3 = max(1 ,k) + stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) + +! -- stability check. Use 2K/100 mb above 600 mb and +! 3K/100mb below (nearer sfc) + if ((stab600._r_kind) & + .or. stab<0.66_r_kind*stab_threshold ) then +! write(*,'(a,3i4,f8.3)') 'skip building cloud in stable layer',i,j,k,stab*10000.0 + cld_cover_3d(i,j,k)=-99999.0 + elseif(rh(i,j,k) < 0.40 .and. ((cloudqvis(i,j,k)-q_bk(i,j,k)) > 0.003_r_kind)) then +! write(*,'(a,3i4,2f6.2)') 'skip building cloud in too-dry layer',i,j,k,& +! rh(i,j,k),(cloudqvis(i,j,k)-q_bk(i,j,k))*1000.0 + cld_cover_3d(i,j,k)=-99999.0_r_single + else +!dk * we need to avoid adding cloud if sat_ctp is lower than 650mb +! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio +! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 + Temp = cloudtmp_3d(i,j,k) +! watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& +! (temp_qvis1-temp_qvis2))) +! sgb - 1/13/2017 - change to discrete change from building water cloud or ice +! cloud (at temp_qvis2) + if (temp >= temp_qvis2) then + watwgt = 1. + cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p + qavail = min(0.25_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) + else + watwgt = 0. + cloud_q_qvis_ratio = 0.1*cloud_q_qvis_rat_p + qavail = min(0.1_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) + endif +! qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) +! change cloud water from 0.5 g/kg to 0.25 g/kg + +! ------------------------------------------------------------------- +! - set cloud water mixing ratio - no more than 0.1 g/kg, +! which is the current autoconversion mixing ratio set in exmoisg +! according to John Brown - 14 May 99 +! ------------------------------------------------------------------- + cldwater_3d(i,j,k) = watwgt*qavail*1000.0_r_kind ! g/kg +! - set ice mixing ratio + cldice_3d(i,j,k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg +! end if + end if + enddo ! k + enddo ! ilvl + endif ! nlvl > 1 + enddo ! i + enddo ! j + +END SUBROUTINE cloudLWC_stratiform + +SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d,cloudtmp_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_Cumulus find cloud liquid water content for cumulus cloud +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates liquid water content for cumulus cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D height +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! cloudtmp_3d - 3D cloud temperature +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real (r_single) :: zs_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_pa_1d(nsig) + real (r_single) :: p_mb_1d(nsig) + real (r_single) :: cld_base_m, cld_top_m + real (r_single) :: cld_base_qc_m, cld_top_qc_m + + real (r_single) :: slwc_1d(nsig) + real (r_single) :: cice_1d(nsig) + real (r_single) :: ctmp_1d(nsig) + + LOGICAL :: l_prt + INTEGER(i_kind) :: iflag_slwc +! +!==================================================================== +! Begin +! + l_prt =.false. + iflag_slwc = 11 + cldwater_3d=-99999.9_r_single + cldice_3d =-99999.9_r_single + cloudtmp_3d=-99999.9_r_single +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + zs_1d(k) = h_bk(i,j,k) + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + cld_base_m = 0.5_r_single * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = 0.5_r_single * (zs_1d(kt) + zs_1d(kt+1)) +! + IF(iflag_slwc /= 0) THEN + IF(iflag_slwc < 10) THEN ! simple adiabatc scheme + CALL get_slwc1d (nsig,cld_base_m,cld_top_m,kb,kt & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + + ELSE ! iflag_slwc > 10, new Smith-Feddes scheme + DO k1 = 1,nsig ! Initialize + slwc_1d(k1) = 0.0_r_single + cice_1d(k1) = 0.0_r_single + ctmp_1d(k1) = t_bk(i,j,k1) + END DO +! +!----------------------------------------------------------------------- +! +! QC the data going into SMF +! +!----------------------------------------------------------------------- +! + IF(cld_top_m > zs_1d(nsig-1) - 110._r_single) THEN + cld_top_qc_m = zs_1d(nsig-1) - 110._r_single + cld_base_qc_m = & + MIN(cld_base_m,cld_top_qc_m - 110._r_single) + ELSE ! normal case + cld_top_qc_m = cld_top_m + cld_base_qc_m = cld_base_m + END IF +! + CALL get_sfm_1d(nsig,cld_base_qc_m,cld_top_qc_m & + ,zs_1d,p_mb_1d,t_1d & + ,slwc_1d,cice_1d,ctmp_1d,l_prt) +! + END IF ! iflag_slwc < 10 + END IF ! iflag_slwc .ne. 0 +! + DO k1 = kb,kt ! Loop through the cloud layer + IF(iflag_slwc /= 0) THEN + IF(slwc_1d(k1) > 0._r_single) cldwater_3d(i,j,k1)=slwc_1d(k1) + IF(cice_1d(k1) > 0._r_single) cldice_3d(i,j,k1)=cice_1d(k1) + cloudtmp_3d(i,j,k1)=ctmp_1d(k1) + END IF ! iflag_slwc .ne. 0 + END DO ! k1 + + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudLWC_Cumulus diff --git a/src/GSD/gsdcloud/cloudLayers.f90 b/src/GSD/gsdcloud/cloudLayers.f90 new file mode 100644 index 0000000000..eb2d523968 --- /dev/null +++ b/src/GSD/gsdcloud/cloudLayers.f90 @@ -0,0 +1,167 @@ +SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & + cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLayers find cloud layers +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine find cloud layer based on cloud cover +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! zh - terrain +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! +! output argument list: +! cloudlayers_i - 3D cloud layer index +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind + + implicit none + + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) +! +! output +! + integer(i_kind),intent(out):: cloudlayers_i(nlon,nlat,21) ! 5 different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! threshold + real (r_single) :: thresh_cvr + parameter ( thresh_cvr = 0.1 ) +!----------------------------------------------------------- +! +! temp. +! + INTEGER :: i,j,k,nlvl + INTEGER :: k_top,k_base + real (r_single) :: zs_1d(nsig) + real (r_single) :: cv_1d(nsig) +! +!==================================================================== +! Begin +! + cloudlayers_i=-99999 +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! Initialize + DO k = 1,nsig + zs_1d(k) = h_bk(i,j,k) + cv_1d(k) = cld_cover_3d(i,j,k) + END DO +! +!----------------------------------------------------------------------- +! +! Get Base and Top +! +!----------------------------------------------------------------------- +! + k=1 + nlvl=0 + DO WHILE (k <= nsig-1) + + IF((cv_1d(k+1) >= thresh_cvr .and. cv_1d(k)= thresh_cvr) ) THEN + k_base = k + 1 + + k = k + 1 + DO WHILE (cv_1d(k) >= thresh_cvr .and. k < nsig) + k_top = k +! +!----------------------------------------------------------------------- +! +! We have now defined a cloud base and top +! +!----------------------------------------------------------------------- +! + k=k+1 + enddo + k=k-1 +!----------------------------------------------------------------------- +! +! Make sure cloud base and top stay in the model domain +! +!----------------------------------------------------------------------- +! + nlvl=nlvl+2 + if(nlvl > 20 ) then + write(6,*) 'cloudLayers: Too many cloud layers in grid point:' + write(6,*) i,j + call stop2(114) + endif + cloudlayers_i(i,j,nlvl) = MIN(k_base,nsig-1) + cloudlayers_i(i,j,nlvl+1) = MIN(k_top,nsig-1) + endif +! + k=k+1 + ENDDO ! k +! + cloudlayers_i(i,j,1) = nlvl/2 + ENDDO + ENDDO +! +! +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 + if(cloudlayers_i(i,j,1) > 0 ) then + do k=1,cloudlayers_i(i,j,1) + if(cloudlayers_i(i,j,k) < 0 .or. cloudlayers_i(i,j,k) > 55555) then + write(6,*) 'cloudLayers: ckeck', i,j,k, cloudlayers_i(i,j,k) + endif + enddo + endif + enddo + enddo +! + +END SUBROUTINE cloudLayers + diff --git a/src/GSD/gsdcloud/cloudType.f90 b/src/GSD/gsdcloud/cloudType.f90 new file mode 100644 index 0000000000..2b97e72509 --- /dev/null +++ b/src/GSD/gsdcloud/cloudType.f90 @@ -0,0 +1,147 @@ +SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudType decide cloud type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine decide cloud type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cld_type_3d - 3D cloud type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000, half + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN) :: nlat,nlon,nsig +! +! background +! + real(r_single),INTENT(IN) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! Variables for cloud analysis +! + real (r_single), INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind), INTENT(IN) :: wthr_type(nlon,nlat) + integer(i_kind),INTENT(OUT) :: cld_type_3d(nlon,nlat,nsig) +! +! cloud layers +! + integer(i_kind), INTENT(IN) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: itype + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: cld_base_m, cld_top_m + + real (r_single) :: zs_1d(nsig) + real (r_single) :: dte_dz_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_mb_1d(nsig) +! + CHARACTER (LEN=2) :: c2_type +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + return + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp !K + zs_1d(k) = h_bk(i,j,k) + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 10 ) then + write(*,*) 'warning: too many cloud levels' + nlvl=10 + endif + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + CALL get_stability (nsig,t_1d,zs_1d,p_mb_1d & + ,kb,kt,dte_dz_1d) + + cld_base_m = half * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = half * (zs_1d(kt) + zs_1d(kt+1)) + DO k1 = kb,kt + CALL get_cloudtype(t_1d(k1),dte_dz_1d(k1) & + ,cld_base_m,cld_top_m,itype,c2_type) +! + IF(radar_3d(i,j,k1) > 45._r_kind) THEN + itype = 10 ! CB + END IF + + cld_type_3d(i,j,k1) = itype + END DO !k1 + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudType + diff --git a/src/GSD/gsdcloud/cloud_saturation.f90 b/src/GSD/gsdcloud/cloud_saturation.f90 new file mode 100644 index 0000000000..70e6587b20 --- /dev/null +++ b/src/GSD/gsdcloud/cloud_saturation.f90 @@ -0,0 +1,335 @@ +SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & + nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,wthr_type, & + cldwater_3d,cldice_3d,sumqci,qv_max_inc) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloud_saturation to ensure water vapor saturation at all cloudy grid points +! also to ensure sub saturation in clear point +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2010-10-06 Hu check whole 3D mositure field and get rid of supersaturation +! 2009-01-20 Hu Add NCO document block +! 2017-04-13 Ladwig Add comments & theta-v conservation for missing obs case +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cldwater_3d - 3D analysis cloud water mixing ratio (g/kg) +! cldice_3d - 3D analysis cloud ice mixing ratio (g/kg) +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! l_conserve_thetaV - if .true. conserving thetaV +! i_conserve_thetaV_iternum - iteration number for conserving thetaV +! +! output argument list: +! q_bk - 3D moisture +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000,one,zero,fv + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig + logical,intent(in):: l_conserve_thetaV + integer(i_kind),intent(in):: i_conserve_thetaV_iternum +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) + REAL(r_kind),intent(in) :: sumqci(nlon,nlat,nsig) ! total liquid water + real(r_kind),intent(in) :: qv_max_inc ! max qv increment +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud water and cloud ice +! + real (r_single),intent(in) :: cldwater_3d(nlon,nlat,nsig) ! kg/kg + real (r_single),intent(in) :: cldice_3d(nlon,nlat,nsig) ! kg/kg +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k + real(r_single) :: cloudqvis,ruc_saturation + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud + + real(r_single) rh_cld3_p + real(r_single) rh_clear_p + data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + + INTEGER(i_kind) :: miter,nnn + + REAL(r_kind) :: constantTv, Temp + real(r_single) :: qtemp +! +!==================================================================== +! Begin +! +! + miter=i_conserve_thetaV_iternum ! iteration number for conserving Tv + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 2,nsig-1 + +!mhu p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single +! qv= q_bk(i,j,k)/(one+q_bk(i,j,k)) ! qv = water vapor specific humidity +! ! q_bk = water vapor mixing ratio +! now, tmperature from GSI s potential temperature. get temperature + Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + +! now, calculate saturation +! + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) +! +! moisture adjustment based on cloud +! +! +! check each grid point to make sure no supersaturation + q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! now, calculate constant virtual temperature + constantTv=Temp*(one + fv*q_bk(i,j,k)) +! + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! If valid cld_cover_3d + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if(cld_cover_3d(i,j,k) > -0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 2.0_r_kind) then + !############################################# + ! if clear ob + !############################################# + if(cld_cover_3d(i,j,k) <= 0.0001_r_kind) then + ! adjust RH to be below 85 percent(50%?) if + ! 1) cloudyn = 0 + ! 2) at least 100 mb above sfc + ! 3) no precip from sfc obs + !make sure that clear volumes are no more than rh_clear_p RH. + if( (sumqci(i,j,k))>1.0e-12_r_kind .and. & + (p_bk(i,j,1) - p_bk(i,j,k))>100._r_kind .and. & + wthr_type(i,j) <=0 ) then + if( q_bk(i,j,k) > cloudqvis * rh_clear_p) then + qtemp = cloudqvis * rh_clear_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_clear_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif + !C - moisten layers above and below cloud layer + if(cld_cover_3d(i,j,k+1) > 0.6_r_kind .or. & + cld_cover_3d(i,j,k-1) > 0.6_r_kind ) then + if( cloudqvis > q_bk(i,j,k) ) then + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif + !############################################# + ! -- If SCT/FEW present, reduce RH only down to rh_cld3_p (0.98) + ! corresponding with cloudyn=3 + !############################################# + elseif(cld_cover_3d(i,j,k) > 0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 0.6_r_kind ) then + if( q_bk(i,j,k) > cloudqvis * rh_cld3_p) then + qtemp = cloudqvis * rh_cld3_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_cld3_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + !############################################# + ! else: cld_cover_3d is > 0.6: cloudy case + !############################################# + else ! set qv at 102%RH + if( q_bk(i,j,k) < cloudqvis * 1.00_r_single ) then + qtemp = cloudqvis * 1.00_r_single + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * 1.00_r_single + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! cld_cover_3d is missing + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + else ! cloud cover is missing + ! Ensure saturation in all cloudy volumes. + ! Since saturation has already been ensured for new cloudy areas (cld_cover_3d > 0.6) + ! we now ensure saturation for all cloud 3-d points, whether cloudy from background + ! (and not changed - cld_cover_3d < 0) + ! If cloud cover is missing, (cldwater_3d(i,j,k)+cldice_3d(i,j,k) = sumqci(i,j,k), + ! which is background cloud liquid water. + if ((cldwater_3d(i,j,k)+cldice_3d(i,j,k))>1.0e-5_r_kind) then + !conserve + qtemp = cloudqvis * 1.00_r_single + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * 1.00_r_single + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + !limit increment + q_bk(i,j,k) = min(qtemp, q_bk(i,j,k)+qv_max_inc) + endif + endif +! +! check each grid point to make sure no supersaturation +! + q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! + + enddo ! k + enddo ! i + enddo ! j + +END SUBROUTINE cloud_saturation + +function ruc_saturation(Temp,pressure) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ruc_saturation calculate saturation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-11-28 +! +! ABSTRACT: +! This subroutine calculate saturation +! +! PROGRAM HISTORY LOG: +! 2011-11-28 Hu Initial +! +! +! input argument list: +! pressure - background pressure (hPa) +! Temp - temperature (K) +! +! output argument list: +! ruc_saturation +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ + + use constants, only: rd_over_cp, h1000,one,zero + use kinds, only: r_single,i_kind, r_kind +! + implicit none + real(r_single) :: ruc_saturation + + REAL(r_kind), intent(in) :: Temp ! temperature in K + real(r_single),intent(in) :: pressure ! pressure (hpa) + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) :: evs, qvs1, eis, qvi1, watwgt +! + +! +! evs, eis in mb +! For this part, must use the water/ice saturation as f(temperature) + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs/(pressure-evs) ! qvs1 is mixing ratio kg/kg + ! so no need next line +! qvs1 = qvs1/(1.0-qvs1) +! Get ice saturation and weighted ice/water saturation ready to go +! for ensuring cloud saturation below. + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis/(pressure-eis) ! qvi1 is mixing ratio kg/kg, + ! so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! watwgt = max(zero,min(one,(Temp-251.15_r_kind)/& +! (263.15_r_kind-251.15_r_kind))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(zero,min(one,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + ruc_saturation= (watwgt*qvs1 + (one-watwgt)*qvi1) ! kg/kg +! +end function ruc_saturation diff --git a/src/GSD/gsdcloud/configure b/src/GSD/gsdcloud/configure new file mode 100755 index 0000000000..bb10af0ac0 --- /dev/null +++ b/src/GSD/gsdcloud/configure @@ -0,0 +1,93 @@ +#!/bin/sh +# +# Creates configuration Makefile. Before attempting to make anything +# in this directory, enter +# +# ./configure +# +# !REVISION HISTORY +# +# 09oct97 da Silva Initial code. +# 19oct97 da Silva Simplified. +# 22oct97 Jing Guo Converted to libpsas.a environment +# - special configuration for CRAY +# - fool-prove configuration +# - additional information +# 23dec99 da Silva Modified error messages. +# +#..................................................................... + +set -x + +c=`basename $0 .sh` + +type=${1:-"unknown"} +echo $type + + +# If type=clean, remove soft links and exit +# ----------------------------------------- +if [ "$type" = "clean" ]; then + if [ -r makefile ]; then + echo "$c: remove makefile" 1>&2 + rm makefile + fi + if [ -r Makefile.conf ]; then + echo "$c: remove Makefile.conf" 1>&2 + rm Makefile.conf + fi + exit +fi + + +# Set makeconf based on user input +# --------------------------------------- +makeconf="Makefile.conf.$type" + + +# Node specific configuration +# --------------------------------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + makeconf="Makefile.conf.`uname -n | awk '{print $1}'`" +fi + +# Machine specific +# ---------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + machine="`uname -m | awk '{print $1}'`" + machine=`echo $machine | tr "[a-z]" "[A-Z]"` + compiler=$F90 + makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" + makeconf="${makeconf}.${machine}.${compiler}" +fi + +# Site specific configuration +# --------------------------- +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + makeconf="Makefile.conf.`uname -s | awk '{print $1}'`" +fi + +# if the OS is UNICOS, it does not follow the convention +# ------------------------------------------------------ +if [ ! -r ${makeconf} ]; then + echo "$c: cannot find ${makeconf} in `pwd`" 1>&2 + mech="`uname -m | awk '{print $1}'`" + if [ "${mech}" = CRAY ]; then + makeconf="Makefile.conf.UNICOS" + fi +fi + +# Create soft link for Makefile.conf +# ------------------------------------------------------ +if [ -r Makefile.conf ]; then + echo "$c: remove Makefile.conf" 1>&2 + rm Makefile.conf +fi +ln -s ${makeconf} Makefile.conf + +echo "$c: using ${makeconf} in `pwd`" 1>&2 + +#. diff --git a/src/GSD/gsdcloud/constants.f90 b/src/GSD/gsdcloud/constants.f90 new file mode 100755 index 0000000000..9d4263197e --- /dev/null +++ b/src/GSD/gsdcloud/constants.f90 @@ -0,0 +1,324 @@ +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-01-27 cucurull - add ione +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! 2007-03-20 rancic - add r3600 +! 2009-02-05 cucurull - modify refractive indexes for gpsro data +! +! Subroutines Included: +! sub init_constants_derived - compute derived constants +! sub init_constants - set regional/global constants +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_single,r_kind,i_kind,r_quad,i_long + implicit none + +! set default as private + private +! set subroutines as public + public :: init_constants_derived + public :: init_constants +! set passed variables to public + public :: one,two,ione,half,zero,izero,deg2rad,pi,three,quarter,one_tenth + public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav + public :: rd,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single + public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix + public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,epsq,climit,epsm1,hvap + public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 + public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 + public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass + public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis + public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 + public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong + +! Declare derived constants + integer(i_kind):: huge_i_kind + real(r_single):: tiny_single, huge_single + real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g + real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 + real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term + real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass + real(r_kind):: eccentricity, grav, rearth, r60inv + + +! Define constants common to global and regional applications + real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) + real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) + real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) + real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) + real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) + real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) + real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) + real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) + real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) + real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) + real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () + real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + integer(i_kind),parameter:: izero = 0_i_kind + integer(i_kind),parameter:: ione = 1_i_kind + + integer(i_long),parameter:: zero_ilong = 0_i_long + + real(r_single),parameter:: zero_single= 0.0_r_single + + real(r_kind),parameter:: zero = 0.0_r_kind + real(r_kind),parameter:: one_tenth = 0.10_r_kind + real(r_kind),parameter:: quarter = 0.25_r_kind + real(r_kind),parameter:: one = 1.0_r_kind + real(r_kind),parameter:: two = 2.0_r_kind + real(r_kind),parameter:: three = 3.0_r_kind + real(r_kind),parameter:: four = 4.0_r_kind + real(r_kind),parameter:: five = 5.0_r_kind + real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r1000 = 1000.0_r_kind + real(r_kind),parameter:: r3600 = 3600.0_r_kind + + real(r_quad),parameter:: zero_quad = 0.0_r_quad + real(r_quad),parameter:: one_quad = 1.0_r_quad + + +! Constants for gps refractivity (Bevis et al 1994) + real(r_kind),parameter:: n_a = 77.60_r_kind ! K/mb + real(r_kind),parameter:: n_b = 3.739e+5_r_kind ! K^2/mb + real(r_kind),parameter:: n_c = 70.4_r_kind ! K/mb + +! Parameters below from WGS-84 model software inside GPS receivers. + real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) + real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) + real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) + real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) + real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) + real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) + +! Derived geophysical constants + real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis + real(r_kind),parameter:: somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one + real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant + +! Derived thermodynamic constants + real(r_kind),parameter:: dldti = cvap-csol + real(r_kind),parameter:: hsub = hvap+hfus + real(r_kind),parameter:: psatk = psat*0.001_r_kind + real(r_kind),parameter:: tmix = ttp-20._r_kind + real(r_kind),parameter:: elocp = hvap/cp + real(r_kind),parameter:: rcp = one/cp + +! Constants used in GFS moist physics + real(r_kind),parameter:: h300 = 300._r_kind + real(r_kind),parameter:: half = 0.5_r_kind + real(r_kind),parameter:: cclimit = 0.001_r_kind + real(r_kind),parameter:: climit = 1.e-20_r_kind + real(r_kind),parameter:: epsq = 2.e-12_r_kind + real(r_kind),parameter:: h1000 = r1000 + real(r_kind),parameter:: rhcbot=0.85_r_kind + real(r_kind),parameter:: rhctop=0.85_r_kind + real(r_kind),parameter:: dx_max=-8.8818363_r_kind + real(r_kind),parameter:: dx_min=-5.2574954_r_kind + real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) + real(r_kind),parameter:: c0=0.002_r_kind + real(r_kind),parameter:: delta=0.6077338_r_kind + real(r_kind),parameter:: pcpeff0=1.591_r_kind + real(r_kind),parameter:: pcpeff1=-0.639_r_kind + real(r_kind),parameter:: pcpeff2=0.0953_r_kind + real(r_kind),parameter:: pcpeff3=-0.00496_r_kind + real(r_kind),parameter:: cmr = one/0.0003_r_kind + real(r_kind),parameter:: cws = 0.025_r_kind + real(r_kind),parameter:: ke2 = 0.00002_r_kind + real(r_kind),parameter:: row = r1000 + real(r_kind),parameter:: rrow = one/row + +! Constant used to process ozone + real(r_kind),parameter:: constoz = 604229.0_r_kind + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind + real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind + +! Constants used for variational qc + real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +contains + + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! +! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! 2008-06-04 safford - rm unused vars +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(izero) + r60inv=one/r60 + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + + logical,intent(in ) :: regional + + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + rd_over_cp_mass = rd / cp_mass + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= zero + rd_over_cp_mass = zero + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + +end module constants diff --git a/src/GSD/gsdcloud/convert_lghtn2ref.f90 b/src/GSD/gsdcloud/convert_lghtn2ref.f90 new file mode 100644 index 0000000000..b4acdb89d3 --- /dev/null +++ b/src/GSD/gsdcloud/convert_lghtn2ref.f90 @@ -0,0 +1,197 @@ +SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-17 +! +! ABSTRACT: +! This subroutine converts lightning stroke rate to radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D reflectivity in analysis grid +! lightning - 2D lightning flash rate in analysis grid +! h_bk - 3D height +! +! output argument list: +! ref_mos_3d - 3D reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single), intent(in) :: lightning(nlon,nlat) + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: dbz_lightning(nlon,nlat) + real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_winter/ & + 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & + 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & + 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ + + real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_summer/ & + 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & + 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & + 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ + + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,1) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,2) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,3) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,4) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,1) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,2) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,3) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,4) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + INTEGER(i_kind) :: num_lightning + INTEGER(i_kind) :: i,j, k2, k, mref + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl + REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) + + +! +! map lightning strokes to maximum reflectiivty +! + season=1 + dbz_lightning = -9999.0_r_kind + DO j=2,nlat-1 + DO i=2,nlon-1 + if(lightning(i,j) > 0.1_r_kind ) then + num_lightning = max(1,min(30,int(lightning(i,j)))) + if(season== 2 ) then + dbz_lightning(i,j) = table_lghtn2ref_winter(num_lightning) + else if(season== 1 ) then + dbz_lightning(i,j) = table_lghtn2ref_summer(num_lightning) + endif + endif + ENDDO + ENDDO +! +! vertical reflectivity distribution +! + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO + +! ref_mos_3d=-9999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + if( dbz_lightning(i,j) > 30 ) then + mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref=(1-wght)*downref + wght*upref + ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) + endif + ENDDO + endif + ENDDO + ENDDO + +END SUBROUTINE convert_lghtn2ref diff --git a/src/GSD/gsdcloud/get_sfm_1d_gnl.f90 b/src/GSD/gsdcloud/get_sfm_1d_gnl.f90 new file mode 100644 index 0000000000..c94e50716b --- /dev/null +++ b/src/GSD/gsdcloud/get_sfm_1d_gnl.f90 @@ -0,0 +1,384 @@ +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: get_sfm_1d_gnl +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate liquid water content for convection cloud +! This subroutine is from ARPS cloud analysis package +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d_gnl (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER :: nz ! number of model vertical levels + REAL :: zs_1d(nz) ! physical height (m) at each scalar level + REAL :: p_mb_1d(nz) ! pressure (mb) at each level + REAL :: t_1d(nz) ! temperature (K) at each level + + REAL :: zcb ! cloud base height (m) + REAL :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL :: ql(nz) ! liquid water content (g/kg) + REAL :: qi(nz) ! ice water content (g/kg) + REAL :: cldt(nz) +! +! LOCAL: + REAL :: calw(200) + REAL :: cali(200) + REAL :: catk(200) + REAL :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL :: c,a1,b1,c1,a2,b2,c2 + REAL :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL :: arg,fraclw,tlwc + REAL :: temp,press,zbase,alw,zht,ht,y + REAL :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER :: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL :: zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0 + cali(i)=0.0 + END DO +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0 ! m + rv=461.5 ! J/deg/kg + rair=287.04 ! J/deg/kg + grav=9.81 ! m/s2 + cp=1004. ! J/deg/kg + rlvo=2.5003E+6 ! J/kg + rlso=2.8339E+6 ! J/kg + dlvdt=-2.3693E+3 ! J/kg/K + eso=610.78 ! pa + c=0.01 + a1=8.4897 + b1=-13.2191 + c1=4.7295 + a2=10.357 + b2=-28.2416 + c2=8.8846 +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2. + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0 + zbase = zcb + nlevel = ((zctop-zcb)/100.0)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0 + calw(1)= 0.0 + cali(1)= 0.0 + catk(1)= temp + entr(1)= 1.0 + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) + + IF(l_prt) THEN + WRITE(6,605) j,zht,temp,press,1000.0*qvs1,es,rl + 605 FORMAT('get_sfm_1d_gnl:',1X,i2,' ht=',f8.0,' T=',f6.1,' P=',f9.1,' qvs=', & + f7.3,' es=',f6.1,' Lv=',e10.3) + END IF +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0+0.621*es*rl/(press*rair*temp))/ & + (cp+0.621*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw + + IF (l_prt) THEN + WRITE(6,9015) j,1000.0*calw(j+1),zht + 9015 FORMAT('get_sfm_1d_gnl',1X,'j=',i3,' adiab.lwc =',f7.3,' alt =',f8.0) + END IF +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001 +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032) THEN + y = -11.0*ht+1.0 ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177) THEN + y = -1.4*ht+0.6915 ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726) THEN + y = -0.356*ht+0.505 ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5) THEN + y = -0.0608*ht+0.2912 ! y(ht=1.5) = 0.2 + ELSE + y = 0.20 + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15) THEN + IF(temp > 248.15) THEN + fraclw=0.05*(temp-248.15) + ELSE + fraclw=0.0 + END IF + ELSE + fraclw=1.0 + END IF + + tlwc=1000.*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1.-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Alternative calculation procedure using the observed or +! inferred in cloud temperature profile +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0 + qi(ip)=0.0 + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100.)*(calw(j)-calw(j-1))*0.01 & + +calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100.)*(cali(j)-cali(j-1))*0.01 & + +cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100.)*(catk(j)-catk(j-1))*0.01 & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100.)*(entr(j)-entr(j-1))*0.01 & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Write out file of lwc comparisons +! +!----------------------------------------------------------------------- +! + RETURN +END SUBROUTINE get_sfm_1d_gnl diff --git a/src/GSD/gsdcloud/hydro_mxr_thompson.f90 b/src/GSD/gsdcloud/hydro_mxr_thompson.f90 new file mode 100644 index 0000000000..af7a7a44e1 --- /dev/null +++ b/src/GSD/gsdcloud/hydro_mxr_thompson.f90 @@ -0,0 +1,196 @@ +SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs_3d, istatus, mype ) +! +! PURPOSE: +! Calculate (1) snow mixing ratio, (2) rain mixing ratio, and (3) rain number concentration +! from reflectivity for Thompson microphysics scheme. A Marshall-Palmer drop-size distribution +! is assumed for rain. +! +! HISTORY: +! 2013-01-30: created by David Dowell, Greg Thompson, Ming Hu +! +! ACKNOWLEDGMENTS: +! Donghai Wang and Eric Kemp (code template from pcp_mxr_ferrier) +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration (/kg) +! qs_3d - snow mixing ratio (g/kg) +! istatus - +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single, i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz) ! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow mixing ratio (g/kg) + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio (g/kg) + REAL(r_single),intent(out) :: qnr_3d(nx,ny,nz) ! rain number concentration (/kg) +! +! PARAMETERS: + REAL(r_kind), PARAMETER :: min_ref = 0.0_r_kind ! minimum reflectivity (dBZ) for converting to qs and qr + REAL(r_kind), PARAMETER :: max_ref_snow = 28.0_r_kind ! maximum reflectivity (dBZ) for converting to qs + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: max_ref_rain = 55.0_r_kind ! maximum reflectivity (dBZ) for converting to qr + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: n0r_mp = 8.0e6_r_kind ! Marshall-Palmer intercept parameter for rain (m**-4) + REAL(r_kind), PARAMETER :: rd= 287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: am_s = 0.069_r_kind + REAL(r_kind), PARAMETER :: bm_s = 2.0_r_kind + REAL(r_kind), PARAMETER :: PI = 3.1415926536_r_kind + REAL(r_kind), PARAMETER :: rho_i = 890.0_r_kind + REAL(r_kind), PARAMETER :: rho_w = 1000.0_r_kind +! +! LOCAL VARIABLES: + INTEGER(i_kind) :: i,j,k + REAL(r_kind) :: rho ! air density (kg m**-3) + REAL(r_kind) :: zes ! reflectivity (m**6 m**-3) associated with snow + REAL(r_kind) :: zer ! reflectivity (m**6 m**-3) associated with rain + REAL(r_kind) :: tc ! temperature (Celsius) + REAL(r_kind) :: rfract ! rain fraction + REAL(r_kind) :: tc0 + REAL(r_kind) :: f + REAL(r_kind) :: loga_ + REAL(r_kind) :: a_ + REAL(r_kind), PARAMETER :: a_min = 1.0e-5_r_kind ! lower bound for a_, to avoid large mixing ratios retrieved + ! for tiny particles sizes in cold temperatures + REAL(r_kind) :: b_ + REAL(r_kind) :: sa(10) + REAL(r_kind) :: sb(10) + REAL(r_kind) :: cse(3) + REAL(r_kind) :: crg(4) + REAL(r_kind) :: am_r + REAL(r_kind) :: oams + REAL(r_kind) :: qs ! snow mixing ratio in kg / kg + REAL(r_kind) :: qr ! rain mixing ratio in kg / kg +! +! for snow moments conversions (from Field et al. 2005) + DATA sa / 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/ + DATA sb / 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/ + +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + istatus=0 + + f = (0.176_r_kind/0.93_r_kind) * (6.0_r_kind/PI)*(6.0_r_kind/PI) * (am_s/rho_i)*(am_s/rho_i) + cse(1) = bm_s + 1.0_r_kind + cse(2) = bm_s + 2.0_r_kind + cse(3) = bm_s * 2.0_r_kind + oams = 1.0_r_kind / am_s + + crg(1) = 24.0_r_kind + crg(2) = 1.0_r_kind + crg(3) = 24.0_r_kind + crg(4) = 5040.0_r_kind + am_r = PI * rho_w / 6.0_r_kind + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + + IF (ref_3d(i,j,k) >= min_ref) THEN + + rho = p_3d(i,j,k) / (rd*t_3d(i,j,k)) + tc = t_3d(i,j,k) - 273.15_r_kind + + IF (tc <= 0.0_r_kind) THEN + rfract = 0.0_r_kind + ELSE IF (tc >= 5.0_r_kind) THEN + rfract = 1.0_r_kind + ELSE + rfract = 0.20_r_kind*tc + ENDIF + + zes = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_snow) ) ) & + * (1.0_r_kind-rfract) & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + zer = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_rain) ) ) & + * rfract & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + tc0 = MIN(-0.1, tc) + IF (bm_s.lt.(1.999_r_kind) .or. bm_s.gt.(2.001_r_kind)) THEN + PRINT*, 'ABORT (hydro_mxr_thompson): bm_s = ', bm_s + STOP + ENDIF + + ! Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & + + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & + + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & + + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(3)*cse(3)*cse(3) + a_ = max( 10.0_r_kind ** loga_, a_min ) + b_ = sb(1) + sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & + + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & + + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + + qs = ( (zes / (f*a_)) ** (1.0_r_kind / b_) ) / (rho*oams) + qs_3d(i,j,k) = 1000.0_r_kind * qs ! convert from kg / kg to g / kg + + qr = n0r_mp * am_r * crg(3) / rho * (zer / (n0r_mp*crg(4)))**(4.0_r_kind/7.0_r_kind) + qnr_3d(i,j,k) = (n0r_mp/rho)**(3.0_r_kind/4.0_r_kind) & + * (qr / (am_r * crg(3)))**(1.0_r_kind/4.0_r_kind) + + qnr_3d(i,j,k) = max(1.0_r_kind, qnr_3d(i,j,k)) + qr_3d(i,j,k) = 1000.0_r_kind * qr ! convert from kg / kg to g / kg + + +! if(mype==51 ) then +! write(*,'(a10,3i5,2f10.5,3f8.2)') 'b=',i,j,k,qs_3d(i,j,k),qr_3d(i,j,k),ref_3d(i,j,k),& +! p_3d(i,j,k)/100.0,tc +! endif + + + ELSE + + qs_3d(i,j,k) = -999._r_kind + qr_3d(i,j,k) = -999._r_kind + qnr_3d(i,j,k) = -999._r_kind + + END IF + + END DO ! k + END DO ! i + END DO ! j +! +! PRINT*,'finish hydro_mxr_thompson...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE hydro_mxr_thompson diff --git a/src/GSD/gsdcloud/kinds.f90 b/src/GSD/gsdcloud/kinds.f90 new file mode 100755 index 0000000000..73fbe3b568 --- /dev/null +++ b/src/GSD/gsdcloud/kinds.f90 @@ -0,0 +1,105 @@ +module kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 2 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module kinds diff --git a/src/GSD/gsdcloud/make.dependencies b/src/GSD/gsdcloud/make.dependencies new file mode 100644 index 0000000000..11a2075f69 --- /dev/null +++ b/src/GSD/gsdcloud/make.dependencies @@ -0,0 +1,33 @@ +kinds.o : kinds.f90 +constants.o : constants.f90 kinds.o + +ARPS_cldLib.o : ARPS_cldLib.f90 kinds.o constants.o +BackgroundCld.o : BackgroundCld.f90 kinds.o constants.o +BckgrndCC.o : BckgrndCC.f90 kinds.o constants.o +CheckCld.o : CheckCld.f90 kinds.o constants.o +radar_ref2tten.o : radar_ref2tten.f90 kinds.o constants.o +PrecipMxr_radar.o : PrecipMxr_radar.f90 kinds.o constants.o +PrecipType.o : PrecipType.f90 kinds.o constants.o +TempAdjust.o : TempAdjust.f90 kinds.o constants.o +adaslib.o : adaslib.f90 kinds.o constants.o +build_missing_REFcone.o : build_missing_REFcone.f90 kinds.o constants.o +cloudCover_NESDIS.o : cloudCover_NESDIS.f90 kinds.o constants.o +cloudCover_Surface.o : cloudCover_Surface.f90 kinds.o constants.o +cloudCover_radar.o : cloudCover_radar.f90 kinds.o constants.o +cloudLWC.o : cloudLWC.f90 kinds.o constants.o +cloudLayers.o : cloudLayers.f90 kinds.o constants.o +cloudType.o : cloudType.f90 kinds.o constants.o +convert_lghtn2ref.o : convert_lghtn2ref.f90 kinds.o constants.o +cloud_saturation.o : cloud_saturation.f90 kinds.o +get_sfm_1d_gnl.o : get_sfm_1d_gnl.f90 kinds.o constants.o +vinterp_radar_ref.o : vinterp_radar_ref.f90 kinds.o constants.o +map_ctp.o : map_ctp.f90 kinds.o constants.o +mthermo.o : mthermo.f90 kinds.o constants.o +pcp_mxr_ARPSlib.o : pcp_mxr_ARPSlib.f90 kinds.o constants.o +## q_adjust.o : q_adjust.f90 kinds.o constants.o +read_Lightning_cld.o : read_Lightning_cld.f90 kinds.o constants.o +read_NESDIS.o : read_NESDIS.f90 kinds.o constants.o +read_radar_ref.o : read_radar_ref.f90 kinds.o constants.o +read_Surface.o :read_Surface.f90 kinds.o constants.o +read_nasalarc_cld.o : read_nasalarc_cld.f90 kinds.o constants.o +smooth.o : smooth.f90 kinds.o constants.o diff --git a/src/GSD/gsdcloud/make.filelist b/src/GSD/gsdcloud/make.filelist new file mode 100644 index 0000000000..9b943ba0b8 --- /dev/null +++ b/src/GSD/gsdcloud/make.filelist @@ -0,0 +1,35 @@ +SRC_FILES = ARPS_cldLib.f90 \ + BackgroundCld.f90 \ + BckgrndCC.f90 \ + radar_ref2tten.f90 \ + PrecipMxr_radar.f90 \ + PrecipType.f90 \ + TempAdjust.f90 \ + adaslib.f90 \ + build_missing_REFcone.f90 \ + cloudCover_NESDIS.f90 \ + cloudCover_Surface.f90 \ + cloudCover_radar.f90 \ + cloudLWC.f90 \ + cloudLayers.f90 \ + cloudType.f90 \ + cloud_saturation.f90 \ + convert_lghtn2ref.f90 \ + get_sfm_1d_gnl.f90 \ + vinterp_radar_ref.f90 \ + map_ctp.f90 \ + mthermo.f90 \ + pcp_mxr_ARPSlib.f90 \ + read_Lightning_cld.f90 \ + read_NESDIS.f90 \ + read_radar_ref.f90 \ + read_Surface.f90 \ + read_nasalarc_cld.f90 \ + smooth.f90 \ + constants.f90 \ + kinds.f90 \ + pbl_height.f90 \ + hydro_mxr_thompson.f90 \ + map_ctp_lar.f90 + +OBJ_FILES =${SRC_FILES:.f90=.o} diff --git a/src/GSD/gsdcloud/map_ctp.f90 b/src/GSD/gsdcloud/map_ctp.f90 new file mode 100644 index 0000000000..1670ba93ef --- /dev/null +++ b/src/GSD/gsdcloud/map_ctp.f90 @@ -0,0 +1,291 @@ +subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,npts_rad,ioption) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp map GOES cloud product to analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map GOES cloud product to analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! npts_rad - impact radius +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + INTEGER(i_kind),intent(in) :: npts_rad + INTEGER(i_kind),intent(in) :: ioption + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=60) + +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt + integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ipt,ii,jj,i,med_pt,ii1,jj1 + + real(r_kind) :: xc + real(r_kind) :: yc + + real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + w_eca (ii,jj) =-99999._r_kind + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind + if(data_s(8,ipt) > 50 ) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-npts_rad), min(ny,jj1+npts_rad) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-npts_rad), min(nx,ii1+npts_rad) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(6,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 + Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ! remove hard code choice ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if ((index(ii,jj) >= 1 .and. index(ii,jj) < 3) .and. npts_rad > 1) then + sat_ctp(ii,jj) = Pxx(ii,jj,1) + sat_tem(ii,jj) = Txx(ii,jj,1) + w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. + w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... + + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample + if(ioption == 1) then !nearest neighborhood + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) + w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind + endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_frac(ii,jj) = fr + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp + +subroutine sorting(d,n,is) + use kinds, only: r_kind,i_kind + implicit none + + integer(i_kind), intent(in) :: n + real(r_kind) , intent(inout) :: d(n) + integer(i_kind), intent(inout) :: is(n) +! + integer(i_kind) :: nm1,ip1,iold,i,j + real(r_kind) :: temp +! +! + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(d(i) <= d(j)) goto 10 + temp = d(i) + d(i) = d(j) + d(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sorting + +subroutine sortmed(p,n,is,f) + use kinds, only: r_kind,i_kind + implicit none + real(r_kind), intent(inout) :: p(n) + integer(i_kind), intent(in) :: n + integer(i_kind), intent(inout) :: is(n) +! * count cloudy fov + real(r_kind), intent(out) :: f + integer(i_kind) :: cfov +! + integer(i_kind) :: i,j,nm1,ip1,iold + real(r_kind) :: temp +! +! +! + cfov = 0 + do i=1,n + if(p(i) < 999._r_kind) cfov = cfov + 1 + enddo + f = float(cfov)/(max(1,n)) +! cloud-top pressure is sorted high cld to clear + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(p(i)<=p(j)) goto 10 + temp = p(i) + p(i) = p(j) + p(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sortmed diff --git a/src/GSD/gsdcloud/map_ctp_lar.f90 b/src/GSD/gsdcloud/map_ctp_lar.f90 new file mode 100644 index 0000000000..c2927869c5 --- /dev/null +++ b/src/GSD/gsdcloud/map_ctp_lar.f90 @@ -0,0 +1,258 @@ +subroutine map_ctp_lar(mype,ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld,ioption) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp map GOES cloud product to analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map GOES cloud product to analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + + integer(i_kind),intent(in) :: mype +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + INTEGER(i_kind),intent(in) :: ioption + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_lwp(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=650) + +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: PHxx(Nx,Ny,nfov),WPxx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt + integer(i_kind) :: Nxx(Nx,Ny,nfov) + integer(i_kind) :: index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ipt,ii,jj,i,med_pt, & + ii1,jj1 + + real(r_kind) :: xc + real(r_kind) :: yc + +! real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios,cfov + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + sat_ctp (ii,jj) =-99999._r_kind + sat_tem (ii,jj) =-99999._r_kind + w_lwp (ii,jj) =-99999._r_kind + w_frac (ii,jj) =-99999._r_kind + nlev_cld (ii,jj) =-99999 + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind + +! skip the bad observations + if(abs(data_s(6,ipt)+9.0_r_single) < 0.1_r_single) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-1), min(ny,jj1+1) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-1), min(nx,ii1+1) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(5,ipt) + PHxx(ii,jj,index(ii,jj)) = data_s(6,ipt) + WPxx(ii,jj,index(ii,jj)) = data_s(7,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 + Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 +! write(6,*)'sat_tem1::',index(ii,jj),data_s(4,ipt),data_s(5,ipt),data_s(6,ipt),data_s(7,ipt) + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ! remove hard code choice ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if (index(ii,jj) < 3 ) then +! sat_ctp(ii,jj) = Pxx(ii,jj,1) +! sat_tem(ii,jj) = Txx(ii,jj,1) +! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. +! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... +! +! do i=1,index(ii,jj) +! jndex(i) = i +! xxxdist(i) = xdist(ii,jj,i) +! enddo +! call sorting(xxxdist,index(ii,jj),jndex) +! w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample + if(ioption == 1) then !nearest neighborhood + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) + w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind + endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_lwp(ii,jj) = WPxx(ii,jj,jndex(med_pt)) + if ( abs(sat_ctp(ii,jj)+20.0_r_single) < 0.1_r_single) then + sat_ctp(ii,jj) = 1013. ! hPa - no cloud + w_frac(ii,jj)=0.0 + nlev_cld(ii,jj) = 0 + end if + +! +! cloud fraction based on phase (0 are clear), what about -9 ???? + if( sat_ctp(ii,jj) < 1012.99) then + cfov = 0 + do i=1,index(ii,jj) + if(PHxx(ii,jj,i) .gt. 0.1) cfov = cfov + 1 + enddo + w_frac(ii,jj) = float(cfov)/(max(1,index(ii,jj))) ! fraction + if( w_frac(ii,jj) > 0.01 ) nlev_cld(ii,jj) = 1 + endif + +! write(6,'(a,2I4,I5,2f10.2)')'sat_tem2::',ii,jj,index(ii,jj),sat_ctp(ii,jj),sat_tem(ii,jj) + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp_lar diff --git a/src/GSD/gsdcloud/mthermo.f90 b/src/GSD/gsdcloud/mthermo.f90 new file mode 100644 index 0000000000..83b5b7741e --- /dev/null +++ b/src/GSD/gsdcloud/mthermo.f90 @@ -0,0 +1,229 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines and functions related to thermodynamic calculations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2010-05-03 Hu Clean the code +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + function esat(t) +! +! this function returns the saturation vapor pressure over +! water (mb) given the temperature (celsius). +! the algorithm is due to nordquist, w.s.,1973: "numerical approxima- +! tions of selected meteorlolgical parameters for cloud physics prob- +! lems," ecom-5475, atmospheric sciences laboratory, u.s. army +! electronics command, white sands missile range, new mexico 88002. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind),intent(in) :: t + real(r_single) :: tk,p1,p2,c1 + real(r_kind) :: esat + + tk = t+273.15 + p1 = 11.344-0.0303998*tk + p2 = 3.49149-1302.8844/tk + c1 = 23.832241-5.02808*alog10(tk) + esat = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tk) + return + end function esat + + function eslo(t) +! +! this function returns the saturation vapor pressure over liquid +! water eslo (millibars) given the temperature t (celsius). the +! formula is due to lowe, paul r.,1977: an approximating polynomial +! for the computation of saturation vapor pressure, journal of applied +! meteorology, vol 16, no. 1 (january), pp. 100-103. +! the polynomial coefficients are a0 through a6. + use kinds, only: r_single,i_kind,r_kind + implicit none +! + real(r_kind), intent(in) :: t + real(r_kind) :: eslo + + real(r_kind) :: a0,a1,a2,a3,a4,a5,a6 + real(r_kind) :: es + + data a0,a1,a2,a3,a4,a5,a6 & + /6.107799961, 4.436518521E-01, 1.428945805E-02, & + 2.650648471E-04, 3.031240396E-06, 2.034080948E-08, & + 6.136820929E-11/ + es = a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) + IF (es < 0.) es = 0. + eslo = es + return + end function eslo + + function tda(o,p) +! +! this function returns the temperature tda (celsius) on a dry adiabat +! at pressure p (millibars). the dry adiabat is given by +! potential temperature o (celsius). the computation is based on +! poisson's equation. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: o,p + real(r_kind) :: tda + + tda= (o+273.15)*((p*.001)**.286)-273.15 + return + end function tda + + function tmr(w,p) +! +! this function returns the temperature (celsius) on a mixing +! ratio line w (g/kg) at pressure p (mb). the formula is given in +! table 1 on page 7 of stipanuk (1973). +! +! initialize constants + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: w,p + real(r_kind) :: tmr + + real(r_kind) :: c1,c2,c3,c4,c5,c6 + real(r_kind) :: x,tmrk + real(r_single) :: y + + data c1/.0498646455/,c2/2.4082965/,c3/7.07475/ + data c4/38.9114/,c5/.0915/,c6/1.2035/ + + y=w*p/(622.+w) + x= alog10(y) + tmrk= 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.) + tmr= tmrk-273.15 + return + end function tmr + + function tsa(os,p) +! +! this function returns the temperature tsa (celsius) on a saturation +! adiabat at pressure p (millibars). os is the equivalent potential +! temperature of the parcel (celsius). sign(a,b) replaces the +! algebraic sign of a with that of b. +! b is an empirical constant approximately equal to 0.001 of the latent +! heat of vaporization for water divided by the specific heat at constant +! pressure for dry air. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: os,p + real(r_kind) :: tsa + + real(r_kind) :: a,b,d,tq,x,tqk,w + integer :: i + + data b/2.6518986/ + a= os+273.15 + +! tq is the first guess for tsa. + + tq= 253.15 + +! d is an initial value used in the iteration below. + + d= 120. + +! iterate to obtain sufficient accuracy....see table 1, p.8 +! of stipanuk (1973) for equation used in iteration. + + do i= 1,12 + tqk= tq-273.15 + d= d/2. + x= a*exp(-b*w(tqk,p)/tq)-tq*((1000./p)**.286) + IF (abs(x) < 1E-7) GOTO 2 + tq= tq+sign(d,x) + end do +2 tsa= tq-273.15 + return + end function tsa + + function tw(t,td,p) +! this function returns the wet-bulb temperature tw (celsius) +! given the temperature t (celsius), dew point td (celsius) +! and pressure p (mb). see p.13 in stipanuk (1973), referenced +! above, for a description of the technique. +! +! +! determine the mixing ratio line thru td and p. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,td,p + real(r_kind) :: tw + + real(r_kind) :: aw,ao,pi,tmr,tda,ti,aos,tsa,w,x + integer :: i + + aw = w(td,p) +! +! determine the dry adiabat thru t and p. + + ao = (t+273.15)*((1000./p)**.286)-273.15 + pi = p + +! iterate to locate pressure pi at the intersection of the two +! curves . pi has been set to p for the initial guess. + + do i= 1,10 + x= .02*(tmr(aw,pi)-tda(ao,pi)) + IF (abs(x) < 0.01) exit + pi= pi*(2.**(x)) + end do + +! find the temperature on the dry adiabat ao at pressure pi. + + ti= tda(ao,pi) + +! the intersection has been located...now, find a saturation +! adiabat thru this point. function os returns the equivalent +! potential temperature (c) of a parcel saturated at temperature +! ti and pressure pi. + + aos= (ti+273.15)*((1000./pi)**.286)*(exp(2.6518986*w(ti,pi)/(ti+273.15)))-273.15 + +! function tsa returns the wet-bulb temperature (c) of a parcel at +! pressure p whose equivalent potential temperature is aos. + + tw = tsa(aos,p) + return + end function tw + + function w(t,p) +! +! this function returns the mixing ratio (grams of water vapor per +! kilogram of dry air) given the dew point (celsius) and pressure +! (millibars). if the temperture is input instead of the +! dew point, then saturation mixing ratio (same units) is returned. +! the formula is found in most meteorological texts. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,p + real(r_kind) :: w + + real(r_kind) :: esat + + w= 622.*esat(t)/(p-esat(t)) + return + end function w diff --git a/src/GSD/gsdcloud/pbl_height.f90 b/src/GSD/gsdcloud/pbl_height.f90 new file mode 100644 index 0000000000..6466899f01 --- /dev/null +++ b/src/GSD/gsdcloud/pbl_height.f90 @@ -0,0 +1,103 @@ +SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pbl_height to calculate PBL height or level +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-04-06 +! +! ABSTRACT: +! This subroutine calculate PBL height +! +! PROGRAM HISTORY LOG: +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! +! output argument list: +! pblh - 2D PBL height (level number) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) +! +! Variables for cloud analysis +! + real (r_single),intent(out) :: pblh(nlon,nlat) +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k + real(r_single) :: thetav(nsig) + real(r_single) :: thsfc,qsp + +!==================================================================== +! Begin +! +! + DO j = 1,nlat + DO i = 1,nlon + + DO k = 1,nsig + qsp=q_bk(i,j,k)/(1.0+q_bk(i,j,k)) ! q_bk = water vapor mixing ratio + thetav(k) = t_bk(i,j,k)*(1.0 + 0.61 * qsp) ! qsp = spcific humidity +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',k,thetav(k),t_bk(i,j,k),q_bk(i,j,k) +! endif + ENDDO + + pblh(i,j) = 0.0_r_single + thsfc = thetav(1) + k=1 + DO while (abs(pblh(i,j)) < 0.0001_r_single) + if( thetav(k) > thsfc + 1.0_r_single ) then + pblh(i,j) = float(k) - (thetav(k) - (thsfc + 1.0_r_single))/ & + max((thetav(k)-thetav(k-1)),0.01_r_single) + endif + k=k+1 + ENDDO + if(abs(pblh(i,j)) < 0.0001) pblh(i,j)=2.0_r_single + +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',pblh(i,j),k +! endif + + + enddo ! i + enddo ! j + +END SUBROUTINE calc_pbl_height + diff --git a/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 b/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 new file mode 100644 index 0000000000..e25e6a8486 --- /dev/null +++ b/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 @@ -0,0 +1,509 @@ + +SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus ) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculates hydrometeor mixing ratios based on Kessler radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on Kessler radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old documents from CAPS +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Kessler (1969) +! formula: +! qr(g/kg) = a*(rho*arg)**b (1) +! +! Here arg = Z (mm**6/m**3), and dBZ = 10log10 (arg). +! Coeffcients a=17300.0, and b=7/4. +! rho represents the air density. +! +! For snow and graupel/hail, using Rogers and Yau (1989) formula: +! +! qs(g/kg) = c*(rho*arg)**d (2) +! +! where, c=38000.0, d=2.2 +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Jian Zhang) +! 06/13/96 +! +! MODIFICATION HISTORY: +! 07/30/97 (J. Zhang) +! Added precipitation type in the argument list so that +! mixing ratios of different precip. types can be computed. +! 09/04/97 (J. Zhang) +! Changed the radar echo thresholds for inserting precip. +! from radar reflectivities. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + real(r_single),intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + real(r_single),intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + integer(i_kind),intent(in):: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field +! +! OUTPUT: + INTEGER(i_kind),intent(out) :: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz)! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz)! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz)! graupel/hail mixing ratio in (g/kg) +! +! LOCAL: + REAL(r_kind) :: a,b,c,d ! Coef. for Z-qr relation. + PARAMETER (a=17300.0_r_kind, b=7.0/4.0_r_kind) + PARAMETER (c=38000.0_r_kind, d=2.2_r_kind) + REAL(r_kind) :: rair ! Gas constant (J/deg/kg) + PARAMETER (rair = 287.04_r_kind) + REAL(r_kind) :: thresh_ref + PARAMETER (thresh_ref = 0.0_r_kind) + INTEGER(i_kind) :: pcptype +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + REAL(r_kind) :: arg,rhobar,br,dr + PARAMETER (br=1.0_r_kind/b, dr=1.0_r_kind/d) +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! + istatus=0 +! +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Kessler (1969) or Rogers and Yau (1989). +! +!----------------------------------------------------------------------- +! + DO k = 1,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rhobar = p_3d(i,j,k)/rair/t_3d(i,j,k) + arg = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + + IF (pcptype == 0) THEN ! no precip + PRINT*,'+++ NOTE: radar echo though no precip. +++' + ELSE IF (pcptype == 1.OR.pcptype == 3) THEN ! rain or Z R + qr_3d(i,j,k) = (arg/a)**br/rhobar + ELSE IF (pcptype == 2) THEN ! snow + qs_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE IF (pcptype == 4.OR.pcptype == 5) THEN ! hail or sleet + qg_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE ! unknown + PRINT*,'+++ NOTE: unknown precip type. +++' + END IF + ELSE + qr_3d(i,j,k) = 0._r_kind + qs_3d(i,j,k) = 0._r_kind + qg_3d(i,j,k) = 0._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr + +! +SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus,mype ) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on ferrier radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old document from CAPS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Ferrier et al (1995) +! formulation: +! +! +! For rain water: +! +! 18 +! 10 * 720 1.75 +! Zer = --------------------------- * (rho * qr) +! 1.75 0.75 1.75 +! pi * N0r * rhor +! +! +! For dry snow (t <= 0 C): +! +! +! 18 2 0.25 +! 10 * 720 * |K| * rhos +! ice 1.75 +! Zes = ----------------------------------------- * (rho * qs) t <= 0 C +! 1.75 2 0.75 2 +! pi * |K| * N0s * rhoi +! water +! +! +! For wet snow (t >= 0 C): +! +! +! 18 +! 10 * 720 1.75 +! Zes = ---------------------------- * (rho * qs) t > 0 C +! 1.75 0.75 1.75 +! pi * N0s * rhos +! +! +! For hail water: +! +! +! / 18 \ 0.95 +! / 10 * 720 \ 1.6625 +! Zeh = | ---------------------------- | * (rho * qg) +! \ 1.75 0.75 1.75 / +! \ pi * N0h * rhoh / +! +! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). +! rho represents the air density, rhor,rhos,rhoh are the density of +! rain, snow and hail respectively. Other variables are all constants +! for this scheme, see below. +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Donghai Wang and Eric Kemp) +! 07/20/2000 +! +! MODIFICATION HISTORY: +! +! 11/09/2000 Keith Brewster +! Moved some parameters with real-valued exponentiation to be +! computed at runtime due to compiler complaint. +! +! 04/07/2003 Keith Brewster +! Restructured code to make more tractable.and consistent with +! the reflec_ferrier subroutine. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio + ! in (g/kg) +! + + REAL(r_kind),PARAMETER :: ki2 = 0.176_r_kind ! Dielectric factor for ice if other + ! than melted drop diameters are used. + REAL(r_kind),PARAMETER :: kw2=0.93_r_kind ! Dielectric factor for water. + + REAL(r_kind),PARAMETER :: m3todBZ=1.0E+18_r_kind ! Conversion factor from m**3 to + ! mm**6 m**-3. + REAL(r_kind),PARAMETER :: Zefact=720.0_r_kind ! Multiplier for Ze components. + REAL(r_kind),PARAMETER :: lg10div=0.10_r_kind ! Log10 multiplier (1/10) + + REAL(r_kind),PARAMETER :: pi=3.1415926_r_kind! Pi. + REAL(r_kind),PARAMETER :: N0r=8.0E+06_r_kind ! Intercept parameter in 1/(m^4) for rain. + REAL(r_kind),PARAMETER :: N0s=3.0E+06_r_kind ! Intercept parameter in 1/(m^4) for snow. + REAL(r_kind),PARAMETER :: N0h=4.0E+04_r_kind ! Intercept parameter in 1/(m^4) for graupel/hail. + + REAL(r_kind),PARAMETER :: N0xpowf=3.0/7.0_r_kind ! Power to which N0r,N0s & N0h are + ! raised. + REAL(r_kind),PARAMETER :: K2powf=4.0/7.0_r_kind ! Power to which K-squared + ! of ice, water are raised + REAL(r_kind),PARAMETER :: zkpowf=4.0/7.0_r_kind ! Power to which Zk is raised + REAL(r_kind),PARAMETER :: zepowf=4.0/7.0_r_kind ! Power to which Ze is raised + REAL(r_kind),PARAMETER :: zehpowf=(4.0/7.0)*1.0526_r_kind ! Power to which Zeh is raised + + REAL(r_kind),PARAMETER :: rhoi=917._r_kind ! Density of ice (kg m**-3) + REAL(r_kind),PARAMETER :: rhor=1000._r_kind ! Density of rain (kg m**-3) + REAL(r_kind),PARAMETER :: rhos=100._r_kind ! Density of snow (kg m**-3) + REAL(r_kind),PARAMETER :: rhoh=913._r_kind ! Density of graupel/hail (kg m**-3) + + REAL(r_kind),PARAMETER :: rhoipowf=8.0/7.0_r_kind ! Power to which rhoi is raised. + REAL(r_kind),PARAMETER :: rhospowf=1.0/7.0_r_kind ! Power to which rhos is raised. + + REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + INTEGER(i_kind) :: pcptype + REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract + REAL(r_kind) :: ze,zer,zeh,zes,rho,tc + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, +! respectively, in Ferrier. +! +! These are the inverse of those presented in the reflec_ferrier function. +! +!----------------------------------------------------------------------- +! + istatus=0 + + zkconst = (Zefact*m3todBZ) ** zkpowf + + zerf=1000._r_kind*(pi * (N0r**N0xpowf) * rhor )/zkconst + + zesnegf=1000._r_kind*(pi*(kw2**k2powf)*(N0s**N0xpowf)*(rhoi**rhoipowf)) / & + ( zkconst * (ki2**k2powf) * (rhos**rhospowf) ) + + zesposf=1000._r_kind*( pi * (N0s**N0xpowf) * rhos) / zkconst + + zehf=1000._r_kind*( pi * (N0h**N0xpowf) * rhoh) / zkconst + +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Ferrier et al (1995). +! +!----------------------------------------------------------------------- +! + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rho = p_3d(i,j,k)/(rd*t_3d(i,j,k)) + ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + tc = t_3d(i,j,k) - 273.15_r_kind +!mhu temporal fix + IF (tc <= 0.0_r_kind) THEN + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + qr_3d(i,j,k) = 0.0_r_kind + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze +! qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho +! qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qs_3d(i,j,k) = zesnegf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + else + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + qs_3d(i,j,k) = 0.0_r_kind + ENDIF + cycle +!mhu + IF (pcptype == 1) THEN ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 2) THEN ! snow + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 3) THEN ! ZR + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 4) THEN ! sleet + IF (tc <= 0.0_r_kind) THEN ! graupel/hail category + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE IF( tc < 10._r_kind ) THEN + rfract=0.10_r_kind*tc + zer=rfract*ze + zeh=(1.-rfract)*ze + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qg_3d(i,j,k) = zehf * (zeh**zehpowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 5) THEN ! graupel/hail + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE ! unknown + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF ( tc < 5.0_r_kind ) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + END IF + ELSE + qr_3d(i,j,k) = -999._r_kind + qs_3d(i,j,k) = -999._r_kind + qg_3d(i,j,k) = -999._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! PRINT*,'Finish Ferrier ...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr_ferrier diff --git a/src/GSD/gsdcloud/radar_ref2tten.f90 b/src/GSD/gsdcloud/radar_ref2tten.f90 new file mode 100644 index 0000000000..c423d7bc6e --- /dev/null +++ b/src/GSD/gsdcloud/radar_ref2tten.f90 @@ -0,0 +1,334 @@ +SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d, & + cld_cover_3d,p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh,sat_ctp) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: radar_ref2tten convert radar reflectivity to 3-d temperature tendency +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 +! +! ABSTRACT: +! This subroutine converts radar observation (dBZ) to temperature tendency for DFI +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D radar reflectivity (dBZ) +! cld_cover_3d - 3D cloud cover (0-1) +! p_bk - 3D background pressure (hPa) +! t_bk - 3D background potential temperature (K) +! sat_ctp - 2D NESDIS cloud top pressure (hPa) +! ges_tten - 3D radar temperature tendency +! dfi_rlhtp - dfi radar latent heat time period. DFI forward integration window in minutes +! krad_bot_in - radar bottome height +! pblh - PBL height in grid unit +! +! output argument list: +! ges_tten - 3D radar temperature tendency +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use constants, only: rd_over_cp, h1000 + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),INTENT(IN) :: mype + INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig + INTEGER(i_kind),INTENT(IN) :: istat_radar + INTEGER(i_kind),INTENT(IN) :: istat_lightning + real(r_kind),INTENT(IN) :: dfi_rlhtp + real(r_single),INTENT(IN) :: krad_bot_in + real(r_single),INTENT(IN) :: pblh(nlon,nlat) + + real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) + real(r_single),INTENT(IN),OPTIONAL :: sat_ctp(nlon,nlat) + + real (r_single) :: tbk_k + + real(r_kind), allocatable :: tten_radar(:,:,:) ! + real(r_kind), allocatable :: dummy(:,:) ! + + integer krad_bot ! RUC bottom level for TTEN_RAD +! +! convection suppression +! + real(r_kind), allocatable :: radyn(:,:) + real(r_kind) :: radmax, dpint + integer(i_kind) :: nrad + real(r_kind) :: radmaxall, dpintmax + +! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) +! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS +!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT +!** R* = 8.31451 +!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR +!** MD = 0.0289645 +!jmb--Old value MD = 0.0289644 +!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR +!** RD = R*>/-100) then ! no echo + tten_radar(i,j,k) = 0._r_kind + else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo + iskip=0 + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + iskip=iskip+1 +! write (6,*)' Radar ref > 5 dbZ, GOES indicates clear' +! write (6,*)' i,j,k / refl / lat-lon',i,j,k,ref_mos_3d(i,j,k) +! Therefore, if GOES indicates clear, tten_radar +! will retain the zero value + endif + endif + if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then + iskip=iskip+1 +! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) +! ALSO, if T > 4C and refl < 28dBZ, again +! tten_radar = 0. + endif + if(iskip == 0 ) then +! tten_radar set as non-zero ONLY IF +! - not contradicted by GOES clear, and +! - ruc_refl > 28 dbZ for temp > 4K, and +! - for temp < 4K, any ruc_refl dbZ is OK. +! - cloudy and under GOES cloud top +! - dfi_rlhtp in minutes + if (k>=krad_bot) then +! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d +! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind .and. (sat_ctp(i,j)>p_bk(i,j,k))) then + addsnow = 10**(ref_mos_3d(i,j,k)/17.8_r_kind)/264083._r_kind*1.5_r_kind + if (PRESENT(sat_ctp) ) then + if ( (sat_ctp(i,j) > 1.0_r_kind .and. sat_ctp(i,j) < 1100.0_r_kind) & + .and. sat_ctp(i,j)>p_bk(i,j,k)) then + addsnow=0.0_r_kind + endif + endif + tten = ((1000.0_r_kind/p_bk(i,j,k))**(1._r_kind/cpovr_p)) & + *(((LV_P+LF0_P)*addsnow)/ & + (dfi_rlhtp*60.0_r_kind*CPD_P)) + tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) + end if + end if + end if ! ref_mos_3d + + ENDDO + ENDDO + ENDDO + +! DO k=1,nsig +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! ENDDO + +!================================================================================ +! At this point +! 1. put tten_radar into ges_tten array +! for use as tten_radar in subsequent model DFI. +! 2. calculate convection suppression array (RADYN), by +! first smoothing further the tten_radar array +! (available since it is already copied to ges_tten) +! and with adding clear areas from GOES cloud data. + +! KEY element -- Set tten_radar to no-coverage AFTER smoothing +! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) +!================================================================================ + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,k,1)=tten_radar(i,j,k) + if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs + ENDDO + ENDDO + ENDDO +! DO k=1,nsig +! write(6,*)' k,max,min check=',mype,k,maxval(ges_tten(:,:,k,1)),minval(ges_tten(:,:,k,1)) +! enddo + +! -- Whack (smooth) the tten_radar array some more. +! for convection suppression in the radyn array. + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + + deallocate(dummy) + +! RADYN array = convection suppression array +! Definition of RADYN values +! -10 -> no information +! 0 -> no convection +! 1 -> there might be convection nearby +! NOTE: 0,1 values are only possible if +! deep radar coverage is available (i.e., > 300 hPa deep) + +! RADYN is read into RUC model as array PCPPREV, +! where it is used to set the cap_depth (cap_max) +! in the Grell-Devenyi convective scheme +! to a near-zero value, effectively suppressing convection +! during DFI and first 30 min of the forward integration. + + allocate(radyn(nlon,nlat)) + radyn = -10._r_kind + + radmaxall=-999 + dpintmax=-999 + DO j=1,nlat + DO i=1,nlon + + nrad = 0 + radmax = 0._r_kind + dpint = 0._r_kind + DO k=2,nsig-1 + if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p + if (tten_radar(i,j,k)>-15._r_kind) then + nrad=nrad+1 + dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) + radmax = max(radmax,tten_radar(i,j,k)) + end if + ENDDO + if (dpint>=300._r_kind ) then + radyn(i,j) = 0._r_kind + if (radmax>0.00002_r_kind) radyn(i,j) = 1. + if( abs(radyn(i,j)) < 0.00001_r_kind ) then + krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height + do k=krad_bot,nsig-1 + ges_tten(j,i,k,1) = 0._r_kind + end do + endif + else +! outside radar coverage area where satellite shows clear conditions, +! then add this area to the convection suppress area. + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + radyn(i,j) = 0._r_kind + endif + endif + endif + +! 2. Extend depth of no-echo zone from dpint zone down to PBL top, +! similarly to how lowest echo (with convection) is extended down to PBL top +! 5/27/2010 - Stan B. +! if (dpint >= 300. .and. radmax<=0.001) then +! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! do k=krad_bot,nsig-1 +! ges_tten(j,i,k,1) = 0._r_kind +! end do +! end if + + if(dpintmax < dpint ) dpintmax=dpint + if(radmaxall< radmax) radmaxall=radmax + ENDDO + ENDDO + + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,nsig,1)=radyn(i,j) + ENDDO + ENDDO + + deallocate(tten_radar) + deallocate(radyn) + + else ! no radar observation i this subdomain + + ges_tten=-spval_p + ges_tten(:,:,nsig,1)=-10.0_r_kind + + DO j=1,nlat + DO i=1,nlon + +! outside radar observation domain and satellite show clean, the suppress convection + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>=1010._r_kind .and. sat_ctp(i,j)<=1100._r_kind) then + ges_tten(j,i,nsig,1) = 0. + endif + endif + ENDDO + ENDDO + + endif + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs + ENDDO + ENDDO + ENDDO + +END SUBROUTINE radar_ref2tten diff --git a/src/GSD/gsdcloud/read_Lightning_cld.f90 b/src/GSD/gsdcloud/read_Lightning_cld.f90 new file mode 100644 index 0000000000..89097f72bb --- /dev/null +++ b/src/GSD/gsdcloud/read_Lightning_cld.f90 @@ -0,0 +1,93 @@ +SUBROUTINE read_Lightning2cld(mype,lunin,istart,jstart, & + nlon,nlat,numlight,lightning) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in lightning flash rate +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 +! +! ABSTRACT: +! This subroutine read in lightning flash rate +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numlight - number of observation +! +! output argument list: +! lightning - lightning flash rate in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numlight + + real(r_single), intent(out):: lightning(nlon,nlat) +! +! local +! + real(r_kind),allocatable :: light_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,ii,jj + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + + read(lunin) obstype,isis,nreal,nchanl + + allocate( light_in(nreal,numlight) ) + light_in=-9999.0_r_kind + + read(lunin) light_in + DO i=1,numlight + ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & + 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & + 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb + lightning(ii,jj)=light_in(3,i) + ENDDO + deallocate(light_in) + +END SUBROUTINE read_Lightning2cld diff --git a/src/GSD/gsdcloud/read_NESDIS.f90 b/src/GSD/gsdcloud/read_NESDIS.f90 new file mode 100644 index 0000000000..0daca20f24 --- /dev/null +++ b/src/GSD/gsdcloud/read_NESDIS.f90 @@ -0,0 +1,124 @@ +SUBROUTINE read_NESDIS(mype,lunin,numobs,istart,jstart,nlon,nlat, & + sat_ctp,sat_tem,w_frac,npts_rad,ioption) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in NESDIS cloud products and map them into analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: npts_rad + INTEGER(i_kind),intent(in) :: ioption + + real(r_single), intent(out):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single), intent(out):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single), intent(out):: w_frac(nlon,nlat) ! cloud fraction +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j + INTEGER(i_kind) :: ib, jb +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp (ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,npts_rad,ioption) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_frac(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + +END SUBROUTINE read_NESDIS diff --git a/src/GSD/gsdcloud/read_Surface.f90 b/src/GSD/gsdcloud/read_Surface.f90 new file mode 100644 index 0000000000..48a1765a4d --- /dev/null +++ b/src/GSD/gsdcloud/read_Surface.f90 @@ -0,0 +1,240 @@ +SUBROUTINE read_Surface(mype,lunin,istart,jstart,nlon,nlat,& + numsao,NVARCLD_P,OI,OJ,OCLD,OWX,Oelvtn,Odist,cstation, & + OIstation,OJstation) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_Surface read in cloud observations in surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in cloud observations in surface observation +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numsao - maximum observation number (observation number) +! NVARCLD_P - first dimension of OLCD +! +! output argument list: +! +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! cstation - station name + +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! + + use kinds, only: r_single,i_kind,r_kind,r_double + + implicit none + + integer(i_kind), intent(in) :: mype + integer(i_kind), intent(in) :: lunin + integer(i_kind), intent(in) :: istart + integer(i_kind), intent(in) :: jstart + INTEGER(i_kind), intent(in) :: nlon,nlat + INTEGER(i_kind), intent(in) :: numsao + INTEGER(i_kind), intent(in) :: NVARCLD_P + + real(r_single), intent(out) :: OI(numsao) ! x location, grid + real(r_single), intent(out) :: OJ(numsao) ! y location, grid + INTEGER(i_kind), intent(out) :: OCLD(NVARCLD_P,numsao) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(out) :: OWX(numsao) ! weather + real(r_single), intent(out) :: Oelvtn(numsao) ! elevation + real(r_single), intent(out) :: Odist(numsao) ! distance from the nearest station + character(8), intent(out) :: cstation(numsao) ! station name + real(r_single), intent(out) :: OIstation(numsao) ! x location, station + real(r_single), intent(out) :: OJstation(numsao) ! y location, station + +! +! temp. +! + real(r_single) :: VIS ! horizontal visibility +! +! misc. +! + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse + character(10) :: obstype + integer(i_kind):: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: nn_obs + real(r_kind) :: cldamt,awx,cldhgt + character*3 :: mwx + INTEGER(i_kind) :: i,j,jb,ib + integer(i_kind) :: start, end + + real(r_kind) :: spval_p + parameter (spval_p = 99999.) + + real(r_double) rstation_id + character(8) :: cstation1 + equivalence(cstation1,rstation_id) + + +!==================================================================== +! Begin + OWX='' + OCLD=-99999 + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + +! + read(lunin) obstype,isis,nreal,nchanl + + nn_obs = nreal + nchanl + allocate(luse(numsao),data_s(nn_obs,numsao)) + read(lunin) data_s, luse +! +! read in ruface observations: +! station name, x location, y location, longitude, latitude, elevation +! visibility, cloud amount, cloud height, weather +! + DO i=1,numsao + rstation_id=data_s(1,i) + cstation(i)=cstation1 + OI(i) = data_s(2,i) - ib + 2 ! covert it to the local grid + OJ(i) = data_s(3,i) - jb + 2 ! covert it to the local grid + if( OI(i) < 1 .or. OI(i) > nlon ) write(6,*) 'read_Surface: Error in reading ii:',mype,OI(i),ib,jb + if( OJ(i) < 1 .or. OJ(i) > nlat ) write(6,*) 'read_Surface: Error in reading jj:',mype,OJ(i),ib,jb + Oelvtn(i) = data_s(4,i) + Odist(i) = data_s(23,i) + OIstation(i) = data_s(24,i) + OJstation(i) = data_s(25,i) + if(data_s(22,i) > 50 ) cycle ! do not use this data + VIS = data_s(5,i) +! cloud amonut and base height +! C 020011 +! 0 0 oktas (0/10) +! 1 1 okta or less, but not zero (1/10 or less, but not zero) +! 2 2 oktas (2/10 - 3/10) +! 3 3 oktas (4/10) +! 4 4 oktas (5/10) +! 5 5 oktas (6/10) +! 6 6 oktas (7/10 - 8/10) +! 7 7 oktas or more, but not 8 oktas (9/10 or more, but not 10/10) +! 8 8 oktas (10/10) +! 9 Sky obscured by fog and/or other meteorological phenomena +! 10 Sky partially obscured by fog and/or other meteorological phenomena +! 11 Scattered +! 12 Broken +! 13 Few +! 14 Reserved +! 15 Cloud cover is indiscernible for reasons other than +! fog or other meteorological phenomena, or observation is not made + + DO j=1,3 + cldamt = data_s(5+j,i) ! cloud amount + cldhgt = int(data_s(11+j,i)) ! cloud bottom height + if(cldamt < spval_p .and. cldhgt < spval_p) then + if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=0 !msky='CLR' + cldhgt=spval_p + elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 !msky='FEW' + elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=2 !msky='SCT' + elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=3 !msky='BKN' + elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & + (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then + OCLD(j,i)=4 ! msky='OVC' msky='VV ' + elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 + elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & + abs(cldamt-3._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=2 + elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then + OCLD(j,i)=3 + elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=4 + else + OCLD(j,i) = spval_p ! wrong cloud observation type + cldhgt = spval_p + endif + if(cldhgt > 0.0_r_kind ) then + OCLD(6+j,i) = cldhgt + else + OCLD(j,i) = spval_p + OCLD(6+j,i) = spval_p + endif + else + OCLD(j,i) = 99 + OCLD(6+j,i) = spval_p + endif + enddo ! j +! weather + DO j=1,3 + awx = data_s(17+j,i) ! weather + mwx=' ' + if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' + if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' + if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' + if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' + if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' + if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' + if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' + if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' + if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' + if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' + if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' + if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' + + if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' + if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' + if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' + if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' + + if (j==1) start=1 + if (j==2) start=4 + if (j==3) start=7 + end=start+2 + OWX(i)(start:end)=mwx + enddo +! visiblity + IF(VIS > spval_P) then + OCLD(13,i)=spval_P + else + IF(VIS > 100.0_r_kind ) then + OCLD(13,i)=int(VIS) + elseif(VIS <=100.0_r_kind .and. VIS > 0.0_r_kind ) then + OCLD(13,i)=100 + write(6,*) 'read_Surface, Warning: change visibility to 100 m !!!' + ENDIF + endif + + ENDDO ! i = numsao +! + +END SUBROUTINE read_Surface + diff --git a/src/GSD/gsdcloud/read_nasalarc_cld.f90 b/src/GSD/gsdcloud/read_nasalarc_cld.f90 new file mode 100644 index 0000000000..557ac81235 --- /dev/null +++ b/src/GSD/gsdcloud/read_nasalarc_cld.f90 @@ -0,0 +1,301 @@ +SUBROUTINE read_NASALaRC(mype,lunin,numLaRC,istart,jstart, & + nlon,nlat,nasalarc) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NASALaRC read in nasalarc cloud +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2009-09-21 +! +! ABSTRACT: +! This subroutine reads in nasalarc cloud products that are already mapped to +! analysis grid. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numLaRC - number of observation +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! nasalarc - nasalarc cloud in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: numLaRC + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + + real(r_single), intent(out) :: nasalarc(nlon,nlat,5) +! +! local +! + real(r_kind),allocatable :: nasalarc_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj, k + INTEGER(i_kind) :: ib,jb + + REAL(r_kind) :: miss_obs_real + PARAMETER ( miss_obs_real = -99999.0_r_kind ) + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + + read(lunin) obstype,isis,nreal,nchanl + + allocate( nasalarc_in(nreal,numLaRC) ) + nasalarc_in=miss_obs_real + + read(lunin) nasalarc_in + DO i=1,numLaRC + ii=int(nasalarc_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(nasalarc_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_nasalarc_cld: ', & + 'Error in read in nasa ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_nasalarc_cld: ', & + 'Error in read in nasa jj:',mype,ii,jj,i,ib,jb + DO k=1,2 + if(nasalarc_in(k+2,i) > 8888.0_r_kind ) then + nasalarc(ii,jj,k)=miss_obs_real + else + nasalarc(ii,jj,k)=nasalarc_in(k+2,i) ! k=1 w_pcld, 2=w_tcld + endif + enddo ! k + + if(nasalarc_in(5,i) > 8888.0_r_kind ) then + nasalarc(ii,jj,3)=miss_obs_real + else + nasalarc(ii,jj,3)=nasalarc_in(5,i)/100.0_r_kind ! w_frac + endif + + if(nasalarc_in(6,i) > 8888.0_r_kind) then + nasalarc(ii,jj,4)=miss_obs_real + else + nasalarc(ii,jj,4)=nasalarc_in(6,i)/1000.0_r_kind ! w_lwp + endif + + if(nasalarc_in(7,i) > 8888.0_r_kind ) then + nasalarc(ii,jj,5)=miss_obs_real + else + nasalarc(ii,jj,5)=nasalarc_in(7,i) ! nlv_cld + endif + ENDDO + deallocate(nasalarc_in) +! +! filling boundarys +! + DO k=1,5 + DO i=2,nlon-1 + nasalarc(i,1,k)=nasalarc(i,2,k) + nasalarc(i,nlat,k)=nasalarc(i,nlat-1,k) + enddo + DO j=2,nlat-1 + nasalarc(1,j,k)=nasalarc(2,j,k) + nasalarc(nlon,j,k)=nasalarc(nlon-1,j,k) + enddo + nasalarc(1,1,k)=nasalarc(2,2,k) + nasalarc(1,nlat,k)=nasalarc(2,nlat-1,k) + nasalarc(nlon,1,k)=nasalarc(nlon-1,2,k) + nasalarc(nlon,nlat,k)=nasalarc(nlon-1,nlat-1,k) + ENDDO + + +END SUBROUTINE read_NASALaRC + +SUBROUTINE read_map_nasalarc(mype,lunin,numobs,istart,jstart,nlon,nlat, & + nasalarc,ioption) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_map_nasalarc read in NASA LaRC cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu & Terra Ladwig ORG: GSD/EMB DATE: 2015-04-30 +! +! ABSTRACT: +! This subroutine reads in global NASA LaRC cloud products and map them into analysis grid. +! +! PROGRAM HISTORY LOG: +! 2015-04-20 Hu This code is based on read_NESDIS +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! nasalarc - nasalarc cloud in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + integer(i_kind),intent(in) :: ioption + + real(r_single):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single):: w_frac(nlon,nlat) ! cloud fraction + real(r_single):: w_lwp(nlon,nlat) ! cloud fraction + integer(i_kind):: nlev_cld(nlon,nlat) ! cloud fraction + real(r_single):: nasalarc(nlon,nlat,5) +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j + INTEGER(i_kind) :: ib, jb +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse + +! do i=1,numobs +! write(6,*)'sliu larcclddata::',mype,data_s(2,i),data_s(3,i) +! end do + +! write(6,*)'read_map_nasalarc::',mype, maxval(data_s(7,:)),numobs + + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp_lar(mype,ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld,ioption) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + w_lwp(i,1) =w_lwp(i,2) + nlev_cld(i,1) =nlev_cld(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + w_lwp(i,nlat) =w_lwp(i,nlat-1) + nlev_cld(i,nlat) =nlev_cld(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_lwp(2,j) + w_lwp(1,j) =w_lwp(2,j) + nlev_cld(1,j) =nlev_cld(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + w_lwp(nlon,j) =w_lwp(nlon-1,j) + nlev_cld(nlon,j) =nlev_cld(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + w_lwp(1,1) =w_lwp(2,2) + nlev_cld(1,1) =nlev_cld(2,2) + + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + w_lwp(1,nlat) =w_lwp(2,nlat-1) + nlev_cld(1,nlat) =nlev_cld(2,nlat-1) + + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + w_lwp(nlon,1) =w_lwp(nlon-1,2) + nlev_cld(nlon,1) =nlev_cld(nlon-1,2) + + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + + do i=1,nlon + do j=1,nlat + nasalarc(i,j,1)=sat_ctp(i,j) + nasalarc(i,j,2)=sat_tem(i,j) + nasalarc(i,j,3)=w_frac(i,j) !/100.0 + nasalarc(i,j,4)=w_lwp(i,j) !/100.0 + nasalarc(i,j,5)=nlev_cld(i,j) +! if(abs(sat_tem(i,j))>0.and.abs(sat_tem(i,j))<400) then +! write(6,*)'sat_tem2 in read_cloud::',sat_ctp(i,j),sat_tem(i,j),nasalarc(i,j,1) +! end if + end do + end do + + +END SUBROUTINE read_map_nasalarc diff --git a/src/GSD/gsdcloud/read_radar_ref.f90 b/src/GSD/gsdcloud/read_radar_ref.f90 new file mode 100644 index 0000000000..9f337a6ae1 --- /dev/null +++ b/src/GSD/gsdcloud/read_radar_ref.f90 @@ -0,0 +1,106 @@ +SUBROUTINE read_radar_ref(mype,lunin,istart,jstart, & + nlon,nlat,Nmsclvl,numref,ref_mosaic31) +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-30 +! +! ABSTRACT: +! This subroutine read in radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numref - number of observation +! +! output argument list: +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and +! vertically in mosaic grid (height) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numref + + INTEGER(i_kind),intent(out):: Nmsclvl + real(r_kind), intent(out):: ref_mosaic31(nlon,nlat,31) +! +! local +! + real(r_kind),allocatable :: ref_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i, ii,jj, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + read(lunin) obstype,isis,nreal,nchanl + + ilon1s=1 + ilat1s=2 + Nmsclvl = nreal - 2 + IF( Nmsclvl .ne. 21 .and. Nmsclvl .ne.31) then + write(6,*) ' read_radar_ref: ', & + 'vertical dimesion inconsistent when read in reflectivty mosaic' + write(6,*) 'read in:',Nmsclvl + write(6,*) 'need:', 21, 'or', 31 + call stop2(114) + ENDIF + allocate( ref_in(nreal,numref) ) + ref_mosaic31=-9999.0_r_kind + + read(lunin) ref_in + DO i=1,numref + ii=int(ref_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(ref_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ( ii >= 1 .and. ii <= nlon ) .and. & + ( jj >= 1 .and. jj <= nlat ) ) then + DO k=1,Nmsclvl + ref_mosaic31(ii,jj,k)=ref_in(2+k,i) + ENDDO + else + write(6,*) 'read_radar_ref: Error ii or jj:',mype,ii,jj,i,ib,jb + endif + ENDDO + deallocate(ref_in) + +END SUBROUTINE read_radar_ref diff --git a/src/GSD/gsdcloud/smooth.f90 b/src/GSD/gsdcloud/smooth.f90 new file mode 100644 index 0000000000..73f6208091 --- /dev/null +++ b/src/GSD/gsdcloud/smooth.f90 @@ -0,0 +1,98 @@ + SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C$$$ SUBPROGRAM DOCUMENTATION BLOCK +!C . . . . +!C SUBPROGRAM: SMOOTH SMOOTH A METEOROLOGICAL FIELD +!C PRGMMR: STAN BENJAMIN ORG: FSL/PROFS DATE: 90-06-15 +!C +!C ABSTRACT: SHAPIRO SMOOTHER. +!C +!C PROGRAM HISTORY LOG: +!C 85-12-09 S. BENJAMIN ORIGINAL VERSION +!C +!C USAGE: CALL SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C INPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C METEOROLOGICAL FIELD +!C HOLD - REAL ARRAY HOLD(IX,2) +!C HOLDING THE VALUE FOR FIELD +!C IX - INTEGER X COORDINATES OF FIELD +!C IY - INTEGER Y COORDINATES OF FIELD +!C SMTH - REAL +!C +!C OUTPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C SMOOTHED METEOROLOGICAL FIELD +!C +!C REMARKS: REFERENCE: SHAPIRO, 1970: "SMOOTHING, FILTERING, AND +!C BOUNDARY EFFECTS", REV. GEOPHYS. SP. PHYS., 359-387. +!C THIS FILTER IS OF THE TYPE +!C Z(I) = (1-S)Z(I) + S(Z(I+1)+Z(I-1))/2 +!C FOR A FILTER WHICH IS SUPPOSED TO DAMP 2DX WAVES COMPLETELY +!C BUT LEAVE 4DX AND LONGER WITH LITTLE DAMPING, +!C IT SHOULD BE RUN WITH 2 PASSES USING SMTH (OR S) OF 0.5 +!C AND -0.5. +!C +!C ATTRIBUTES: +!C$$$ +!C********************************************************************** +!C********************************************************************** + + + use kinds, only: r_kind,i_kind,r_single + implicit none +!C********************************************************************** + INTEGER(i_kind),INTENT(IN) :: IX,IY + real(r_kind),intent(inout) :: FIELD(IX,IY) + real(r_kind),intent(inout) :: HOLD (IX,2) + real(r_kind),intent(in) :: SMTH +!C********************************************************************** + real(r_kind) :: SMTH1,SMTH2,SMTH3,SMTH4,SMTH5 + INTEGER(i_kind) :: I1,I2,I,J,IT + real(r_kind) :: SUM1,SUM2 + + SMTH1 = 0.25 * SMTH * SMTH + SMTH2 = 0.5 * SMTH * (1.-SMTH) + SMTH3 = (1.-SMTH) * (1.-SMTH) + SMTH4 = (1.-SMTH) + SMTH5 = 0.5 * SMTH + I1 = 2 + I2 = 1 + DO J=2,IY-1 + IT = I1 + I1 = I2 + I2 = IT + DO I = 2,IX-1 + SUM1 = FIELD (I-1,J+1) + FIELD (I-1,J-1) & + + FIELD (I+1,J+1) + FIELD (I+1,J-1) + SUM2 = FIELD (I ,J+1) + FIELD (I+1,J ) & + + FIELD (I ,J-1) + FIELD (I-1,J ) + HOLD(I,I1) = SMTH1*SUM1 + SMTH2*SUM2 + SMTH3*FIELD(I,J) + ENDDO + IF (J /= 2) THEN + DO I=2,IX-1 + FIELD(I,J-1) = HOLD(I,I2) + ENDDO + ENDIF + ENDDO + + + DO I = 2,IX-1 + FIELD (I,IY-1) = HOLD(I,I1) + ENDDO + + DO I = 2,IX-1 + FIELD(I,1) = SMTH4* FIELD(I,1) & + + SMTH5 * (FIELD(I-1,1) + FIELD(I+1,1)) + FIELD(I,IY) = SMTH4* FIELD(I,IY) & + + SMTH5 * (FIELD(I-1,IY) + FIELD(I+1,IY)) + ENDDO + + DO J = 2,IY-1 + FIELD(1,J) = SMTH4* FIELD(1,J) & + + SMTH5 * (FIELD(1,J-1) + FIELD(1,J+1)) + FIELD(IX,J) = SMTH4* FIELD(IX,J) & + + SMTH5 * (FIELD(IX,J-1) + FIELD(IX,J+1)) + ENDDO + + RETURN + END diff --git a/src/GSD/gsdcloud/vinterp_radar_ref.f90 b/src/GSD/gsdcloud/vinterp_radar_ref.f90 new file mode 100644 index 0000000000..314aabd781 --- /dev/null +++ b/src/GSD/gsdcloud/vinterp_radar_ref.f90 @@ -0,0 +1,142 @@ +SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31,h_bk,zh) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: interp_radar_ref radar observation vertical interpolation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine interpolate radar reflectivity vertically +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and vertically +! in mosaic grid (height) +! h_bk - 3D background height +! zh - terrain +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind, r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon + INTEGER(i_kind), intent(in) :: nlat + INTEGER(i_kind), intent(in) :: nsig + INTEGER(i_kind), intent(in) :: Nmsclvl + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_kind), intent(in) :: ref_mosaic31(nlon,nlat,Nmsclvl) + real(r_kind), intent(out):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: msclvl21(21),msclvlAll(31) + DATA msclvl21/1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 6, 7, & + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17/ + DATA msclvlAll/0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16, 18/ +! + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + + real(r_kind) :: ref_mosaic + INTEGER(i_kind) :: i,j, k2, k + +! + if(Nmsclvl < -888 ) then + write(6,*) 'interp_radar_ref: No radar reflectivity data in this subdomain !' + return + endif +! + ref_mos_3d=-99999.0_r_kind + numref=0 + if (Nmsclvl == 31 ) then + DO k=1,Nmsclvl + msclvlAll(k)=msclvlAll(k)*1000.0_r_kind + ENDDO + elseif( Nmsclvl == 21 ) then + msclvlAll=0 + DO k=1,Nmsclvl + msclvlAll(k)=msclvl21(k)*1000.0_r_kind + ENDDO + else + write(6,*) 'interp_radar_ref: Wrong vertical radar mosaic levels' + write(6,*) ' the level read in is:', msclvlAll + call stop2(114) + endif + + DO k2=1,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + heightGSI=h_bk(i,j,k2)+zh(i,j) + if(heightGSI >= msclvlAll(1) .and. heightGSI < msclvlAll(Nmsclvl) ) then + do k=1,Nmsclvl-1 + if( heightGSI >=msclvlAll(k) .and. heightGSI < msclvlAll(k+1) ) ilvl=k + enddo + upref=ref_mosaic31(i,j,ilvl+1) + downref=ref_mosaic31(i,j,ilvl) + if(abs(upref) <90.0_r_kind .and. abs(downref) <90.0_r_kind ) then + wght=(heightGSI-msclvlAll(ilvl))/(msclvlAll(ilvl+1)-msclvlAll(ilvl)) + ref_mosaic=(1-wght)*downref + wght*upref + numref=numref+1 + elseif( abs(upref+99.0_r_kind) < 0.1_r_kind .or. & + abs(downref+99.0_r_kind) <0.1_r_kind ) then + ref_mosaic=-99.0_r_kind + else + ref_mosaic=-99999.0_r_kind + endif + ref_mos_3d(i,j,k2)=max(ref_mos_3d(i,j,k2),ref_mosaic) + else + ref_mos_3d(i,j,k2)=-99999.0_r_kind + endif + ENDDO + ENDDO + ENDDO + +! + DO k2=1,nsig + DO i=2,nlon-1 + ref_mos_3d(i,1,k2)=ref_mos_3d(i,2,k2) + ref_mos_3d(i,nlat,k2)=ref_mos_3d(i,nlat-1,k2) + ENDDO + DO j=2,nlat-1 + ref_mos_3d(1,j,k2)=ref_mos_3d(2,j,k2) + ref_mos_3d(nlon,j,k2)=ref_mos_3d(nlon-1,j,k2) + ENDDO + ref_mos_3d(nlon,nlat,k2)=ref_mos_3d(nlon-1,nlat-1,k2) + ref_mos_3d(nlon,1,k2)=ref_mos_3d(nlon-1,2,k2) + ref_mos_3d(1,nlat,k2)=ref_mos_3d(2,nlat-1,k2) + ref_mos_3d(1,j,k2)=ref_mos_3d(2,2,k2) + ENDDO + + +END SUBROUTINE vinterp_radar_ref diff --git a/src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 b/src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 new file mode 100755 index 0000000000..7017e9e80f --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/ARPS_cldLib.f90 @@ -0,0 +1,1405 @@ +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ARPS_cldLib +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: +! +! ABSTRACT: +! This file include a collection of subroutines that are related to +! cloud analysis from ARPS cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_STABILITY ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & + ,dte_dz_1d) +! +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns stability at a given level given +! 1D temperature and pressure array inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on LAPS cloud analysis code of 07/95 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),INTENT(IN) :: nz ! number of vertical model levels + REAL(r_single) ,INTENT(IN) :: t_1d(nz) ! temperature (degree Kelvin) profile + REAL(r_single) ,INTENT(IN) :: zs_1d(nz) ! heights (m MSL) of each level + REAL(r_single) ,INTENT(IN) :: p_mb_1d(nz)! pressure (mb) at each level + INTEGER(i_kind),INTENT(IN) :: kbtm,ktop ! indices of the bottom and top cloud layer +! +! OUTPUT: + REAL(r_single) ,INTENT(out):: dte_dz_1d(nz) ! stability array +! +! LOCAL: + REAL(r_single) :: thetae_1d(nz) ! (equivalent) potential temperature. +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: k,km1,kp1,klow,khigh + REAL(r_single) :: os_fast +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Calculate Stability +! +!----------------------------------------------------------------------- +! + klow = MAX(kbtm-1,1) + khigh = MIN(ktop+1,nz-1) + + DO k = klow,khigh + thetae_1d(k) = os_fast(t_1d(k), p_mb_1d(k)) + END DO ! k + + dte_dz_1d=0._r_kind + + DO k = kbtm,ktop + km1 = MAX(k-1,1) + kp1 = MIN(k+1,nz-1) + + IF( (zs_1d(kp1) - zs_1d(km1)) <= 0._r_kind) THEN + write(6,*) 'GNRLCLD_mpi, get_stability: Error in get_stability ' + write(6,*) 'GNRLCLD_mpi, get_stability: k,kp1,km1 = ',k,kp1,km1 + write(6,*) 'GNRLCLD_mpi, get_stability: zs_1d(kp1),zs_1d(km1)= ',zs_1d(kp1),zs_1d(km1), & + (zs_1d(kp1) - zs_1d(km1)) + call STOP2(114) + ELSE + dte_dz_1d(k) = (thetae_1d(kp1) - thetae_1d(km1)) & + / (zs_1d(kp1) - zs_1d(km1)) + END IF + END DO ! k + + RETURN +END SUBROUTINE get_stability + + +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION OS_FAST ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION os_fast(tk,p) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! THIS FUNCTION RETURNS THE EQUIVALENT POTENTIAL TEMPERATURE OS +! (K) FOR A PARCEL OF AIR SATURATED AT TEMPERATURE T (K) +! AND PRESSURE P (MILLIBARS). +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (BAKER,SCHLATTER) +! 05/17/1982 +! +! +! MODIFICATION HISTORY: +! 05/11/96 (Jian Zhang) +! Modified for ADAS grid. Add document stuff. +! +!----------------------------------------------------------------------- +! +! Variables declaration +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single) ,INTENT(IN) :: tk ! temperature in kelvin + REAL(r_single) ,INTENT(IN) :: p ! pressure in mb +! +! OUTPUT: + REAL(r_single) :: os_fast ! equivalent potential temperature +! +! LOCAL: + REAL(r_kind) :: b ! empirical const. approx.= latent heat of + ! vaporiz'n for water devided by the specific + ! heat at const. pressure for dry air. + DATA b/2.6518986_r_kind/ + + REAL(r_kind) :: tc,x,w + REAL(r_kind) :: eslo +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + tc = tk - 273.15_r_kind +! +!----------------------------------------------------------------------- +! +! From W routine +! +!----------------------------------------------------------------------- +! + x= eslo(tc) + w= 622._r_kind*x/(p-x) + + os_fast= tk*((1000._r_kind/p)**.286_r_kind)*(EXP(b*w/tk)) + + RETURN + END FUNCTION os_fast + + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_CLOUDTYPE ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & + ,itype,c2_type) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns cloud type at a given point given +! temperature and stability inputs +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 05/1995 +! +! MODIFICATION HISTORY: +! +! 05/11/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + REAL(r_single),INTENT(IN) :: temp_k ! temperature + REAL(r_single),INTENT(IN) :: dte_dz ! stability factor + REAL(r_single),INTENT(IN) :: cbase_m ! height at cloud base level + REAL(r_single),INTENT(IN) :: ctop_m ! height at cloud top level +! +! OUTPUT: + INTEGER(i_kind),INTENT(out):: itype ! cloud type index + CHARACTER (LEN=2) :: c2_type +! +! LOCAL: + CHARACTER (LEN=2) :: c2_cldtyps(10) + + DATA c2_cldtyps /'St','Sc','Cu','Ns','Ac' & + ,'As','Cs','Ci','Cc','Cb'/ +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_kind) :: depth_m,temp_c +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + temp_c = temp_k - 273.15_r_kind + depth_m = ctop_m - cbase_m +! +!----------------------------------------------------------------------- +! +! Go from Stability to Cloud Type +! +!----------------------------------------------------------------------- +! + IF ( temp_c >= -10._r_kind) THEN + IF (dte_dz >= +.001_r_kind) THEN + itype = 1 ! St + ELSE IF (dte_dz < +.001_r_kind .AND. dte_dz >= -.001_r_kind) THEN + itype = 2 ! Sc + ELSE IF (dte_dz < -.001_r_kind .AND. dte_dz >= -.005_r_kind) THEN + itype = 3 ! Cu + ELSE ! dte_dz .lt. -.005 + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE ! depth < 5km + itype = 3 ! Cu + END IF + END IF + + ELSE IF (temp_c < -10._r_kind .AND. temp_c >= -20._r_kind) THEN + + IF (dte_dz < 0._r_kind) THEN + IF(depth_m > 5000) THEN + itype = 10 ! Cb + ELSE + itype = 5 ! Ac + END IF + ELSE + itype = 6 ! As + END IF + + ELSE ! temp_c.lt.-20. + + IF (dte_dz >= +.0005_r_kind) THEN + itype = 7 ! Cs + ELSE IF (dte_dz < +.0005_r_kind .AND. dte_dz >= -.0005_r_kind) THEN + itype = 8 ! Ci + ELSE ! dte_dz .lt. -.0005 + itype = 9 ! Cc + END IF + + IF(depth_m > 5000 .AND. dte_dz < -.0000_r_kind) THEN + itype = 10 ! Cb + END IF + + END IF + + c2_type = c2_cldtyps(itype) + + RETURN +END SUBROUTINE get_cloudtype + +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nz ! number of model vertical levels + REAL(r_single),intent(in) :: zs_1d(nz) ! physical height (m) at each scalar level + REAL(r_single),intent(in) :: p_mb_1d(nz)! pressure (mb) at each level + REAL(r_single),intent(in) :: t_1d(nz) ! temperature (K) at each level + + REAL(r_single),intent(in) :: zcb ! cloud base height (m) + REAL(r_single),intent(in) :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL(r_single),intent(out) :: ql(nz) ! liquid water content (g/kg) + REAL(r_single),intent(out) :: qi(nz) ! ice water content (g/kg) + REAL(r_single),intent(out) :: cldt(nz) +! +! LOCAL: + REAL(r_single) :: calw(200) + REAL(r_single) :: cali(200) + REAL(r_single) :: catk(200) + REAL(r_single) :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL(r_single) :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL(r_single) :: c,a1,b1,c1,a2,b2,c2 + REAL(r_single) :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL(r_single) :: arg,fraclw,tlwc + REAL(r_single) :: temp,press,zbase,alw,zht,ht,y + REAL(r_single) :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER(i_kind):: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL(r_single) :: dtdz,dttdz,zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0_r_single + cali(i)=0.0_r_single + END DO +! if(i_prt.le.20) then +! i_prt=i_prt+1 +! l_prt=.true. +! else +! l_prt=.false. +! endif +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0_r_single ! m + rv=461.5_r_single ! J/deg/kg + rair=287.04_r_single ! J/deg/kg + grav=9.81_r_single ! m/s2 + cp=1004._r_single ! J/deg/kg + rlvo=2.5003E+6_r_single ! J/kg + rlso=2.8339E+6_r_single ! J/kg + dlvdt=-2.3693E+3_r_single ! J/kg/K + eso=610.78_r_single ! pa + c=0.01_r_single + a1=8.4897_r_single + b1=-13.2191_r_single + c1=4.7295_r_single + a2=10.357_r_single + b2=-28.2416_r_single + c2=8.8846_r_single +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2._r_single + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0_r_single + zbase = zcb + nlevel = ((zctop-zcb)/100.0_r_single)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0_r_single + calw(1)= 0.0_r_single + cali(1)= 0.0_r_single + catk(1)= temp + entr(1)= 1.0_r_single + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622_r_single*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0_r_single+0.621_r_single*es*rl/(press*rair*temp))/ & + (cp+0.621_r_single*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15_r_single-temp)*dlvdt + arg = rl*(temp-273.15_r_single)/273.15_r_single/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622_r_single*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001_r_single +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032_r_single) THEN + y = -11.0_r_single*ht+1.0_r_single ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177_r_single) THEN + y = -1.4_r_single*ht+0.6915_r_single ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726_r_single) THEN + y = -0.356_r_single*ht+0.505_r_single ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5_r_single) THEN + y = -0.0608_r_single*ht+0.2912_r_single ! y(ht=1.5) = 0.2 + ELSE + y = 0.20_r_single + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15_r_single) THEN + IF(temp > 248.15_r_single) THEN + fraclw=0.05*(temp-248.15_r_single) + ELSE + fraclw=0.0_r_single + END IF + ELSE + fraclw=1.0_r_single + END IF + + tlwc=1000._r_single*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1._r_single-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0_r_single + qi(ip)=0.0_r_single + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (calw(j)-calw(j-1))*0.01_r_single+calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100._r_single)* & + (cali(j)-cali(j-1))*0.01_r_single+cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100._r_single)* & + (catk(j)-catk(j-1))*0.01_r_single & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100._r_single)* & + (entr(j)-entr(j-1))*0.01_r_single & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! + RETURN +END SUBROUTINE get_sfm_1d + + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE PCP_TYPE_3D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine returns 3D cloud and precipitation type field. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/1996 Based on the LAPS cloud analysis code developed by +! Steve Albers. +! +! This program modifies the most significant 4 bits of the integer +! array by inserting multiples of 16. +! +! MODIFICATION HISTORY: +! +! 05/16/96 (J. Zhang) +! Modified for ADAS format. Added full documentation. +! 01/20/98 (J. Zhang) +! Fixed a bug that no precip. type was assigned for a +! grid point at the top of the radar echo with Tw +! falling in the range of 0 to 1.3 degree C. +! 01/21/98 (J. Zhang) +! Fixed a bug that does the freezing/refreezing test +! on ice precipitates. +! 02/17/98 (J. Zhang) +! Change the hail diagnose procedure. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind), intent(in) :: nx,ny,nz ! Model grid size + REAL(r_single), intent(in) :: temp_3d(nx,ny,nz) ! temperature (K) + REAL(r_single), intent(in) :: rh_3d(nx,ny,nz) ! relative humudity + REAL(r_single), intent(in) :: p_pa_3d(nx,ny,nz) ! pressure (Pascal) + REAL(r_kind), intent(in) :: radar_3d(nx,ny,nz) ! radar refl. (dBZ) +! +! OUTPUT: + INTEGER(i_kind), intent(out) :: istatus + INTEGER(i_kind), intent(out) :: cldpcp_type_3d(nx,ny,nz)! cld/precip type + LOGICAL :: l_mask(nx,ny) ! "Potential" Precip Type +! +! LOCAL functions: + REAL(r_kind) :: wb_melting_thres ! define melting temp. thresh. + REAL(r_kind) :: tw ! for wet-bulb temp calcl'n +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: itype ! cld/precip type index + INTEGER(i_kind) :: i,j,k,k_upper + REAL(r_kind) :: t_c,td_c,t_wb_c,temp_lower_c,temp_upper_c,tbar_c & + ,p_mb,thickns,frac_below_zero + INTEGER(i_kind) :: iprecip_type,iprecip_type_last,iflag_melt & + ,iflag_refreez + REAL(r_kind) :: zero_c,rlayer_refreez_max,rlayer_refreez + INTEGER(i_kind) :: n_zr,n_sl,n_last + REAL(r_kind) :: tmelt_c,x +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +!----------------------------------------------------------------------- +! + return + istatus=0 + wb_melting_thres = 1.3 ! Units are C +! +!----------------------------------------------------------------------- +! +! Stuff precip type into cloud type array +! 0 - No Precip +! 1 - Rain +! 2 - Snow +! 3 - Freezing Rain +! 4 - Sleet +! 5 - Hail +! +!----------------------------------------------------------------------- +! + zero_c = 273.15_r_kind + rlayer_refreez_max = 0.0_r_kind + + n_zr = 0 + n_sl = 0 + n_last = 0 + + DO j = 1,ny-1 + DO i = 1,nx-1 + + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + iprecip_type_last = 0 + + DO k = nz-1,1,-1 + + IF(radar_3d(i,j,k) >= 0._r_kind.OR. l_mask(i,j)) THEN +! +!----------------------------------------------------------------------- +! +! Set refreezing flag +! +!----------------------------------------------------------------------- +! + t_c = temp_3d(i,j,k) - zero_c +! compute dew point depression. +! td_c = dwpt(t_c,rh_3d(i,j,k)) + x = 1._r_kind-0.01_r_kind*rh_3d(i,j,k) + td_c =t_c-(14.55_r_kind+0.114_r_kind*t_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_c)*x**14 + + p_mb = 0.01_r_kind*p_pa_3d(i,j,k) + + tmelt_c = wb_melting_thres + t_wb_c = tw(t_c,td_c,p_mb) + + IF(t_wb_c < 0._r_kind) THEN + IF(iflag_melt == 1) THEN +! +!----------------------------------------------------------------------- +! +! Integrate below freezing temperature times column thickness +! - ONLY for portion of layer below freezing +! +!----------------------------------------------------------------------- +! + temp_lower_c = t_wb_c + k_upper = MIN(k+1,nz-1) +! +!----------------------------------------------------------------------- +! +! For simplicity and efficiency, the assumption is here made that +! the wet bulb depression is constant throughout the level. +! +!----------------------------------------------------------------------- +! + temp_upper_c = t_wb_c + ( temp_3d(i,j,k_upper) & + - temp_3d(i,j,k)) + IF(temp_upper_c <= 0._r_kind) THEN + frac_below_zero = 1.0_r_kind + tbar_c = 0.5_r_kind * (temp_lower_c + temp_upper_c) + + ELSE ! Layer straddles the freezing level + frac_below_zero = temp_lower_c & + / (temp_lower_c - temp_upper_c) + tbar_c = 0.5_r_kind * temp_lower_c + + END IF + + thickns = p_pa_3d(i,j,k_upper) - p_pa_3d(i,j,k) + rlayer_refreez = rlayer_refreez & + + ABS(tbar_c * thickns * frac_below_zero) + + IF(rlayer_refreez >= 25000._r_kind) THEN + iflag_refreez = 1 + END IF + + rlayer_refreez_max = & + MAX(rlayer_refreez_max,rlayer_refreez) + + END IF ! iflag_melt = 1 + + ELSE ! Temp > 0C + iflag_refreez = 0 + rlayer_refreez = 0.0 + + END IF ! T < 0.0c, Temp is below freezing +! +!----------------------------------------------------------------------- +! +! Set melting flag +! +!----------------------------------------------------------------------- +! + IF(t_wb_c >= tmelt_c) THEN + iflag_melt = 1 + END IF + + IF(t_wb_c >= tmelt_c) THEN ! Melted to Rain + iprecip_type = 1 + + ELSE ! Check if below zero_c (Refrozen Precip or Snow) + IF(t_wb_c < 0.0_r_kind) THEN + IF(iflag_melt == 1) THEN + IF(iprecip_type_last == 1 .OR.iprecip_type_last == 3) THEN + ! test if rain or zr freeze + IF(iflag_refreez == 0) THEN ! Freezing Rain + n_zr = n_zr + 1 + IF(n_zr < 30) THEN +! WRITE(6,5)i,j,k,t_wb_c,temp_3d(i,j,k) & +! ,rh_3d(i,j,k) + 5 FORMAT('zr',3I3,2F8.2,f8.1) + END IF + iprecip_type = 3 + + ELSE ! (iflag_refreez = 1) ! Sleet + n_sl = n_sl + 1 + iprecip_type = 4 + END IF ! iflag_refreez .eq. 0 + ELSE + iprecip_type = iprecip_type_last ! Unchanged + n_last = n_last + 1 + IF(n_last < 5) THEN +! WRITE(6,*)'Unchanged Precip',i,j,k,t_wb_c + END IF + END IF ! liquid precip. at upper level? + + ELSE ! iflag_melt =0 ! Snow + iprecip_type = 2 + + END IF ! iflag_melt = 1? + ELSE ! t_wb_c >= 0c, and t_wb_c < tmelt_c + + IF (iprecip_type_last == 0) THEN ! 1/20/98 + iprecip_type = 1 ! rain:at echo top and 0= tmelt_c + + ELSE ! radar_3d < 0dBZ; No Radar Echo + iprecip_type = 0 + iflag_melt = 0 + iflag_refreez = 0 + rlayer_refreez = 0.0_r_kind + + END IF ! radar_3d(i,j,k).ge.0. .or. l_mask(i,j); Radar Echo? +! +!----------------------------------------------------------------------- +! +! Insert most sig 4 bits into array +! +!----------------------------------------------------------------------- +! + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + + iprecip_type_last = iprecip_type + + END DO ! k + END DO ! j + END DO ! i + + DO j = 1,ny-1 + DO i = 1,nx-1 + DO k = 1,nz-1 + IF(radar_3d(i,j,k) >= 50._r_kind) THEN + iprecip_type = 5 + itype = cldpcp_type_3d(i,j,k) + itype = itype - (itype/16)*16 ! Initialize the 4 bits + itype = itype + iprecip_type * 16 ! Add in the new value + cldpcp_type_3d(i,j,k) = itype + END IF + END DO ! k + END DO ! j + END DO ! i + + istatus=1 + + RETURN +END SUBROUTINE pcp_type_3d + +! +! +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SLWC1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! This routine calls a subroutine "lwc_rep" which calculates +! the adiabatic liquid water content. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/13/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: iflag_slwc ! indicator for LWC scheme option + INTEGER(i_kind),intent(in) :: nk ! number of model vertical levels + REAL(r_single),intent(in) :: t_1d(nk) ! temperature (k) in one model column + REAL(r_single),intent(in) :: zs_1d(nk) ! heights (m) at grd pts in one model column + REAL(r_single),intent(in) :: p_pa_1d(nk) ! pressure (pa) in one model column + REAL(r_single),intent(in) :: cbase_m,ctop_m ! heights (m) of cloud base and top levels + INTEGER(i_kind),intent(in) :: kbase,ktop ! vertical index of cloud base and top levels +! +! OUTPUT: + REAL(r_single),intent(out) :: slwc_1d(nk) ! estimated adiabatic liquid water +! +! LOCAL: + INTEGER(i_kind) :: i_status1,i_status2 ! flag for subroutine calling +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind):: k + REAL(r_single) :: p_low,p_high,cbase_pa,cbase_k,ctop_k,frac_k & + ,grid_top_pa,grid_top_k + REAL(r_single) :: fraction,thickness,dlog_space + REAL(r_single) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize +! +!----------------------------------------------------------------------- +! + DO k = 1,nk + slwc_1d(k) = 0.0_r_single + END DO + + IF(ctop_m > cbase_m) THEN +! +!----------------------------------------------------------------------- +! +! Determine Lowest and Highest Grid Points within the cloud +! +!----------------------------------------------------------------------- +! + IF(ktop >= kbase .AND. kbase >= 2) THEN +! +!----------------------------------------------------------------------- +! +! Get cloud base pressure and temperature +! +!----------------------------------------------------------------------- +! + cbase_pa = -999._r_single ! Default value is off the grid + DO k = 1,nk-2 + IF(zs_1d(k+1) > cbase_m .AND. zs_1d(k) <= cbase_m) THEN + thickness = zs_1d(k+1) - zs_1d(k) + fraction = (cbase_m - zs_1d(k))/thickness + p_low = p_pa_1d(k) + p_high = p_pa_1d(k+1) + dlog_space = LOG(p_high/p_low) + cbase_pa = p_low * EXP(dlog_space*fraction) + END IF + END DO ! k + + frac_k=(cbase_m-zs_1d(kbase-1))/(zs_1d(kbase)-zs_1d(kbase-1)) + IF(frac_k /= fraction) & + PRINT*,' **GET_SLWC1D** frac=',fraction,' frac_k=',frac_k + + cbase_k = t_1d(kbase-1)*(1.0_r_single-frac_k) + t_1d(kbase)*frac_k +! +!----------------------------------------------------------------------- +! +! Get cloud top temperature +! +!----------------------------------------------------------------------- +! + frac_k = (ctop_m-zs_1d(ktop-1)) / (zs_1d(ktop)-zs_1d(ktop-1)) + ctop_k = t_1d(ktop-1)*(1.0_r_single - frac_k) + t_1d(ktop) * frac_k +! +!----------------------------------------------------------------------- +! +! Calculate SLWC at each vertical grid point. For each level +! we use an assumed cloud extending from the actual cloud base +! to the height of the grid point in question. +! +!----------------------------------------------------------------------- +! + DO k=kbase,ktop + grid_top_pa = p_pa_1d(k) + grid_top_k = t_1d(k) + + CALL slwc_revb(cbase_pa,cbase_k & + ,grid_top_pa,grid_top_k,ctop_k & + ,adiabatic_lwc,adjusted_lwc,adjusted_slwc & + ,i_status1,i_status2) +! + IF(i_status2 == 1) THEN + IF(iflag_slwc == 1) THEN + slwc_1d(k) = adiabatic_lwc + ELSE IF(iflag_slwc == 2) THEN + slwc_1d(k) = adjusted_lwc + ELSE IF(iflag_slwc == 3) THEN + slwc_1d(k) = adjusted_slwc + END IF + ELSE + WRITE(6,*)' Error Detected in SLWC' + END IF + END DO ! k + END IF ! ktop > kbase & kbase > 2, thick enough cloud exists + END IF ! ctop_m > cbase_m, cloud exists + + RETURN +END SUBROUTINE get_slwc1d + +SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & + adiabatic_lwc,adjusted_lwc,adjusted_slwc, & + i_status1,i_status2) +! +!.......................HISTORY............................. +! +! WRITTEN: CA. 1982 BY W. A. COOPER IN HP FORTRAN 4 +! +!....... CALCULATES TEMPERATURE T AND LIQUID WATER CONTENT FROM +!.. CLOUD BASE PRESSURE P0 AND TEMPERATURE T0, FOR ADIABATIC +!.. ASCENT TO THE PRESSURE P. +!.. -> INPUT: CLOUD BASE PRESSURE P0 AND TEMPERATURE T0 +!.. PRESSURE AT OBSERVATION LEVEL P +!.. -> OUTPUT: "ADIABATIC" TEMPERATURE T AND LIQUID WATER CONTENT +! +! MODIFIED: November 1989 by Paul Lawson for LAPS/WISP. Routine +! now calculates adiabatic liquid water content +! (ADIABATIC_LWC) using cloud base pressure and grid-top +! temperature and pressure. Also calculated are ADJUSTED_LWC, +! which adjusts ADIABATIC_LWC using an empirical cloud +! water depletion algorithm, and ADJUSTED_SLWC, which is +! ADIABATIC_LWC in regions where T < 0 C adjusted +! using an empirical algorithm by Marcia Politovich. +! +! Subroutine is now hardwired for stratiform cloud only. +! Can be modified to include Cu with input from LAPS main. +! +! revb: ca 12/89 Calculate adiabatic lwc by going from cloud +! base to LAPS grid level instead to cloud top, thus +! helping to better calculate in layer clouds. +! Add TG (grid temperature) to calcualtion. +! +! revc: 2/27/90 Correct error in code. Zero-out slwc when grid +! temperature (GT) > 0. +! +! J.Z.: 4/7/97 Correct error in code +! Grid temperature should be TG, not GT. +! +! +! OUTPUTS: ADIABATIC_LWC +! ADJUSTED_LWC +! ADJUSTED_SLWC +! I_STATUS1 - 1 when -20 < cld_top_temp < 0 for Stratus +! 0 Otherwise +! I_STATUS2 - 1 when valid input data provided from main +! + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE + + real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k + real(r_single), intent(out) :: adiabatic_lwc,adjusted_lwc,adjusted_slwc + INTEGER(i_kind),intent(out) :: i_status1,i_status2 + + real(r_kind) :: eps,cpd,cw,rd,alhv + DATA eps/0.622_r_kind/,cpd/1.0042E3_r_kind/,cw/4.218E3_r_kind/,rd/287.05_r_kind/,alhv/2.501E6_r_kind/ + INTEGER(i_kind) :: cty,i + real(r_kind) :: p0,p,t0,tg,ctt,tk,e,r,cpt,t1,thetaq,rv,t,tw + real(r_kind) :: vapor +! +! + i_status1=1 + i_status2=1 +! 2 Print *,'ENTER: P-BASE(mb), T-BASE(C), P-TOP, T-TOP, CLD TYPE' +! READ(5,*) P0, T0, P, CTT, CTY +! If(CTY.ne.0.and.CTY.ne.1) Go to 2 +! +! Hardwire cloud type (CTY) for stratus for now +! + cty=0 +! +!.....Convert Pa to mb and Kelvin to Celcius +! + p0 = cb_pa/100._r_kind + p = gt_pa/100._r_kind + t0 = cb_k - 273.15_r_kind + tg = gt_k - 273.15_r_kind + ctt= ct_k - 273.15_r_kind +! Print *, 'CTT in Sub = ', CTT +! +! Check for valid input data... +! + IF(p0 > 1013._r_kind.OR.p0 < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(t0 > 50._r_kind.OR.t0 < -70._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! + IF(p > 1013._r_kind.OR.p < 50._r_kind) THEN + i_status2=0 + RETURN + ELSE + END IF +! +! Set I_STATUS1 = F if 0 < cld top < -20 C (for stratus). +! + IF(tg >= 0._r_kind.OR.ctt < -20._r_kind) i_status1=0 +! + tk=t0+273.15_r_kind + e=vapor(t0) + r=eps*e/(p0-e) + cpt=cpd+r*cw + thetaq=tk*(1000._r_kind/(p0-e))**(rd/cpt)*EXP(alhv*r/(cpt*tk)) +! 1ST APPROX + t1=tk + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) +! SUCCESSIVE APPROXIMATIONS + DO i=1,10 + e=vapor(t1-273.15_r_kind) + rv=eps*e/(p-e) + t1=(thetaq/((1000._r_kind/(p-e))**(rd/cpt)*EXP(alhv*rv/(cpt*t1))) & + +t1)/2._r_kind + t=t1-273.15_r_kind +! Print *, P0,T0,P,T,E,RV,THETAQ + END DO +! GET LWC + e=vapor(t) + rv=eps*e/(p-e) + tw=r-rv + adiabatic_lwc=tw*p*28.9644_r_kind/(8.314E7_r_kind*t1)*1.e9_r_kind + IF(adiabatic_lwc < 0._r_kind) adiabatic_lwc=0._r_kind +! Print *, 'Adiabtic LWC = ', ADIABATIC_LWC + IF(tg >= 0._r_kind) THEN +! + adjusted_slwc=0._r_kind ! Added 2/27/90 +! + + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + END IF + END IF + ELSE + IF(cty == 0._r_kind) THEN + IF(ctt < -20._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -20._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + ELSE + IF(ctt < -25._r_kind) THEN + adjusted_lwc=0._r_kind + adjusted_slwc=0._r_kind + ELSE IF(ctt < -15._r_kind.AND.ctt >= -25._r_kind) THEN + adjusted_lwc=adiabatic_lwc/8._r_kind + adjusted_slwc=adiabatic_lwc/8._r_kind + ELSE IF(ctt < -10._r_kind.AND.ctt >= -15._r_kind) THEN + adjusted_lwc=adiabatic_lwc/4._r_kind + adjusted_slwc=adiabatic_lwc/4._r_kind + ELSE + adjusted_lwc=adiabatic_lwc/2._r_kind + adjusted_slwc=adiabatic_lwc/2._r_kind + END IF + END IF + END IF +! Print *,'Adjusted LWC = ', ADJUSTED_LWC +! Print *,'Adjusted SLWC = ', ADJUSTED_SLWC +END SUBROUTINE slwc_revb + +! FUNCTION TO CALCULATE VAPOR PRESSURE: +! + + FUNCTION vapor(tfp) +! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF +! LESS THAN 0, ASSUMED TO BE FROST POINT. +! ROUTINE CODES GOFF-GRATCH FORMULA + use kinds, only: i_kind,r_kind + IMPLICIT NONE + + real(r_kind), intent(in) :: tfp + real(r_kind) :: vapor + +! + real(r_kind) :: tvap, e + + tvap=273.16_r_kind+tfp + IF(tfp > 0.) GO TO 1 +! THIS IS ICE SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-9.09718_r_kind*(273.16_r_kind/tvap-1._r_kind)- & + 3.56654_r_kind*LOG10(273.16_r_kind/tvap) & + +0.876793_r_kind*(1.-tvap/273.16_r_kind) + vapor=6.1071_r_kind*10._r_kind**e + RETURN + 1 CONTINUE +! THIS IS WATER SATURATION VAPOR PRESSURE + IF(tvap <= 0) tvap=1E-20_r_kind + e=-7.90298_r_kind*(373.16_r_kind/tvap-1._r_kind)+ & + 5.02808_r_kind*LOG10(373.16_r_kind/tvap) & + -1.3816E-7_r_kind*(10._r_kind**(11.344_r_kind*& + (1._r_kind-tvap/373.16_r_kind))-1._r_kind) & + +8.1328E-3_r_kind*(10._r_kind**(3.49149_r_kind& + *(1-373.16_r_kind/tvap))-1) + vapor=1013.246_r_kind*10._r_kind**e + RETURN + END FUNCTION vapor diff --git a/src/GSD/gsdcloud4nmmb/BackgroundCld.f90 b/src/GSD/gsdcloud4nmmb/BackgroundCld.f90 new file mode 100755 index 0000000000..96857711db --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/BackgroundCld.f90 @@ -0,0 +1,193 @@ +SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & + zh,pt_ll,eta1_ll,aeta1_ll,regional,wrf_mass_regional) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BackgroundCld Ingest background fields for cloud analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine reads in background hydrometeor fields for cloud analysis +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2010-04-26 Hu delete the module gridmod and guess_grids. +! transfer information subroutine dummy variables +! +! +! input argument list: +! mype - processor ID +! lon2 - no. of lons on subdomain (buffer points on ends) +! lat2 - no. of lats on subdomain (buffer points on ends) +! nsig - no. of vertical levels +! tbk - 3D background potential temperature (K) +! psbk - 2D background surface pressure (hPa) +! q - 3D moisture (water vapor mixing ratio kg/kg) +! zh - terrain +! pt_ll - vertical coordinate +! eta1_ll - vertical coordinate +! aeta1_ll - vertical coordinate +! regional - if regional +! wrf_mass_regional - if mass core +! +! output argument list: +! pbk - 3D background pressure (hPa) +! hbk - 3D height above the ground (not the sea level) +!!!! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + use constants, only: rd_over_cp, h1000 + use constants, only: rd, grav, half, rad2deg + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: lon2 + integer(i_kind),intent(in):: lat2 + integer(i_kind),intent(in):: nsig + + real(r_kind), intent(in) :: pt_ll + real(r_kind), intent(in) :: eta1_ll(nsig+1) ! + real(r_kind), intent(in) :: aeta1_ll(nsig) ! + logical, intent(in) :: regional ! .t. for regional background/analysis + logical, intent(in) :: wrf_mass_regional ! + + +! background +! +! read in from WRF +! + real(r_single),intent(inout) :: tbk(lon2,lat2,nsig) ! temperature + real(r_single),intent(inout) :: psbk(lon2,lat2) ! surface pressure + real(r_single),intent(in) :: zh(lon2,lat2) ! terrain elevation + real(r_single),intent(inout) :: q(lon2,lat2,nsig) ! moisture +! +! derived fields +! + real(r_single),intent(out) :: hbk(lon2,lat2,nsig)! height + real(r_single),intent(out) :: pbk(lon2,lat2,nsig)! pressure hPa +! real(r_single),intent(out) :: z_lcl(lon2,lat2) ! lifting condensation level +! + real(r_single) :: cv_bk(lon2,lat2,nsig) ! cloud cover + real(r_single) :: t_k(lon2,lat2,nsig) ! temperature in C + +! +! misc. +! + INTEGER :: i,j,k + + REAL(r_single) :: rdog, h, dz, rl + REAL(r_single) :: height(nsig+1) + real(r_single) :: q_integral(lon2,lat2) + real(r_single) :: deltasigma, psfc_this + +! +!================================================================ +! + q_integral=1 + do k=1,nsig + deltasigma=eta1_ll(k)-eta1_ll(k+1) + do j=1,lat2 + do i=1,lon2 + q(i,j,k) = q(i,j,k)/(1.0_r_kind-q(i,j,k)) ! water vapor mixing ratio (kg/kg) + q_integral(i,j)=q_integral(i,j)+deltasigma*q(i,j,k) + enddo + enddo + enddo + do j=1,lat2 + do i=1,lon2 + psfc_this=pt_ll+(psbk(i,j)-pt_ll)/q_integral(i,j) + psbk(i,j)= psfc_this + enddo + enddo + +! +! assign CAPE as 0, this part needs more work +! +! gsfc(:,:,3)=0.0 ! CAPE, we need but not included in wrf_inout +! 1: land use; 2: sfc soil T; 3: CAPE +! +! get land use and convert latitude and longitude back to degree +! xland=gsfc(:,:,1) +! soil_tbk=gsfc(:,:,2) +! +! get virtual potential temperature (thv) +! +! thv=0.0 +! do k=1,nsig +! do j=1,nlat +! do i=1,nlon +! rl=qr(i,j,k)+qs(i,j,k)+qg(i,j,k)+qc(i,j,k)+qi(i,j,k) +! thv(i,j,k)=tbk(i,j,k)*(1.0+0.61*q(i,j,k)-rl) +! ENDDO +! ENDDO +! ENDDO +!! +! +! now get pressure (pbk) and height (hbk) at each grid point +! + if(regional .and. wrf_mass_regional ) then + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + pbk(i,j,k)=aeta1_ll(k)*(psbk(i,j)-pt_ll)+pt_ll + end do + end do + end do + +! Compute geopotential height at midpoint of each layer + rdog = rd/grav + do j=1,lat2 + do i=1,lon2 + k = 1 + h = rdog * tbk(i,j,k) + dz = h * log(psbk(i,j)/pbk(i,j,k)) + height(k) = zh(i,j) + dz + + do k=2,nsig + h = rdog * half * (tbk(i,j,k-1)+tbk(i,j,k)) + dz = h * log(pbk(i,j,k-1)/pbk(i,j,k)) + height(k) = height(k-1) + dz + end do + + do k=1,nsig + hbk(i,j,k)=height(k) - zh(i,j) + end do + end do + end do + else + write(6,*) ' Only wrf mass grid is done for cloud analysis ' + write(6,*) ' You are choosing grid that is not recoginzed by cloud analysis' + call stop2(114) + endif + + do k=1,nsig + do j=1,lat2 + do i=1,lon2 + tbk(i,j,k)=tbk(i,j,k)*(h1000/pbk(i,j,k))**rd_over_cp + enddo + enddo + enddo + +!mhu call BckgrndCC(lon2,lat2,nsig,tbk,pbk,q,hbk,zh, & +!mhu cv_bk,t_k,z_lcl) ! out + +END SUBROUTINE BackgroundCld diff --git a/src/GSD/gsdcloud4nmmb/BckgrndCC.f90 b/src/GSD/gsdcloud4nmmb/BckgrndCC.f90 new file mode 100755 index 0000000000..0fefb28c7e --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/BckgrndCC.f90 @@ -0,0 +1,159 @@ +SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & + cv_bk,t_k,z_lcl) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: BckgrndCC generate background field for +! fractional cloud cover based on RH +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-27 +! +! ABSTRACT: +! This subroutine calculate cloud field based on background fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2016-02-10 S.Liu Change subdomain boundary to cover full subdomain +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! tbk - 3D background potentional temperature (K) +! pbk - 3D background pressure (hPa) +! q - 3D moisture (kg/kg) +! hbk - 3D height +! zh - terrain +! +! output argument list: +! cv_bk - 3D background cloud cover +! t_k - 3D temperature in K +! z_lcl - lifting condensation level +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_single,i_kind,r_kind + use constants, only: h1000, rd_over_cp, g_over_rd + + implicit none + + integer(i_kind),intent(in):: nlon,nlat,nsig +! background +! +! read in from WRF +! + real(r_single),intent(in) :: tbk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain elevation + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture + real(r_single),intent(in) :: hbk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure + + real(r_single),intent(out) :: t_k(nlon,nlat,nsig) ! temperature in K + real(r_single),intent(out) :: z_lcl(nlon,nlat) ! lifting condensation level + real(r_single),intent(out) :: cv_bk(nlon,nlat,nsig)! cloud cover + +! CONSTANTS: + real(r_single) :: gamma_d ! dry adiabatic lapse rate (K/m) + real(r_single) :: z_ref_lcl + PARAMETER(z_ref_lcl = 180.0_r_single) + +! misc. +! + real(r_single) :: rhbk(nlon,nlat,nsig) ! rh + + INTEGER :: i,j,k + + + REAL(r_kind) :: f_qvsat + REAL(r_kind) :: qvsat + REAL(r_kind) :: rh_to_cldcv + + REAL(r_kind) :: z_ref,x + REAL(r_kind) :: arg,arg2, t_ref_c, td_ref_c + REAL(r_kind) :: frac_z, t_ref_k,rh_ref + +! +!================================================================ +! + gamma_d = g_over_rd/rd_over_cp +! +! get the RH +! + do k=1,nsig + do j=1,nlat + do i=1,nlon + t_k(i,j,k)=tbk(i,j,k)*(pbk(i,j,k)/h1000)**rd_over_cp + qvsat=f_qvsat(pbk(i,j,k)*100.0_r_kind,t_k(i,j,k)) + ! Saturation water vapor specific humidity + qvsat = qvsat/(1.0 - qvsat) ! convert to saturation mixing ratio (kg/kg) + rhbk(i,j,k)=100._r_kind*MIN(1._r_kind,MAX(0._r_kind,(q(i,j,k)/qvsat))) + ! q is mixing ration kg/kg + enddo + enddo + enddo +! +! Find the lifting condensation level +! + z_lcl = -99999.0_r_kind + do j=2,nlat + do i=2,nlon + z_ref = z_ref_lcl + zh(i,j) + IF (z_ref <= hbk(i,j,2) .OR. z_ref > hbk(i,j,nsig-1)) THEN + write(6,*) 'Error, ref.level is out of bounds at pt:' & + ,i,j,z_ref,hbk(i,j,2),hbk(i,j,nsig-1) + call STOP2(114) + END IF + + DO k = 3,nsig-1 + IF ( z_ref < hbk(i,j,k) .and. z_ref >= hbk(i,j,k-1)) THEN + frac_z = (z_ref-hbk(i,j,k-1))/(hbk(i,j,k)-hbk(i,j,k-1)) + t_ref_k = t_k(i,j,k-1)+ frac_z*(t_k(i,j,k)-t_k(i,j,k-1)) + t_ref_c = t_ref_k - 273.15_r_kind +! + rh_ref = rhbk(i,j,k-1)+ frac_z*(rhbk(i,j,k)-rhbk(i,j,k-1)) +! compute dew point depression. +! td_ref_c = dwpt(t_ref_c,rh_ref) + x = 1._r_kind-0.01_r_kind*rh_ref + td_ref_c =t_ref_c-(14.55_r_kind+0.114_r_kind*t_ref_c)*x+ & + ((2.5_r_kind+0.007_r_kind*t_ref_c)*x)**3+ & + (15.9_r_kind+0.117_r_kind*t_ref_c)*x**14 + + END IF + END DO ! k = 2,nz-1 +! + z_lcl(i,j) = z_ref + (t_ref_c - td_ref_c)/gamma_d + z_lcl(i,j) = min(hbk(i,j,nsig-1),max(z_lcl(i,j),hbk(i,j,2))) + enddo + enddo +! +! get background cloud cover +! + cv_bk=0.0_r_kind + do k=1,nsig + do j=1,nlat + do i=1,nlon + IF (hbk(i,j,k) >= z_lcl(i,j)) THEN + arg = hbk(i,j,k) - zh(i,j) + arg2=rhbk(i,j,k)*0.01_r_kind + cv_bk(i,j,k) = rh_to_cldcv(arg2,arg) + ENDIF + enddo + enddo + enddo +! + +END SUBROUTINE BckgrndCC diff --git a/src/GSD/gsdcloud4nmmb/CheckCld.f90 b/src/GSD/gsdcloud4nmmb/CheckCld.f90 new file mode 100755 index 0000000000..795eaa9972 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/CheckCld.f90 @@ -0,0 +1,292 @@ +SUBROUTINE check_cloud(mype,nlat,nlon,nsig,q,qr,qs,qg,qc,qi,tcld,pbk,h_bk, & + mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,cstation,& + sat_ctp,cld_cover_3d,xland) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: save_cloudResults writes out diagnostics on cloud/hydrometeor analysis +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-27 +! +! ABSTRACT: +! This subroutine writes out diagnostics on cloud analysis results +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! pbk - 3D background pressure (hPa) +! q - 3D moisture (water vapor mixing ratio) +! qr - 3D rain mixing ratio (kg/kg) +! qs - 3D snow mixing ratio (kg/kg) +! qg - 3D graupel mixing ratio (kg/kg) +! qc - 3D cloud water mixing ratio (kg/kg) +! qi - 3D cloud ice mixing ratio (kg/kg) +! tcld - 3D in-cloud temperature (K) +! +! mxst_p - maximum observation number +! NVARCLD_P - first dimension of OLCD +! numsao - observation number +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind, r_double + use guess_grids, only: ges_tv,ges_q + use guess_grids, only: ges_qc,ges_qi,ges_qr,ges_qs,ges_qg,ges_tten + use constants, only: rd_over_cp, h1000 + use gridmod, only: jlon1,ilat1,istart,jstart + + implicit none + + integer (i_kind),intent(in) :: nlat,nlon,nsig + integer (i_kind),intent(in) :: mype + +! background +! +! read in from WRF +! + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, mixing ratio (kg/kg) + real(r_single),intent(in) :: qr(nlon,nlat,nsig) ! rain + real(r_single),intent(in) :: qs(nlon,nlat,nsig) ! snow + real(r_single),intent(in) :: qg(nlon,nlat,nsig) ! graupel + real(r_single),intent(in) :: qc(nlon,nlat,nsig) ! cloud water + real(r_single),intent(in) :: qi(nlon,nlat,nsig) ! cloud ice + real(r_single),intent(in) :: tcld(nlon,nlat,nsig) ! cloud temperature (potential temperature) + + real(r_single),intent(in) :: pbk(nlon,nlat,nsig) ! pressure , pa + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height +! +! cloud observation from METAR + + INTEGER(i_kind), intent(in) :: mxst_p,NVARCLD_P +! PARAMETER (LSTAID_P=9) + + INTEGER,intent(in) :: numsao + real(r_single),intent(in) :: OI(mxst_p) ! x location + real(r_single),intent(in) :: OJ(mxst_p) ! y location + INTEGER(i_kind),intent(in):: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, + ! visibility + CHARACTER*10,intent(in) :: OWX(mxst_p) ! weather + real(r_single),intent(in) :: Oelvtn(mxst_p) ! elevation + character(8),intent(in) :: cstation(mxst_p) ! station name + real(i_kind), intent(in) :: xland(nlon,nlat) ! surface +! + real(r_single),intent(in) :: sat_ctp(nlon,nlat) +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) +! +! misc. +! + INTEGER :: ista,idw,ids + INTEGER :: i,j,k, iunit + character*3 :: cmype +! +!================================================================ +! + idw=jstart(mype+1)-2 + ids=istart(mype+1)-2 + iunit=68 + write(cmype,'(I3.3)') mype + open(iunit,file='checkCloud_'//trim(cmype)//'.txt') + write(iunit,*) idw,ids,jstart(mype+1),istart(mype+1),mype + + if(mype==22 ) then + DO i=54, 58 + DO j=96, 100 + write(*,*) 'radar=',i,j,k + DO k=1,nsig + write(*,*) 'radar=',ges_tten(j,i,k,1) ,pbk(i,j,k) + enddo + enddo + enddo + endif + + return +if(mype==5 ) then + DO i=100, 102 + DO j=44, 46 +! DO i=2, nlon-1 +! DO j=2, nlat-1 + +! if(sat_ctp(i,j) > 900 .and. sat_ctp(i,j) < 1014) then + write(iunit,'(a,f8.1,2i8,f8.1)') 'cloud top pressure=',sat_ctp(i,j),i,j,xland(i,j) + write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' + DO k=1,nsig + write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & + k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & + h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) + enddo +! endif + END DO + END DO + + + if(numsao > 0 ) then + do ista = 1,numsao + if(abs(OCLD(1,ista)) <10 ) then + write(iunit,'(a10,I10,2f8.2,20I10)') cstation(ista),ista,oi(ista),oj(ista),(OCLD(k,ista),k=1,3),(OCLD(k,ista),k=7,10) + endif + enddo + endif + +endif + +! do k=1,nsig +! do j=1,nlat +! do i=1,nlon +! tcld(i,j,k)=tcld(i,j,k)*(pbk(i,j,k)/h1000/100.0)**rd_over_cp +! ENDDO +! ENDDO +! ENDDO + + if(mype == 130 ) then + + + if(numsao > 0 ) then + write(cmype,'(I3.3)') mype + open(iunit,file='checkCloud_'//trim(cmype)//'.txt') + write(iunit,*) 'mype,idw,ids',mype,idw,ids,nlon,nlat + do ista = 1,numsao + if(abs(OCLD(1,ista)) <10 ) then + write(iunit,'(a10,I10,2f8.2)') cstation(ista),ista,oi(ista),oj(ista) + write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) + write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) + endif + enddo + + + do ista = 1,numsao + i = int(oi(ista)+0.0001) + j = int(oj(ista)+0.0001) + + write(iunit,*) + write(iunit,'(a10,I10,a10,2I10,3f8.2)') 'ista=',ista,cstation(ista),i,j,oi(ista),oj(ista),Oelvtn(ista) + write(iunit,'(20I10)') (OCLD(k,ista),k=1,6) + write(iunit,'(20I10)') (OCLD(k,ista),k=7,NVARCLD_P) + + if( i >= 2 .and. i <=nlon-1 ) then + if( j >= 2 .and. j <=nlat-1 ) then + + write(iunit,'(a,f8.1)') 'cloud top pressure=',sat_ctp(i,j) + write(iunit,'(a10,3a10,a12,3a10)') 'level','cover','qc', 'qi', 'h_bk', 'pbk','tcld' + DO k=1,nsig + write(iunit,'(i10,f10.2,2f10.5,f12.1,3f10.1)') & + k,cld_cover_3d(i,j,k),qc(i,j,k)*1000.0,qi(i,j,k)*1000.0, & + h_bk(i,j,k),pbk(i,j,k),tcld(i,j,k) + enddo + + endif + endif + ENDDO + close(iunit) + + endif + endif +! + +END SUBROUTINE check_cloud +SUBROUTINE FindCloumn(mype,ifindomain,iglobal,jglobal,ilocal,jlocal) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: CheckCloumn find local i,j from certain global i,j +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-05-02 +! +! ABSTRACT: +! This subroutine print the column information for certain i,j +! +! PROGRAM HISTORY LOG: +! 2011-05-02 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! iglobal - i grid for whole domain +! jglobal - j grid for whole domain +! +! output argument list: +! ilocal - i grid for subdomain domain +! jlocal - j grid for subdomain domain +! ifindomain - if in this sub-domain +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! + + use kinds, only: r_single,i_kind,r_kind,r_double + use gridmod, only: jlon1,ilat1,istart,jstart + + implicit none + + integer(i_kind), intent(in) :: mype + integer(i_kind), intent(in) :: iglobal + integer(i_kind), intent(in) :: jglobal + integer(i_kind), intent(out) :: ilocal + integer(i_kind), intent(out) :: jlocal + logical, intent(out) :: ifindomain + +! +! misc. +! + + integer(i_kind) :: ib,jb + +!==================================================================== +! Begin + + ifindomain=.false. + ib=jstart(mype+1) ! begin i point of this domain + jb=istart(mype+1) ! begin j point of this domain + +! + ilocal = iglobal - ib + 2 ! covert it to the local grid + jlocal = jglobal - jb + 2 ! covert it to the local grid + + if(ilocal > 0 .and. jlocal > 0 ) then + if(ilocal <= jlon1(mype+1) .and. jlocal <= ilat1(mype+1) ) then + ifindomain=.true. + endif + endif +! write(*,*) 'find the location',mype,ilocal,jlocal,iglobal,jglobal +! write(*,*) mype,ib,jb,jlon1(mype+1),ilat1(mype+1),ifindomain + +END SUBROUTINE FindCloumn + diff --git a/src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 b/src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 new file mode 100755 index 0000000000..e4f9cd96dd --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/PrecipMxr_radar.f90 @@ -0,0 +1,167 @@ +SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & + t_bk,p_bk,ref_mos_3d, & + cldpcp_type_3d,q_bk,qr_cld,qnr_3d,qs_cld,qg_cld,cldqropt) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipMxR_radar find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This is the driver to call subroutines that calculate liquid water content based on +! radar reflectivity and hydrometeor type diagnosed from radar +! and background 3-D temperature fields +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! ref_mos_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D hydrometeor type +! cldqropt - scheme used to retrieve +! mixing ratios for hydrometeors related to precipitation (qr, qs, qg) +! 1=Kessler 2=Lin 3=Thompson +! +! output argument list: +! qr_cld - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration +! qs_cld - snow mixing ratio (g/kg) +! qg_cld - graupel mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio +! + real(r_kind),intent(in) :: ref_mos_3d(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + integer(i_kind),intent(in) :: cldpcp_type_3d(nlon,nlat,nsig) +! +! hydrometeors +! + REAL(r_single),intent(out) :: qr_cld(nlon,nlat,nsig) ! rain + REAL(r_single),intent(out) :: qnr_3d(nlon,nlat,nsig) ! rain number concentration(/kg) + REAL(r_single),intent(out) :: qs_cld(nlon,nlat,nsig) ! snow + REAL(r_single),intent(out) :: qg_cld(nlon,nlat,nsig) ! graupel + +!----------------------------------------------------------- +! +! temp. +! + + REAL(r_single) :: t_3d(nlon,nlat,nsig) + REAL(r_single) :: p_3d(nlon,nlat,nsig) + REAL(r_kind) :: qs_max + + INTEGER(i_kind) :: cldqropt + INTEGER(i_kind) :: istatus_pcp + INTEGER(i_kind) :: i,j,k + INTEGER(i_kind) :: k_qs_max + REAL(r_kind) :: threshold_t_1st + +! +!==================================================================== +! Begin +! +! cldqropt = 2 + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + t_3d(i,j,k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + p_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO + END DO + END DO + +!----------------------------------------------------------------------- +! +! Calculate 3D precipitation hydrometeor mixing ratios +! from radar reflectivity in g/kg. +! Note that qr_cld, qs_cld, and qg_cld are diagnosed +! qr, qs and qg in g/kg, respectively. +! +!----------------------------------------------------------------------- +! + IF (cldqropt == 1) THEN +! +! Kessler's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Kessler radar reflectivity equations...' + endif + CALL pcp_mxr (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp) + + ELSE IF (cldqropt == 2) THEN +! +! Ferrier's scheme +! + if(mype==0) then + WRITE(6,'(a)') 'PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Ferrier radar reflectivity equations...' + endif + CALL pcp_mxr_ferrier_new (nlon,nlat,nsig,t_3d,p_3d,ref_mos_3d, & + cldpcp_type_3d,q_bk, & + qr_cld,qs_cld,qg_cld, & + istatus_pcp) + + ELSE IF (cldqropt == 3) THEN +! +! Thompson's scheme +! + if(mype==0) then + WRITE(6,'(a)') ' PrecipMxR_radar: Computing Precip mixing ratio.' + WRITE(6,'(a)') & + ' Using Thompson RUC radar reflectivity equations...' + endif +! call pcp_mxr_thompsonRUC(qr_cld,qs_cld,qg_cld, & +! p_3d,t_3d, & +! ref_mos_3d,nlon,nlat,nsig,cldpcp_type_3d) + call hydro_mxr_thompson (nlon,nlat,nsig, t_3d, p_3d, ref_mos_3d, & + qr_cld,qnr_3d,qs_cld, istatus_pcp,mype) + + END IF !cldqropt=1 or 2 or 3 + +END SUBROUTINE PrecipMxR_radar + diff --git a/src/GSD/gsdcloud4nmmb/PrecipType.f90 b/src/GSD/gsdcloud4nmmb/PrecipType.f90 new file mode 100755 index 0000000000..51f83ddb07 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/PrecipType.f90 @@ -0,0 +1,118 @@ +SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & + wthr_type,cldpcp_type_3d) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: PrecipType decide precipitation type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates precipitation type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! q_bk - 3D moisture +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! wthr_type - weather type +! +! output argument list: +! cldpcp_type_3d - 3D precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN):: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),INTENT(IN) :: q_bk(nlon,nlat,nsig) ! moisture +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! +! Variables for cloud analysis +! + integer(i_kind),INTENT(out) :: cldpcp_type_3d(nlon,nlat,nsig) + integer(i_kind),INTENT(in) :: wthr_type(nlon,nlat) + LOGICAL :: l_mask(nlon,nlat) ! "Potential" Precip Type + +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind):: i,j,k,ilvl,nlvl + real(r_single) :: temp_3d(nlon,nlat,nsig) ! temperature (C) + real(r_single) :: rh_3d(nlon,nlat,nsig) ! relative humidity + real(r_single) :: p_pa_3d(nlon,nlat,nsig) ! + REAL(r_single) :: qvsat + REAL(r_single) :: f_qvsat + INTEGER :: istatus +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 1,nlat + DO i = 1,nlon +! + DO k = 1,nsig ! Initialize + temp_3d(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to K + qvsat=f_qvsat(p_bk(i,j,k)*100.0_r_single,temp_3d(i,j,k)) + qvsat = qvsat/(1.0_r_single-qvsat) ! convert to mixing ratio (kg/kg) + rh_3d(i,j,k)=100._r_single*MIN(1.,MAX(0._r_single,(q_bk(i,j,k)/qvsat))) + p_pa_3d(i,j,k) = p_bk(i,j,k)*100.0_r_single + END DO +!----------------------------------------------------------------------- + + ENDDO ! i + ENDDO ! j + + l_mask = .false. + + call pcp_type_3d (nlon,nlat,nsig,temp_3d,rh_3d,p_pa_3d & + ,radar_3d,l_mask,cldpcp_type_3d,istatus) + + +END SUBROUTINE precipType + diff --git a/src/GSD/gsdcloud4nmmb/TempAdjust.f90 b/src/GSD/gsdcloud4nmmb/TempAdjust.f90 new file mode 100755 index 0000000000..a7f0802750 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/TempAdjust.f90 @@ -0,0 +1,199 @@ +SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & + qc,qi,ctmp_bk) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: TempAdjust temperature adjustment +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-26 +! +! ABSTRACT: +! This subroutine adjusts the perturbation potential temperature field to account +! for the latent heating release. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! cldptopt - schemes of adjustment +! 3=latent heat, 4,5,6 = adiabat profile +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! w_bk - 3D background vertical velocity +! q_bk - 3D moisture (water vapor mixing ratio) +! qc - 3D cloud water mixing ratio (kg/kg) +! qi - 3D cloud ice mixing ratio (kg/kg) +! ctmp_bk - 3D cloud temperature +! +! output argument list: +! t_bk - 3D background potential temperature (K) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: cp,rd_over_cp, h1000, hvap + use kinds, only: r_single,i_kind + + implicit none + integer(i_kind),intent(in):: nlat,nlon,nsig + integer(i_kind),intent(in):: mype + +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: w_bk(nlon,nlat,nsig) ! terrain + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture - water vapor mixing ratio +! +! real(r_single) :: t_bk_check(nlon,nlat,nsig) ! temperature +! +! +! cloud water and cloud ice mixing ratios +! + real (r_single),intent(in) :: qc(nlon,nlat,nsig) + real (r_single),intent(in) :: qi(nlon,nlat,nsig) + real (r_single),intent(in) :: ctmp_bk(nlon,nlat,nsig) +! +! constant + REAL :: p0 +! +! +! temp. +! + INTEGER :: i,j,k + INTEGER(i_kind),intent(in) :: cldptopt + REAL :: frac_qc_2_lh, max_lh_2_pt + REAL :: max_pt_adj + REAL :: p0inv,arg,ptdiff + REAL :: ppi,wratio,ptcld +! +! +!----------------------------------------------------------- +! +! t_bk_check=0.0 + + p0=h1000 +! + wratio=1.0 +! cldptopt=3 + frac_qc_2_lh =1.0 + max_lh_2_pt=20.0 +! + IF (cldptopt == 3) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating.' + WRITE(6,'(a,f10.4,a,f10.4)') & + 'TempAdjust: frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + p0inv=1./p0 + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + arg=max(0.0,qc(i,j,k)) + max(0.0,qi(i,j,k)) + if( arg > 0.0 ) then + ppi = (p_bk(i,j,k)*p0inv) ** rd_over_cp + arg = hvap*frac_qc_2_lh*arg*0.001/(cp*ppi) + max_pt_adj = MAX(max_pt_adj,arg) + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + endif + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 4) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to account for latent heating in w.' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k) > 0.0) THEN + wratio=1.0 + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + ELSE IF (cldptopt == 5) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>-0.2' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF( ctmp_bk(i,j,k) > 0.0) THEN + wratio=min(max(0.,(5.0*(w_bk(i,j,k)+0.2))),1.0) + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*wratio*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + ENDIF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + ELSE IF (cldptopt == 6) THEN +if(mype==0) then + WRITE(6,'(a)')'TempAdjust: Adjusting t_bk to moist-adiab cloud temp for w>0.0' + PRINT*,'frac of qc:',frac_qc_2_lh,' adj_lim:',max_lh_2_pt +endif + max_pt_adj = 0.0 + DO k=2,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + IF(w_bk(i,j,k) > 0. .and. ctmp_bk(i,j,k)>0.0 ) THEN + ptcld=ctmp_bk(i,j,k)*(p0/p_bk(i,j,k))**rd_over_cp + ptdiff=ptcld-t_bk(i,j,k) + IF(ptdiff > 0.) THEN + arg = frac_qc_2_lh*ptdiff + t_bk(i,j,k) = t_bk(i,j,k) + MIN(arg,max_lh_2_pt) +! t_bk_check(i,j,k) = MIN(arg,max_lh_2_pt) + max_pt_adj = MAX(max_pt_adj,arg) + END IF + END IF + END DO + END DO + END DO + if(mype==0) PRINT*,'max_adj=',max_pt_adj + + END IF ! cldptopt=3? + +! t_bk = t_bk_check + +END SUBROUTINE TempAdjust diff --git a/src/GSD/gsdcloud4nmmb/adaslib.f90 b/src/GSD/gsdcloud4nmmb/adaslib.f90 new file mode 100755 index 0000000000..555e7ec6a0 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/adaslib.f90 @@ -0,0 +1,474 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines related to cloud analysis in ADAS (CAPS) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION RH_TO_CLDCV ###### +!###### ###### +!################################################################## +!################################################################## +! + + FUNCTION rh_to_cldcv(rh,hgt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Obtain first guess cloud cover field from relative humidity. +! +! +! AUTHOR: Jian Zhang +! 07/95 +! +! MODIFICATION HISTORY +! +! 04/08/97 J. Zhang +! Added the empirical relationship between RH and +! cloud cover used by Koch et al. (1997). +! Reference: +! Reference: +! Koch, S.E., A. Aksakal, and J.T. McQueen, 1997: +! The influence of mesoscale humidity and evapotranspiration +! fields on a model forecast of a cold-frontal squall line. +! Mon. Wea. Rev., Vol.125, 384-409 +! 09/10/97 J. Zhang +! Modified the empirical relationship between cloud +! fraction and relative humidity from quadratic +! to one-fourth-power. +! +! +!----------------------------------------------------------------------- +! +! INPUT: +! rh ! relative humidity +! hgt ! height (AGL) +! +! OUTPUT: +! rh_to_cld_cv ! cloud fractional cover value +! +! LOCAL: +! rh0 ! the critical RH value that seperate clear + ! air condition and cloudy condition +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind,r_kind + + IMPLICIT NONE + + INTEGER(i_kind) :: rh2cform + PARAMETER (rh2cform=2) + + REAL(r_kind), intent(in) :: rh,hgt + REAL(r_kind) :: rh_to_cldcv + REAL(r_kind) :: rh0 + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! + IF(rh2cform == 1) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600.0_r_kind) THEN + rh0 = 0.9_r_kind + ELSE IF (hgt < 1500.0_r_kind) THEN + rh0 = 0.8_r_kind + ELSE IF (hgt < 2500.0_r_kind) THEN + rh0 = 0.6_r_kind + ELSE + rh0 = 0.5_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = (rh - rh0)/(1.0_r_kind - rh0) + rh_to_cldcv = rh_to_cldcv*rh_to_cldcv + END IF + + ELSE IF(rh2cform == 2) THEN +! +!----------------------------------------------------------------------- +! +! A quadratic relationship between relative humidity and cloud +! fractional cover with fixed rh0=0.75 +! +!----------------------------------------------------------------------- +! +! + IF (rh < 0.75_r_kind) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 16._r_kind*(rh - 0.75_r_kind)*(rh - 0.75_r_kind) + END IF + + ELSE +! +!-----------------------------------------------------------------------! +! A modified version of the sqrt relationship between +! relative humidity and cloud fractional cover used in Eta model. +! +!----------------------------------------------------------------------- +! + IF (hgt < 600._r_kind) THEN + rh0 = 0.8_r_kind + ELSE + rh0 = 0.75_r_kind + END IF + + IF (rh < rh0) THEN + rh_to_cldcv = 0.0_r_kind + ELSE + rh_to_cldcv = 1.0_r_kind - SQRT((1.0_r_kind - rh)/(1.0_r_kind - rh0)) + END IF + + END IF + + RETURN + END FUNCTION rh_to_cldcv +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_ES ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_es( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_es Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_es ! Saturation water vapor pressure (Pa) +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_esl, f_esi + +!fpp$ expand (f_esl) +!fpp$ expand (f_esi) +!!dir$ inline always f_esl, f_esi +!*$* inline routine (f_esl, f_esi) + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + IF ( t >= 273.15 ) THEN ! for water + f_es = f_esl( p,t ) + ELSE ! for ice + f_es = f_esi( p,t ) + END IF + + RETURN +END FUNCTION f_es + +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over liquid water using +! enhanced Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esl( p, t ) + + IMPLICIT NONE + +! constant + REAL :: satfwa, satfwb + PARAMETER ( satfwa = 1.0007 ) + PARAMETER ( satfwb = 3.46E-8 ) ! for p in Pa + + REAL :: satewa, satewb, satewc + PARAMETER ( satewa = 611.21 ) ! es in Pa + PARAMETER ( satewb = 17.502 ) + PARAMETER ( satewc = 32.18 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esl ! Saturation water vapor pressure over liquid water + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfwa + satfwb * p + f_esl = f * satewa * EXP( satewb*(t-273.15)/(t-satewc) ) + + RETURN +END FUNCTION f_esl +! +!----------------------------------------------------------------------- +! +! Calculate the saturation water vapor over ice using enhanced +! Teten's formula. +! +!----------------------------------------------------------------------- +! + +FUNCTION f_esi( p, t ) + + IMPLICIT NONE + +! + REAL :: satfia, satfib + PARAMETER ( satfia = 1.0003 ) + PARAMETER ( satfib = 4.18E-8 ) ! for p in Pa + + REAL :: sateia, sateib, sateic + PARAMETER ( sateia = 611.15 ) ! es in Pa + PARAMETER ( sateib = 22.452 ) + PARAMETER ( sateic = 0.6 ) + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_esi ! Saturation water vapor pressure over ice (Pa) + + REAL :: f + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f = satfia + satfib * p + f_esi = f * sateia * EXP( sateib*(t-273.15)/(t-sateic) ) + + RETURN +END FUNCTION f_esi +! +! +!################################################################## +!################################################################## +!###### ###### +!###### FUNCTION F_QVSAT ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +FUNCTION f_qvsat( p, t ) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Calculate the saturation specific humidity using enhanced Teten's +! formula. +! +!----------------------------------------------------------------------- +! +! AUTHOR: Yuhe Liu +! 01/08/1998 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! +! INPUT : +! +! p Pressure (Pascal) +! t Temperature (K) +! +! OUTPUT: +! +! f_qvsat Saturation water vapor specific humidity (kg/kg). +! +!----------------------------------------------------------------------- +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE + + REAL :: p ! Pressure (Pascal) + REAL :: t ! Temperature (K) + REAL :: f_qvsat ! Saturation water vapor specific humidity (kg/kg) +! +!----------------------------------------------------------------------- +! +! Include files: +! +!----------------------------------------------------------------------- +! +! + + REAL :: rd ! Gas constant for dry air (m**2/(s**2*K)) + PARAMETER( rd = 287.0 ) + + REAL :: rv ! Gas constant for water vapor (m**2/(s**2*K)). + PARAMETER( rv = 461.0 ) + + REAL :: rddrv + PARAMETER( rddrv = rd/rv ) + +! +!----------------------------------------------------------------------- +! +! Function f_es and inline directive for Cray PVP +! +!----------------------------------------------------------------------- +! + REAL :: f_es +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! + f_qvsat = rddrv * f_es(p,t) / (p-(1.0-rddrv)*f_es(p,t)) + + RETURN +END FUNCTION f_qvsat + +SUBROUTINE getdays(nday,iyear,imonth,iday) + + use kinds, only: i_kind + implicit none +! + INTEGER(i_kind), intent(in) :: iyear,imonth,iday + INTEGER(i_kind), intent(out) :: nday +! + + nday=0 + if(imonth==1) then + nday=iday + elseif(imonth==2) then + nday=31+iday + elseif(imonth==3) then + nday=59+iday + elseif(imonth==4) then + nday=90+iday + elseif(imonth==5) then + nday=120+iday + elseif(imonth==6) then + nday=151+iday + elseif(imonth==7) then + nday=181+iday + elseif(imonth==8) then + nday=212+iday + elseif(imonth==9) then + nday=243+iday + elseif(imonth==10) then + nday=273+iday + elseif(imonth==11) then + nday=304+iday + elseif(imonth==12) then + nday=334+iday + endif + if(mod(iyear,4) == 0 .and. imonth > 2 ) nday=nday+1 + +END SUBROUTINE getdays diff --git a/src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 b/src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 new file mode 100755 index 0000000000..fd153a99db --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/build_missing_REFcone.f90 @@ -0,0 +1,245 @@ +SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk,pblh) +! +! radar observation +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: build_missing_REFcone build missing reflectivity area +! below cone down to assumed cloud base +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-26 +! +! ABSTRACT: +! This subroutine sets reflectivity values at missing reflectivity volumes +! below the radar "data cone" down to an assumed cloud base +! As of March 2010, this code code not yet use the local PBL base +! as used in the RUC cloud/hydrometeor analysis since summer 2009. +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2011-04-08 Hu Clean the reflectivity below PBL height or level 7 +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! krad_bot - radar bottom level +! ref_mos_3d - 3D radar reflectivity +! h_bk - 3D background height +! pblh - PBL height in grid +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single), intent(in) :: pblh(nlon,nlat) ! PBL height + real(r_single), intent(in) :: krad_bot_in +! + integer(i_kind) :: krad_bot,ifmissing +! + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile(km) + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-35 dbz + DATA refprofile_winter(:,1) / & + 0.999,0.938,0.957,0.975,0.983,0.990,0.995,0.999,1.000,1.000, & + 0.994,0.985,0.957,0.926,0.892,0.854,0.819,0.791,0.770,0.747, & + 0.729,0.711,0.705,0.685,0.646,0.631,0.649,0.711,0.828,0.931, & + 0.949/ +! max reflectivity 25-30 dbz + DATA refprofile_winter(:,2) / & + 0.965,0.937,0.954,0.970,0.984,0.991,0.996,1.000,0.997,0.988, & + 0.973,0.954,0.908,0.856,0.808,0.761,0.718,0.684,0.659,0.631, & + 0.607,0.586,0.570,0.550,0.523,0.512,0.531,0.601,0.711,0.813, & + 0.870/ +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,3) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,4) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,5) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,6) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + + real(r_kind) :: refprofile_summer(maxlvl,6) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 20-25 dbz + DATA refprofile_summer(:,1) / & + 0.883,0.870,0.879,0.892,0.904,0.912,0.913,0.915,0.924,0.936, & + 0.946,0.959,0.984,0.999,1.000,0.995,0.988,0.978,0.962,0.940, & + 0.916,0.893,0.865,0.839,0.778,0.708,0.666,0.686,0.712,0.771, & + 0.833/ +! max reflectivity 25-30 dbz + DATA refprofile_summer(:,2) / & + 0.836,0.874,0.898,0.915,0.927,0.938,0.945,0.951,0.960,0.970, & + 0.980,0.989,1.000,0.995,0.968,0.933,0.901,0.861,0.822,0.783, & + 0.745,0.717,0.683,0.661,0.614,0.564,0.538,0.543,0.578,0.633, & + 0.687/ +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,3) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,4) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,5) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,6) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + REAL(r_kind) :: lowest,highest,tempref(nsig), tempprofile(maxlvl) + REAL(r_kind) :: maxref + + INTEGER(i_kind) :: i,j, k2, k, mref + +! +! vertical reflectivity distribution +! + season=1 + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO +! + DO j=2,nlat-1 + DO i=2,nlon-1 + ifmissing=0 + maxref=-9999.0_r_kind +!mhu krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! Here, we only use PBL height to build missing corn and clean the reflectivity lower than +! PBL height. The krad_bot_in will be used when calculate the radar tten but not the hydrometer retrieval. +! Nov 21, 2011. Ming Hu + krad_bot= int( pblh(i,j) + 0.5_r_single ) ! consider PBL height +! +! in our case, -99 is no echo +! + DO k2=int(nsig/2),krad_bot,-1 + if(ref_mos_3d(i,j,k2+1)>=20._r_kind .and. & + ref_mos_3d(i,j,k2) < -100._r_kind ) ifmissing=k2 + if(ref_mos_3d(i,j,k2)>=maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO + IF(ifmissing > 1 ) then + DO k2=krad_bot,1,-1 + if(ref_mos_3d(i,j,k2) >maxref) maxref=ref_mos_3d(i,j,k2) + ENDDO +! if(maxref < 19.0_r_kind) then +! write(6,*) 'build_missing_REFcone:',ifmissing,i,j,ifmissing +! write(6,*) (ref_mos_3d(i,j,k2),k2=1,nsig) +! endif + endif + IF(ifmissing > 1 .and. maxref > 19.0_r_kind ) then + mref = min(6,(int((maxref - 20.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*maxref + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*maxref + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif +! make a ref profile + tempref=-9999.9_r_kind + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. & + heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref(k2)=(1-wght)*downref + wght*upref + endif + ENDDO +! build missing volumes down to krad_bot level +! NOTE: no use of PBL base yet, as done in RUC analysis since summer 2009 + maxref=ref_mos_3d(i,j,ifmissing+1)-tempref(ifmissing+1) + if(abs(maxref) < 10.0_r_kind ) then + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = tempref(k2) + maxref + ENDDO + else + DO k2=ifmissing,krad_bot,-1 + ref_mos_3d(i,j,k2) = ref_mos_3d(i,j,ifmissing+1) + ENDDO + endif +! + ENDIF +! clean echo less than PBL height and level 7 + DO k2=1,krad_bot + ref_mos_3d(i,j,k2) = -99999.0_r_kind + ENDDO + ENDDO + ENDDO + +END SUBROUTINE build_missing_REFcone diff --git a/src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 b/src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 new file mode 100755 index 0000000000..24e89e0115 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudCover_NESDIS.f90 @@ -0,0 +1,697 @@ +SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& + xlong,xlat,t_bk,p_bk,h_bk,zh,xland, & + soil_tbk,sat_ctp,sat_tem,w_frac,& + l_cld_bld,cld_bld_hgt,build_cloud_frac_p,clear_cloud_frac_p,nlev_cld, & + cld_cover_3d,cld_type_3d,wthr_type) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_NESDIS cloud cover analysis using NESDIS cloud products +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine determines cloud_cover (fractional) field using NESDIS cloud products +! Based on RUC assimilation code - (Benjamin, Weygandt, Kim, Brown) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2016-02-10 S.Liu use r_single type for xland +! +! +! input argument list: +! mype - processor ID +! regional_time - analysis time +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! xlong - 2D longitude in each grid +! xlat - 2D latitude in each grid +! +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! h_bk - 3D background height +! zh - terrain +! xland - surface type (water, land) +! soil_tbk - background soil temperature +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! l_cld_bld - logical for turning on GOES cloud building +! cld_bld_hgt - Height below which cloud building is done +! build_cloud_frac_p - Threshold above which we build clouds +! clear_cloud_frac_p - Threshold below which we clear clouds +! +! output argument list: +! nlev_cld - cloud status +! cld_cover_3d- 3D cloud cover (fractional cloud) +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: xlong(nlon,nlat) ! longitude + real(r_single),intent(in) :: xlat(nlon,nlat) ! latitude + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potentional temperature + real(r_single),intent(inout) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: xland(nlon,nlat) ! surface + real(r_single),intent(in) :: soil_tbk(nlon,nlat) ! soil tmperature +! real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) +! +! Observation +! + real(r_single),intent(inout) :: sat_ctp(nlon,nlat) + real(r_single),intent(inout) :: sat_tem(nlon,nlat) + real(r_single),intent(inout) :: w_frac(nlon,nlat) + integer(i_kind),intent(out) :: nlev_cld(nlon,nlat) +! +! Turn on cloud building and height limit + logical, intent(in) :: l_cld_bld + real(r_kind), intent(in) :: cld_bld_hgt + real(r_kind), intent(in) :: build_cloud_frac_p + real(r_kind), intent(in) :: clear_cloud_frac_p +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! +!------------------------------------------------------------------------- +! --- Key parameters +! Cloud_def_p = 0.000001 g/g cloud top threshold for model +! Min_cloud_lev_p = 3 Lowest model level to check for cloud +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Sat_cloud_pthick_p= 50. Depth (mb) of new sat-sensed cloud layer +! cloud_zthick_p = 300. Depth (m) of new cloud layer +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice +! saturation mixing ratio for new cloud +! Max_cloud_top_p = 150. Max cloud top (mb) +! RH_makecloud_p = 0.90 RH threshold for making cloud if bkg +! rh is at least this high at +! neighboring points +! Cloud_up_p = 10 Pressure thickness for +! Upward extrapolation of cloud +! (if model level is within cloud_up_p +! mb of sat cloud level) +! min_cloud_p_p = 960. Max pressure at which NESDIS cloud +! info is considered reliable +! (i.e., not reliable at low levels) + +! zen_limit = 0.20 Solar zenith angle - lower limit +! at which sun is considered +! high enough to trust the +! GOES cloud data + + real(r_kind) :: Cloud_def_p + integer(i_kind) :: min_cloud_lev_p + real(r_kind) :: Rh_clear_p + real(r_kind) :: sat_cloud_pthick_p + real(r_kind) :: cloud_zthick_p + real(r_kind) :: Cloud_q_qvis_rat_p + real(r_kind) :: Max_cloud_top_p + real(r_kind) :: RH_makecloud_p + real(r_kind) :: cloud_up_p + real(r_kind) :: min_cloud_p_p + real(r_kind) :: co2_preslim_p + real(r_kind) :: auto_conver + real(r_kind) :: zen_limit + real(r_kind) :: dt_remap_pcld_limit_p + +! --- Key parameters + data Cloud_def_p / 0.000001_r_kind/ + data Min_cloud_lev_p / 1_i_kind / ! w/ sfc cld assim +! data Min_cloud_lev_p / 3_i_kind / ! w/ sfc cld assim + data Rh_clear_p / 0.80_r_kind/ + data Sat_cloud_pthick_p / 30._r_kind/ +! data Sat_cloud_pthick_p / 50._r_kind/ + data cloud_zthick_p / 300._r_kind/ + data Cloud_q_qvis_rat_p / 0.05_r_kind/ + data Max_cloud_top_p / 150._r_kind/ + data RH_makecloud_p / 0.90_r_kind/ + data cloud_up_p / 0._r_kind / + data min_cloud_p_p / 1080._r_kind/ ! w/ sfc cld assim + data co2_preslim_p / 620._r_kind/ + data auto_conver / 0.0002_r_kind/ +! -- change to 82 deg per Patrick Minnis - 4 Nov 09 + data zen_limit / 0.14_r_kind/ +! data zen_limit / 0.20_r_kind / + data dt_remap_pcld_limit_p / 3.5_r_kind / +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: null_p + REAL(r_kind) :: spval_p + PARAMETER ( null_p = -1 ) + PARAMETER ( spval_p = 99999.0 ) + + INTEGER(i_kind) :: i,j,k,k1,i1,j1,jp1,jm1,ip1,im1 + REAL(r_kind) :: ri, rj + INTEGER(i_kind) :: gmt,nday,iyear,imonth,iday + REAL(r_kind) :: declin + real(r_kind) :: hrang,xxlat + real(r_single) :: csza(nlon,nlat) + + INTEGER(i_kind) :: ndof_tot, npts_clear, npts_build, npts_bel650 + INTEGER(i_kind) :: npts_warm_cld_flag, npts_tskin_flag, npts_stab_flag, npts_ptly_cloudy + real (r_single) :: tbk_k(nlon,nlat,nsig) + + INTEGER(i_kind) :: npts_ctp_change, npts_ctp_delete, npts_ctp_nobuddy + INTEGER(i_kind) :: npts_clr_nobuddy,npts_ctp_marine_remap + real (r_single) :: dctp, dctpabs + + real(r_single) :: tsmin + + INTEGER(i_kind) :: kisotherm, ibuddy, ktempmin + real(r_kind) :: tempmin,dth2dp2, stab, stab_threshold + + real(r_kind) :: firstcloud, pdiff,pdiffabove + + INTEGER(i_kind) :: ista, k_closest, cld_warm_strat(nlon,nlat) + REAL(r_kind) :: dist, tdiff + +! +!==================================================================== +! Begin +! +! calculation solar declination +! + iyear=regional_time(1) + imonth=regional_time(2) + iday=regional_time(3) + call getdays(nday,iyear,imonth,iday) + declin=deg2rad*23.45_r_kind*sin(2.0_r_kind*pi*(284+nday)/365.0_r_kind) + + cld_warm_strat=-1 +! +! from mb to Pa +! + do k = 1,nsig + do j = 1,nlat + do i = 1,nlon +! qw=q_bk(i,j,k)/(1. + q_bk(i,j,k)) ! convert to specific humidity + tbk_k(i,j,k)=t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp ! convert to temperature(K) + p_bk(i,j,k) = p_bk(i,j,k)*100._r_kind + end do + end do + end do + + if( p_bk(nlon/2,nlat/2,2) < 5000.0_r_kind ) then + write(6,*) 'cloudCover_NESDIS: pressure unit check failed', p_bk(nlon/2,nlat/2,2) + call stop2(114) + endif + if( tbk_k(nlon/2,nlat/2,nsig-2) > 300._r_kind) then + write(6,*) 'cloudCover_NESDIS: temperature unit check failed', & + tbk_k(nlon/2,nlat/2,nsig-2) + call stop2(114) + endif + +! +! csza = fraction of solar constant (cos of zenith angle) + gmt = regional_time(4) ! UTC + do j=2,nlat-1 + do i=2,nlon-1 + hrang= (15._r_kind*gmt + xlong(i,j) - 180._r_kind )*deg2rad + xxlat=xlat(i,j)*deg2rad + csza(i,j)=sin(xxlat)*sin(declin) & + +cos(xxlat)*cos(declin)*cos(hrang) + end do + end do + +! +! start checking the data +! + ndof_tot = 0 !counting total number of grids of sat info + npts_clear = 0 + npts_build = 0 + npts_bel650 = 0 + npts_tskin_flag = 0 + npts_stab_flag = 0 + npts_ptly_cloudy = 0 + + do j=2,nlat-1 + do i=2,nlon-1 + jp1 = min(j+1,nlat) + jm1 = max(j-1,1 ) + ip1 = min(i+1,nlon) + im1 = max(i-1,1 ) + tsmin = soil_tbk(i,j) +! --- Determine min skin temp in 3x3 around grid point. +! This is to detect nearby presence of coastline. + do j1 = jm1,jp1 + do i1 = im1,ip1 + tsmin = min(tsmin,soil_tbk(i1,j1) ) + end do + end do + + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-soil_tbk(i,j)) > 4._r_kind & + .and. soil_tbk(i,j) < 263._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. xland(i,j) /=0.0 & + .and. p_bk(i,j,1)/100. >=850._r_kind ) then +! w_frac(i,j) = -99999._r_kind +! sat_tem(i,j) = 99999._r_kind +! sat_ctp(i,j) = 0._r_kind +! nlev_cld(i,j) = -999 + npts_warm_cld_flag = npts_warm_cld_flag + 1 + cld_warm_strat(i,j)=5 + end if +! PH changed condition to match RUC: Tcld-Tskin(bkg) < 4, > -2 + if ( w_frac(i,j) > -1._r_kind & + .and. (sat_tem(i,j)-tsmin) > -2._r_kind & + .and. (sat_tem(i,j)-tsmin) <= 4._r_kind & + .and. sat_ctp(i,j) > co2_preslim_p & + .and. sat_ctp(i,j) < 1010._r_kind & + .and. xland(i,j) /=0.0 & + .and. p_bk(i,j,1)/100._r_kind>= 950._r_kind ) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_tskin_flag = npts_tskin_flag + 1 + cld_warm_strat(i,j)=4 + end if + if (w_frac(i,j)<=clear_cloud_frac_p .and. & + w_frac(i,j)>-1._r_kind) then + sat_ctp(i,j) = 1013.0_r_kind + npts_clear = npts_clear + 1 + cld_warm_strat(i,j)=0 + end if + if (w_frac(i,j) > clear_cloud_frac_p.and. & + w_frac(i,j) < build_cloud_frac_p) then +! w_frac(i,j) = -99999._r_kind + sat_tem(i,j)= 99999._r_kind +! mhu: this can cause problem: a miss line between cloud and clean, set it to clean +! PH: for CLAVR data, just set sat_ctp = 0. + sat_ctp(i,j) = 0._r_kind + nlev_cld(i,j)= -999 + npts_ptly_cloudy = npts_ptly_cloudy + 1 + cld_warm_strat(i,j)=1 + end if + if (w_frac(i,j) >= build_cloud_frac_p.and. & + sat_ctp(i,j) < 1050) then + npts_build = npts_build + 1 + cld_warm_strat(i,j)=2 + end if + if (sat_ctp(i,j)>co2_preslim_p .and. sat_ctp(i,j)<1010._r_kind) & + npts_bel650 = npts_bel650 + 1 + +! -- nlev_cld = 1 if cloud info is present +! -- nlev_cld = 0 if no cloud info is at this grid point + + if(nlev_cld(i,j) >= 1) ndof_tot = ndof_tot + 1 + end do ! i + end do ! j +! + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: TOTAL NUMBER OF GRID pts w/ GOES CLOUD data =',ndof_tot + write(6,*) 'cloudCover_NESDIS: CLEAR NUMBER OF GRID pts w/ GOES CLOUD data =',npts_clear + write(6,*) 'cloudCover_NESDIS: BUILD NUMBER OF GRID pts w/ GOES CLOUD data =',npts_build + write(6,*) 'cloudCover_NESDIS: PTCLDY NUMBER OF GRID pts w/ GOES CLOUD data =',npts_ptly_cloudy + write(6,*) 'cloudCover_NESDIS: > 650mb - no OF GRID pts w/ GOES CLOUD data =',npts_bel650 + write(6,*) 'cloudCover_NESDIS: Flag CTP - skin temp too close to TB, no=',npts_tskin_flag + write(6,*) 'cloudCover_NESDIS: Clear -> cloud frac < clear frac' + write(6,*) 'cloudCover_NESDIS: Build -> cloud frac > build frac' + endif + +! +!! +! + npts_ctp_change = 0 + npts_ctp_delete = 0 + npts_ctp_nobuddy = 0 + npts_clr_nobuddy = 0 + npts_ctp_marine_remap = 0 + dctp = 0. + dctpabs = 0. + +! - stability threshold for building cloud - 3K / 100 mb (10000 Pa) + + stab_threshold = 3._r_kind/10000._r_kind + do j=2,nlat-1 + do i=2,nlon-1 + +! -- GOES indicates clouds in the lower troposphere + if (sat_ctp(i,j) < 1010._r_kind .and. sat_ctp(i,j) > co2_preslim_p) then + + tdiff = 999. + k_closest = -1 + do k=3,nsig-1 +! Attempt remapping if within 75 hPa (arbitrary) + if ((sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind)< 75._r_kind) then + if (abs(sat_tem(i,j)-tbk_k(i,j,k)) < tdiff) then + k_closest = k + tdiff = abs(sat_tem(i,j)-tbk_k(i,j,k)) + end if + end if + end do ! k loop + + if (k_closest <= 0 .and. xland(i,j) /= 0.0) then + npts_ctp_delete = npts_ctp_delete + 1 + write (6,*) i,j,sat_tem(i,j),tdiff,k_closest,xland(i,j) + go to 111 + end if + + k = k_closest + + if( xland(i,j) /=0.0 ) then +! PH: dt_limit was hardwired to 1.5K, changed it to 3.5K to match RUC + if ((tdiff < dt_remap_pcld_limit_p) .or. & + (cld_warm_strat(i,j) == 5 .and. tdiff < 4._r_kind )) then + dctpabs = dctpabs + abs(sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + dctp = dctp+ (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) + k1 = k + +1115 continue + +! --- This stability check only for reassigining CTP using RUC bkg profile. +! There is a later general check also. + stab = (t_bk(i,j,k1+1)-t_bk(i,j,k1)) & + /(p_bk(i,j,k1)-p_bk(i,j,k1+1)) + if (stab < stab_threshold) then + k1 = k1 + 1 + if ((p_bk(i,j,k)-p_bk(i,j,k1)) > 5000._r_kind) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_stab_flag= npts_stab_flag + 1 + go to 111 + end if + go to 1115 + end if + + sat_ctp(i,j) = p_bk(i,j,k)/100._r_kind + npts_ctp_change = npts_ctp_change + 1 + go to 111 + else + npts_ctp_delete = npts_ctp_delete + 1 +! write (6,*) i,j,sat_tem(i,j),tdiff + go to 111 + end if + + else ! xland==0: over water + +! --- Remap marine cloud to min temp level below 880 mb +! if no matching RUC temp already found + + if (sat_ctp(i,j)>880._r_kind)then + tempmin = -500._r_kind + +! --- Look thru lowest 15 levels for lowest temp for +! level to put marine cloud at. +! --- Start at level 3 + kisotherm = 20 + ktempmin = 20 + do k=min_cloud_lev_p+2,15 + if (p_bk(i,j,k)/100._r_kind .lt. 880._r_kind) go to 1101 + dth2dp2 = t_bk(i,j,k+1)+t_bk(i,j,k-1)-2._r_kind*t_bk(i,j,k) + if (kisotherm==0 .and. & + tbk_k(i,j,k) < tbk_k(i,j,k+1)) kisotherm = k + if (dth2dp2>tempmin) then + ktempmin = k + tempmin = max(dth2dp2,tempmin) + end if + end do +1101 continue + ktempmin = min(ktempmin,kisotherm) + sat_ctp(i,j) = p_bk(i,j,ktempmin)/100._r_kind + npts_ctp_marine_remap = npts_ctp_marine_remap + 1 + end if ! sat_ctp(i,j)>880._r_kind + endif ! xland == 0 + end if +111 continue + enddo ! i + enddo ! j + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - unstable w/i 50mb of CTP, no=', npts_stab_flag + write(6,*) 'cloudCover_NESDIS: Flag CTP - can''t remap CTP, no=', npts_ctp_delete + write(6,*) 'cloudCover_NESDIS: Flag CTP -remap marine cloud, no=', npts_ctp_marine_remap + endif + + if (npts_ctp_change > 0) then + if(mype==0) write (6,1121) npts_ctp_change, dctp/float(npts_ctp_change), & + dctpabs/float(npts_ctp_change) +1121 format (/'No. of pts w/ cloud-top pres change = ',i6 & + /'Mean cloud-top pres change (old-new)= ',f8.1 & + /'Mean abs cloud-top pres change = ',f8.1/) + end if +! +! --- Make sure that any cloud point has another cloud point nearby. +! Otherwise, get rid of it. + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j)< 1010._r_kind .and. sat_ctp(i,j)>50._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1)<1010._r_kind .and. sat_ctp(i1,j1)>50._r_kind) ibuddy = 1 + end do + end do + if (ibuddy==0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_ctp_nobuddy = npts_ctp_nobuddy + 1 + end if + end if + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j) <1100._r_kind) then + ibuddy = 0 + do j1=j-1,j+1 + do i1=i-1,i+1 + if (sat_ctp(i1,j1) > 1010._r_kind .and. sat_ctp(i1,j1) <1100._r_kind) ibuddy = 1 + end do + end do + if (ibuddy == 0) then + w_frac(i,j) = -99999._r_kind + sat_tem(i,j) = 99999._r_kind + sat_ctp(i,j) = 99999._r_kind + nlev_cld(i,j) = -999 + npts_clr_nobuddy = npts_clr_nobuddy + 1 + end if + end if + enddo + enddo + + if(mype==0) then + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ cloud, no=', & + npts_ctp_nobuddy + + write(6,*) 'cloudCover_NESDIS: Flag CTP - no contiguous points also w/ clear, no=', & + npts_clr_nobuddy + endif + +! +! ***************************************************************** +! ***************************************************************** +! Start to adjust to GOES cloud top pressure +! ***************************************************************** +! ***************************************************************** + +! --- clear where GOES shows clear down to the surface +! or down to the GOES cloud top level + +! ============================================= +! - clear down to surface in fully clear column (according to GOES) +! ============================================= +! Only trust 'clear' indication under following conditions +! - over ocean +! - or over land only if p<620 mb overnight +! - or at any level in daytime (zenith angle +! greater than zen_limit threshold) +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + if (sat_ctp(i,j) >=1010.0_r_kind .and. sat_ctp(i,j) <1050._r_kind) then !clear + do k=1,nsig + if (csza(i,j)=zen_limit) then + cld_cover_3d(i,j,k) = 0 + wthr_type(i,j) = 0 + end if + end do +!mhu: use 1060hps cloud top pressure to clean above the low cloud top + elseif (abs(sat_ctp(i,j)-1060.0_r_kind) < 1.0_r_kind) then !clear since the low cloud top + do k=1,nsig + if (csza(i,j)=zen_limit) then + if( abs(cld_cover_3d(i,j,k)) > 2 ) then + cld_cover_3d(i,j,k) = 0 + wthr_type(i,j) = 0 + endif + end if + end do + end if + enddo + enddo +! ============================================= +! - clearing above cloud top +! ============================================= + + do j=2,nlat-1 + do i=2,nlon-1 + do k=1,nsig-1 +! - return to previous (but experimental) version - 12 Oct 04 + if (csza(i,j) < zen_limit & + .and. p_bk(i,j,k)/100._r_kind=zen_limit) then +! --- since we set GOES to nearest RUC level, only clear at least +! 1 RUC level above cloud top + if (sat_ctp(i,j)<1010._r_kind .and. & + sat_ctp(i,j)>p_bk(i,j,k)/100._r_kind) then +! +! mhu, some low cloud top press (> 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! + if(sat_ctp(i,j) >= 800.0_r_kind ) then + cld_cover_3d(i,j,k+1) = & + max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0 + endif + endif + end if + end do + enddo + enddo + +! print *, 'h_bk max: ', maxval(h_bk(:,:,1)), ' min: ', minval(h_bk(:,:,1)) + +! ============================================= +! - start building where GOES indicates so +! ============================================= + do j=2,nlat-1 + do i=2,nlon-1 + + if ((w_frac(i,j)>= build_cloud_frac_p) .and. & + (w_frac(i,j)< 99999._r_kind) )then !Dongsoo added + +! --- Cloud info below MIN_CLOUD_P not reliable + firstcloud = 0 +! - pdiff (diff between sat cloud top and model sfc pres) in mb + do k=nsig-1,min_cloud_lev_p,-1 + pdiff = (sat_ctp(i,j)-p_bk(i,j,k)/100._r_kind) +! --- set closest RUC level w/ cloud + if (pdiff<=0. .and. firstcloud==0) then + pdiffabove = sat_ctp(i,j)-p_bk(i,j,k+1)/100._r_kind + if (abs(pdiffabove) 800 hpa) over clean the cloud that observed by METAR +! so add these check to keep cloud base correct +! + if(sat_ctp(i,j) >= 800.0_r_kind ) then + cld_cover_3d(i,j,k+1) = max(0.0_r_single, cld_cover_3d(i,j,k+1)) + else + cld_cover_3d(i,j,k+1) = 0 + endif + firstcloud = 1 + end if + end if + +! no cloud above cloud top + +! +! --- Add 50mb thick (at least 1 level) of cloud where GOES +! indicates cloud top + if (xland(i,j)/=0._r_single) then + if (sat_ctp(i,j)< min_cloud_p_p .and. & + pdiff<=cloud_up_p ) then + if (firstcloud==0.or. firstcloud==1 & + .and.pdiff >= -1.*sat_cloud_pthick_p) then +! sgb - 2/7/2012 - remove this condition +! Allow cloud building below CO2_preslim and at night and over land +! if (p_bk(i,j,k)/100._r_kind= -1.*sat_cloud_pthick_p) then +! xland ==0 if (p_bk(i,j,k)/100..lt.co2_preslim_p) then + if (l_cld_bld .and. h_bk(i,j,k+1) < cld_bld_hgt) then + cld_cover_3d(i,j,k)=1 + else + cld_cover_3d(i,j,k)=-99998 + end if + firstcloud = 1 + end if + end if + end if + + end do + end if + enddo ! j + enddo + +! go from pa to mb + do k = 1,nsig + do j = 2,nlat-1 + do i = 2,nlon-1 + p_bk(i,j,k) = p_bk(i,j,k)/100._r_kind + end do + end do + end do +! +END SUBROUTINE cloudCover_NESDIS + diff --git a/src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 b/src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 new file mode 100755 index 0000000000..2f350c2717 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudCover_Surface.f90 @@ -0,0 +1,411 @@ +SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& + t_bk,p_bk,q,h_bk,zh, & + mxst_p,NVARCLD_P,numsao,OI,OJ,OCLD,OWX,Oelvtn,Odist,& + cld_cover_3d,cld_type_3d,wthr_type,pcp_type_3d, & + watericemax, kwatericemax) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_Surface cloud cover analysis using surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine determines 3D cloud fractional cover using surface observations +! Code based on RUC assimilation code (hybfront/hybcloud.f) +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! r_radius - influence radius of the cloud observation +! thunderRadius - +! +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! q - 3D moisture (water vapor mixing ratio) +! h_bk - 3D background height (m) +! zh - terrain (m) +! +! mxst_p - maximum observation number +! NVARCLD_P - first dimension of OLCD +! numsao - observation number +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! pcp_type_3d - 3D weather precipitation type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + REAL(r_single), intent(in) :: r_radius + integer(i_kind),intent(in) :: nlat,nlon,nsig + real(r_single), intent(in) :: thunderRadius +! +! surface observation +! + INTEGER(i_kind),intent(in) :: mxst_p,NVARCLD_P + +! PARAMETER (LSTAID_P=9) + + INTEGER(i_kind),intent(in) :: numsao + real(r_single), intent(in) :: OI(mxst_p) ! x location + real(r_single), intent(in) :: OJ(mxst_p) ! y location + INTEGER(i_kind),intent(in) :: OCLD(NVARCLD_P,mxst_p) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(in) :: OWX(mxst_p) ! weather + real(r_single), intent(in) :: Oelvtn(mxst_p) ! elevation + real(r_single), intent(in) :: Odist(mxst_p) ! distance from the nearest station + +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure + real(r_single),intent(in) :: zh(nlon,nlat) ! terrain + real(r_single),intent(in) :: q(nlon,nlat,nsig) ! moisture, water vapor mixing ratio (kg/kg) + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height +! + REAL(r_single),intent(in) :: watericemax(mxst_p) ! max of background total liquid water in station + INTEGER(i_kind),intent(in):: kwatericemax(nlon,nlat) ! lowest level of background total liquid water in grid +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) + integer(i_kind),intent(inout) :: pcp_type_3d(nlon,nlat,nsig) +! +! local +! + real (r_single) :: vis2qc(nlon,nlat) + real (r_single) :: cloud_zthick_p + data cloud_zthick_p /300._r_kind/ +! + REAL (r_kind) :: spval_p + PARAMETER ( spval_p = 99999.0_r_kind ) + + INTEGER(i_kind) :: i,j,k,k1 + INTEGER(i_kind) :: i1,j1,ic + INTEGER(i_kind) :: nx_p, ny_p, nztn_p + INTEGER(i_kind) :: ista + INTEGER(i_kind) :: ich, iob,job + + REAL(r_kind) :: min_dist, dist + REAL(r_kind) :: zdiff + REAL(r_kind) :: zlev_clr,cloud_dz,cl_base_ista,betav +! +! +! + real(r_single):: tbk_k(nlon,nlat,nsig) + real(r_single):: cv_bk(nlon,nlat,nsig) + real(r_single):: z_lcl(nlon,nlat) + REAL(r_kind) :: cf_model_base,t_model_base, ht_base + REAL(r_kind) :: t_dry_adiabat,t_inversion_strength + + LOGICAL :: l_cf,l_inversion + LOGICAL :: if_cloud_exist + + integer(i_kind) :: firstcloud,cl_base_broken_k + real(r_single) :: underlim + integer(i_kind) :: npts_near_clr + + +!==================================================================== +! Begin +! +! set constant names consistent with original RUC code +! + nx_p=nlon + ny_p=nlat + nztn_p=nsig + + vis2qc=-9999.0_r_kind + npts_near_clr=0 +! +! +!***************************************************************** +! analysis of surface/METAR cloud observations +! ***************************************************************** + + DO ista=1,numsao + i1 = int(oi(ista)+0.0001_r_kind) + j1 = int(oj(ista)+0.0001_r_kind) + min_dist = Odist(ista) + +!mh - grid point has the closest cloud station + +! -- find out if any precip is present + do ich=1,1 + if ( owx(ista)(ich:ich+1)=='SH' ) wthr_type(i1,j1)=16 + if ( owx(ista)(ich:ich+1)=='TH' .and. & + min_dist < thunderRadius) wthr_type(i1,j1)=1 + if ( owx(ista)(ich:ich+1)=='RA' ) wthr_type(i1,j1)=11 + if ( owx(ista)(ich:ich+1)=='SN' ) wthr_type(i1,j1)=12 + if ( owx(ista)(ich:ich+1)=='PL' ) wthr_type(i1,j1)=13 + if ( owx(ista)(ich:ich+1)=='DZ' ) wthr_type(i1,j1)=14 + if ( owx(ista)(ich:ich+1)=='UP' ) wthr_type(i1,j1)=15 + if ( owx(ista)(ich:ich+1)=='BR' ) wthr_type(i1,j1)=21 + if ( owx(ista)(ich:ich+1)=='FG' ) wthr_type(i1,j1)=22 + enddo + +! Consider clear condition case +! ----------------------------- + if (ocld(1,ista)==0) then + + do ic=1,6 + if(float(abs(ocld(6+ic,ista))) < 55555) then + write(6,*) 'cloudCover_Surface: Observed cloud above the clear level !!!' + write(6,*) 'cloudCover_Surface: some thing is wrong in surface cloud observation !' + write(6,*) 'cloudCover_Surface: check the station no.', ista, 'at process ', mype + write(6,*) ic,OI(ista),OJ(ista) + write(6,*) (ocld(k,ista),k=1,12) + call stop2(114) + endif + enddo +! clean the whole column up to ceilometer height (12 kft) if ob is CLR +! h_bk is AGL, not ASL (per Ming Hu's notes below +! +! zlev_clr = Oelvtn(ista)+3650. +! Upcoming mods commented out below for this commit - 4/3/2010 +! PH: added in column cleaning up to ceilometer height if ob is CLR + zlev_clr = 3650. + + do k=1,nztn_p + if (h_bk(i1,j1,k) < zlev_clr) then + cld_cover_3d(i1,j1,k)=0.0_r_kind + pcp_type_3d(i1,j1,k)=0 + endif + end do + + wthr_type(i1,j1)=0 + +! -- Now consider non-clear obs +! -------------------------- + else + +! increase zthick by 1.5x factor for ceiling < 900 m (~3000 ft - MVFR) + cloud_dz = cloud_zthick_p + cl_base_broken_k = -9 +! ????? check with Stan O(h_p) if (Oelvtn(ista).lt.900.) cloud_dz = cloud_zthick_p * 2 + + do ic = 1,6 + if (ocld(ic,ista)>0 .and. ocld(ic,ista)<50) then +! if ( csza(i,j)>=0.10 .and. sat_ctp(i1,j1)>1010.0 & +! .and. sat_ctp(i1,j1)<1050.) go to 1850 +! +! New tweak - 11/07/2009 +! If there was cloud in background over station but if there +! was partial cloudiness within volume and this is one of the +! clear columns within the polygonal area for this METAR, +! then leave it that way and skip. +! if (watericemax(iob,job).gt.0. .and. +! 1 kwatericemax(iob,job).gt.0 .and. +! 1 kwatericemax(iob,job).le.12) then +! npts_cld_match = npts_cld_match + 1 +! dzbase = cl_base_ista - g3(iob,job,kwatericemax(iob,job),h_p) +! sum_dzbase = sum_dzbase + dzbase +! sum_dzbase_abs = sum_dzbase_abs + abs(dzbase) +! end if + +! if (watericemax(ista) > 0._r_single .and. kwatericemax(i1,j1)==-1) then +! npts_near_clr = npts_near_clr + 1 +! cycle ! skip cloud build at point (i,j) because background is clear +! end if + + if(ocld(ic,ista) == 4) then + if(wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) cloud_dz = 1000._r_kind + ! precipitation + highest level + if(wthr_type(i1,j1) == 1) cloud_dz = 10000._r_kind ! thunderstorm + endif + +! --- calculate cloud ceiling level, not exactly, FEW SCT are also considered now +! iob = int(oi(ista)-idw+0.5) +! job = int(oj(ista)-ids+0.5) +! cl_base_ista = (float(ocld(6+ic,ista))+zh(iob,job)) +! cl_base_ista = (float(ocld(6+ic,ista))+Oelvtn(ista)) +! the h_bk is AGL. So observation cloud base should be AGL too, delete Oelvtn(ista) +! cover cloud base observation from AGL to ASL + cl_base_ista = float(ocld(6+ic,ista)) + Oelvtn(ista) - zh(i1,j1) + if(zh(i1,j1) < 1.0_r_kind .and. Oelvtn(ista) > 20.0_r_kind & + .and. float(ocld(6+ic,ista)) < 250.0_r_kind) then + cycle ! limit the use of METAR station over oceas for low cloud base + endif + + firstcloud = 0 + underlim = 10._r_kind ! + + do k=1,nztn_p + zdiff = cl_base_ista - h_bk(i1,j1,k) +! Must be within cloud_dz meters (300 or 1000 currently) +! ------------------------------------------------------------------- +! -- Bring in the clouds if model level is within 10m under cloud level. + if(k==1) underlim=(h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.5_r_kind + if(k==2) underlim=10.0_r_kind ! 100 feet + if(k==3) underlim=20.0_r_kind ! 300 feet + if(k==4) underlim=15.0_r_kind ! 500 feet + if(k==5) underlim=33.0_r_kind ! 1000 feet + if (k>=6 .and. k <= 7) underlim = (h_bk(i1,j1,k+1)-h_bk(i1,j1,k))*0.6_r_kind + if(k==8) underlim=95.0_r_kind ! 3000 feet + if(k>=9 .and. k= 1.0 .and. (firstcloud==0 .or. abs(zdiff) 10 .and. wthr_type(i1,j1) < 20) then +! cld_type_3d(i1,j1,k)=5 + pcp_type_3d(i1,j1,k)=1 + endif + else + write(6,*) 'cloudCover_Surface: wrong cloud coverage observation!' + call stop2(114) + endif + firstcloud = firstcloud + 1 + end if ! zdiff < cloud_dz + else +! ---- Clear up to cloud base of first cloud level + if (ic==1) cld_cover_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 1) pcp_type_3d(i1,j1,k)=0 + if (ocld(ic,ista) == 3 .or. ocld(ic,ista) == 4) then + if( (wthr_type(i1,j1) > 10 .and. wthr_type(i1,j1) < 20) & + .or. wthr_type(i1,j1) == 1 ) then + pcp_type_3d(i1,j1,k)=1 + endif + endif + end if ! underlim + end do ! end K loop +! ----clean cloud above stratusphere + do k=1,nztn_p + if( h_bk(i1,j1,k) > 18000 ) cld_cover_3d(i1,j1,k)=0 + enddo +! + end if ! end if ocld > 0 + end do ! end IC loop +! +! clean up to broken (3) or if cloud cover less than 2, clean to cloud top +! + if(cl_base_broken_k > 0 .and. cl_base_broken_k < nztn_p) then + do k=1, cl_base_broken_k + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + enddo + else + if(ocld(1,ista) == 1 .or. ocld(1,ista) == 2 ) then + do k=1, nztn_p + if( cld_cover_3d(i1,j1,k) < -0.001_r_kind ) cld_cover_3d(i1,j1,k)=0 + enddo + endif + endif + + end if ! end if cloudy ob ocld(1,ista) > 0 + +! -- Use visibility for low-level cloud whether + if (wthr_type(i1,j1) < 30 .and. wthr_type(i1,j1) > 20 .and. & + ocld(13,ista) < 5000 .and. ocld(13,ista) > 1) then + cld_type_3d(i1,j1,1) = 2 + cld_type_3d(i1,j1,2) = 2 + betav = 3.912_r_kind / (float(ocld(13,ista)) / 1000._r_kind) + vis2qc(i1,j1) = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind + endif ! cloud or clear + + ENDDO ! ista + + +! Determine if the layer is dry or it has inversion. +! (in either case, the cloud will be cleared out) +! + IF(.false.) THEN ! Set inversion strength flag + call BckgrndCC(nlon,nlat,nsig, & + t_bk,p_bk,q,h_bk,zh, & + cv_bk,tbk_k,z_lcl) ! out + + DO j = 1,nlat + DO i = 1,nlon + + if_cloud_exist=.false. + do k=nsig-1,2,-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + cf_model_base = cv_bk(i,j,k) + t_model_base = tbk_k(i,j,k) + ht_base=h_bk(i,j,k) + if_cloud_exist=.true. + endif + enddo +! +! note, do we need to consider cloud base from background + if(if_cloud_exist) then + do k=2, nsig-1 + if(cld_cover_3d(i,j,k) > 0.01_r_kind) then + l_cf=.false. + l_inversion=.false. + t_dry_adiabat = tbk_k(i,j,2) -.0098_r_kind * (h_bk(i,j,k) - h_bk(i,j,2)) + t_inversion_strength = tbk_k(i,j,k) - t_dry_adiabat + + IF( (tbk_k(i,j,k) > t_model_base) .and. & + (tbk_k(i,j,k) > 283.15_r_kind) .and. & ! temp check + (t_inversion_strength > 4._r_kind) ) then ! delta theta chk + l_inversion = .true. ! Inversion exists + endif + IF( (cv_bk(i,j,k) < cf_model_base - 0.3_r_kind) .and. & + (h_bk(i,j,k) - ht_base >= 500._r_kind) ) THEN + l_cf = .true. ! Dry layer exists + ENDIF + if(l_inversion) then + cld_cover_3d(i,j,k) =0.0_r_kind + endif + endif ! in cloud + enddo ! k + endif ! if_cloud_exist = true + + ENDDO ! i + ENDDO ! j + + END IF ! .true. for dry-inversion check. + +END SUBROUTINE cloudCover_Surface + diff --git a/src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 b/src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 new file mode 100755 index 0000000000..b38419e812 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudCover_radar.f90 @@ -0,0 +1,137 @@ +SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,zh,grid_ref, & + cld_cover_3d,cld_type_3d,wthr_type) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudCover_radar cloud cover analysis using radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-10 +! +! ABSTRACT: +! This subroutine find cloud cover using radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2015-02-24 S.Liu adjust cloud cover based on reflectivity observations +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! zh - terrain +! grid_ref - radar reflectivity in analysis grid +! +! output argument list: +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use constants, only: deg2rad, rad2deg, pi + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig+1) ! height +! +! Observation +! + real(r_kind), intent(in) :: grid_ref(nlon,nlat,nsig) +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(inout) :: wthr_type(nlon,nlat) +! + REAL(r_kind) :: ref_base ! "significant" radar echo at upper levels +! + REAL(r_kind) :: cloud_base +! +!----------------------------------------------------------- +! +! threshold +! + + REAL(r_kind) :: radar_cover + PARAMETER(radar_cover=1.02) + REAL(r_kind) :: thresh_cvr ! lower radar echo threshold for cloud filling + PARAMETER (thresh_cvr = 0.9) +! +! temp. +! + INTEGER(i_kind) :: i,j,k,k1 + REAL(r_kind) :: zs_1d(nsig) + +! +!==================================================================== +! Begin +! +! ref_base = 15.0 +! set ref_base is 35.0 dbz, assuming cloud water will coexist with rain/snow +! based on discussion with Eric Aligo + ref_base = 35.0 +! +!----------------------------------------------------------------------- +! +! Essentially, this go downward to detect radar tops in time +! to search for a new cloud base +! +!----------------------------------------------------------------------- +! + + DO i = 2,nlon-1 + DO j = 2,nlat-1 + + DO k=1,nsig + zs_1d(k) = h_bk(i,j,k) + END DO + + cloud_base = 200000._r_kind +! + DO k = nsig-1,1,-1 + IF( (cld_cover_3d(i,j,k) < thresh_cvr) .and. & + (cld_cover_3d(i,j,k+1) >= thresh_cvr .and. & + cld_cover_3d(i,j,k+1) < 2.0_r_kind) ) THEN + cloud_base = 0.5_r_kind * (zs_1d(k) + zs_1d(k+1)) + END IF + END DO ! k + + + DO k = 6, nsig-1 + if(grid_ref(i,j,k) > ref_base ) then + cld_cover_3d(i,j,k)=radar_cover + endif + ENDDO ! k + + ENDDO ! i + ENDDO ! j +! + +END SUBROUTINE cloudCover_radar + diff --git a/src/GSD/gsdcloud4nmmb/cloudLWC.f90 b/src/GSD/gsdcloud4nmmb/cloudLWC.f90 new file mode 100755 index 0000000000..dd636206d1 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudLWC.f90 @@ -0,0 +1,418 @@ +SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_stratiform find cloud liquid water content +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(inout) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: p_pa_1d(nsig), thv(nsig) + real(r_single) :: cld_base_m, cld_top_m + real(r_single) :: cld_base_qc_m, cld_top_qc_m + real(r_single) :: cloudqvis(nlon,nlat,nsig) + real(r_single) :: rh(nlon,nlat,nsig) + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud +! Cloud_q_qvis_rat_p= 0.10 Ratio of cloud water to water/ice + + real(r_single) Cloud_q_qvis_rat_p, cloud_q_qvis_ratio + real(r_single) auto_conver + real(r_single) cloud_def_p + real(r_single) rh_cld3_p + real(r_single) rh_clear_p + data Cloud_q_qvis_rat_p/ 0.05_r_single/ + data auto_conver /0.0002_r_single/ + data cloud_def_p /0.000001_r_single/ + data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) stab, stab_threshold + LOGICAL :: l_prt + INTEGER(i_kind) :: iflag_slwc + INTEGER(i_kind) :: kp3,km3 + + REAL(r_kind) :: q, Temp, tv, evs, qvs1, eis, qvi1, watwgt, qavail +! +!==================================================================== +! Begin +! + cldwater_3d=-99999.9_r_kind + cldice_3d=-99999.9_r_kind + cloudtmp_3d=-99999.9_r_kind +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + rh=0.0 + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 2,nsig-1 + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + q = q_bk(i,j,k)/(1._r_single+q_bk(i,j,k)) ! Q = water vapor specific humidity + ! q_bk = water vapor mixing ratio + tv = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp +! now, tmperature from GSI s potential temperature + Temp = tv ! temperature +! evs, eis in mb + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs*100._r_kind/(p_pa_1d(k)-100._r_kind*evs) ! qvs1 is mixing ratio kg/kg, so no need next line +! qvs1 = qvs1/(1.0-qvs1) + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis*100._r_kind/(p_pa_1d(k)-100._r_kind*eis) ! qvi1 is mixing ratio kg/kg, so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloudtmp_3d(i,j,k)= Temp + cloudqvis(i,j,k)= (watwgt*qvs1 + (1._r_kind-watwgt)*qvi1) +! qvis(i,j,k)= (watwgt*qvs1 + (1.-watwgt)*qvi1) + rh(i,j,k) = q_bk(i,j,k)/cloudqvis(i,j,k) + enddo + enddo ! i + enddo ! j + + stab_threshold = 3._r_kind/10000._r_kind + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 1,nsig + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_kind + thv(k) = t_bk(i,j,k)*(1.0_r_kind + 0.6078_r_kind*q_bk(i,j,k)) + ENDDO + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + DO k = kb,kt + +! -- change these to +/- 3 vertical levels + kp3 = min(nsig,k+5) + km3 = max(1 ,k) + stab = (thv(kp3)-thv(km3))/(p_pa_1d(km3)-p_pa_1d(kp3)) + +! -- stability check. Use 2K/100 mb above 600 mb and +! 3K/100mb below (nearer sfc) + if ((stab600._r_kind) & + .or. stab<0.66_r_kind*stab_threshold ) then +! write(*,'(a,3i4,f8.3)') 'skip building cloud in stable layer',i,j,k,stab*10000.0 + cld_cover_3d(i,j,k)=-99999.0 + elseif(rh(i,j,k) < 0.40 .and. ((cloudqvis(i,j,k)-q_bk(i,j,k)) > 0.003_r_kind)) then +! write(*,'(a,3i4,2f6.2)') 'skip building cloud in too-dry layer',i,j,k,& +! rh(i,j,k),(cloudqvis(i,j,k)-q_bk(i,j,k))*1000.0 + cld_cover_3d(i,j,k)=-99999.0_r_single + else +!dk * we need to avoid adding cloud if sat_ctp is lower than 650mb +! ph - 2/7/2012 - use a temperature-dependent cloud_q_qvis_ratio +! and with 0.1 smaller condensate mixing ratio building also for temp < 263.15 + Temp = cloudtmp_3d(i,j,k) + watwgt = max(0._r_kind,min(1._r_kind,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + cloud_q_qvis_ratio = watwgt*cloud_q_qvis_rat_p & + + (1.0-watwgt)*0.1*cloud_q_qvis_rat_p + qavail = min(0.5_r_single*auto_conver,cloud_q_qvis_ratio*cloudqvis(i,j,k)) + +! ------------------------------------------------------------------- +! - set cloud water mixing ratio - no more than 0.1 g/kg, +! which is the current autoconversion mixing ratio set in exmoisg +! according to John Brown - 14 May 99 +! ------------------------------------------------------------------- + cldwater_3d(i,j,k) = watwgt*qavail*1000.0_r_kind ! g/kg +! - set ice mixing ratio + cldice_3d(i,j,k)= (1.-watwgt)*qavail*1000.0_r_kind ! g/kg +! end if + end if + enddo ! k + enddo ! ilvl + endif ! nlvl > 1 + enddo ! i + enddo ! j + +END SUBROUTINE cloudLWC_stratiform + +SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i, & + cldwater_3d,cldice_3d,cloudtmp_3d) +! +! find cloud liquid water content +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLWC_Cumulus find cloud liquid water content for cumulus cloud +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculates liquid water content for cumulus cloud +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D height +! t_bk - 3D background potentional temperature (K) +! p_bk - 3D background pressure (hPa) +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cldwater_3d - 3D cloud water mixing ratio (g/kg) +! cldice_3d - 3D cloud ice mixing ratio (g/kg) +! cloudtmp_3d - 3D cloud temperature +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000 + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! surface observation +! +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure +! +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud layers +! + integer(i_kind),intent(in) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! cloud water and cloud ice +! + real (r_single),intent(out) :: cldwater_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cldice_3d(nlon,nlat,nsig) + real (r_single),intent(out) :: cloudtmp_3d(nlon,nlat,nsig) +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real (r_single) :: zs_1d(nsig) + real (r_single) :: cv_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_pa_1d(nsig) + real (r_single) :: p_mb_1d(nsig) + real (r_single) :: cld_base_m, cld_top_m + real (r_single) :: cld_base_qc_m, cld_top_qc_m + + real (r_single) :: slwc_1d(nsig) + real (r_single) :: cice_1d(nsig) + real (r_single) :: ctmp_1d(nsig) + + LOGICAL :: l_prt + INTEGER(i_kind) :: iflag_slwc +! +!==================================================================== +! Begin +! + l_prt =.false. + iflag_slwc = 11 + cldwater_3d=-99999.9_r_single + cldice_3d =-99999.9_r_single + cloudtmp_3d=-99999.9_r_single +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + zs_1d(k) = h_bk(i,j,k) + p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + cld_base_m = 0.5_r_single * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = 0.5_r_single * (zs_1d(kt) + zs_1d(kt+1)) +! + IF(iflag_slwc /= 0) THEN + IF(iflag_slwc < 10) THEN ! simple adiabatc scheme + CALL get_slwc1d (nsig,cld_base_m,cld_top_m,kb,kt & + ,zs_1d,t_1d,p_pa_1d,iflag_slwc,slwc_1d) + + ELSE ! iflag_slwc > 10, new Smith-Feddes scheme + DO k1 = 1,nsig ! Initialize + slwc_1d(k1) = 0.0_r_single + cice_1d(k1) = 0.0_r_single + ctmp_1d(k1) = t_bk(i,j,k1) + END DO +! +!----------------------------------------------------------------------- +! +! QC the data going into SMF +! +!----------------------------------------------------------------------- +! + IF(cld_top_m > zs_1d(nsig-1) - 110._r_single) THEN + cld_top_qc_m = zs_1d(nsig-1) - 110._r_single + cld_base_qc_m = & + MIN(cld_base_m,cld_top_qc_m - 110._r_single) + ELSE ! normal case + cld_top_qc_m = cld_top_m + cld_base_qc_m = cld_base_m + END IF +! + CALL get_sfm_1d(nsig,cld_base_qc_m,cld_top_qc_m & + ,zs_1d,p_mb_1d,t_1d & + ,slwc_1d,cice_1d,ctmp_1d,l_prt) +! + END IF ! iflag_slwc < 10 + END IF ! iflag_slwc .ne. 0 +! + DO k1 = kb,kt ! Loop through the cloud layer + IF(iflag_slwc /= 0) THEN + IF(slwc_1d(k1) > 0._r_single) cldwater_3d(i,j,k1)=slwc_1d(k1) + IF(cice_1d(k1) > 0._r_single) cldice_3d(i,j,k1)=cice_1d(k1) + cloudtmp_3d(i,j,k1)=ctmp_1d(k1) + END IF ! iflag_slwc .ne. 0 + END DO ! k1 + + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudLWC_Cumulus diff --git a/src/GSD/gsdcloud4nmmb/cloudLayers.f90 b/src/GSD/gsdcloud4nmmb/cloudLayers.f90 new file mode 100755 index 0000000000..ac63b99d92 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudLayers.f90 @@ -0,0 +1,167 @@ +SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & + cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudLayers find cloud layers +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine find cloud layer based on cloud cover +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! zh - terrain +! cld_cover_3d- 3D cloud cover +! cld_type_3d - 3D cloud type +! +! output argument list: +! cloudlayers_i - 3D cloud layer index +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind + + implicit none + + integer(i_kind),intent(in) :: nlat,nlon,nsig +! +! background +! + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: cld_type_3d(nlon,nlat,nsig) +! +! output +! + integer(i_kind),intent(out):: cloudlayers_i(nlon,nlat,21) ! 5 different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +! threshold + real (r_single) :: thresh_cvr + parameter ( thresh_cvr = 0.1 ) +!----------------------------------------------------------- +! +! temp. +! + INTEGER :: i,j,k,k1,nlvl + INTEGER :: k_top,k_base + real (r_single) :: zs_1d(nsig) + real (r_single) :: cv_1d(nsig) +! +!==================================================================== +! Begin +! + cloudlayers_i=-99999 +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! Initialize + DO k = 1,nsig + zs_1d(k) = h_bk(i,j,k) + cv_1d(k) = cld_cover_3d(i,j,k) + END DO +! +!----------------------------------------------------------------------- +! +! Get Base and Top +! +!----------------------------------------------------------------------- +! + k=1 + nlvl=0 + DO WHILE (k <= nsig-1) + + IF((cv_1d(k+1) >= thresh_cvr .and. cv_1d(k)= thresh_cvr) ) THEN + k_base = k + 1 + + k = k + 1 + DO WHILE (cv_1d(k) >= thresh_cvr .and. k < nsig) + k_top = k +! +!----------------------------------------------------------------------- +! +! We have now defined a cloud base and top +! +!----------------------------------------------------------------------- +! + k=k+1 + enddo + k=k-1 +!----------------------------------------------------------------------- +! +! Make sure cloud base and top stay in the model domain +! +!----------------------------------------------------------------------- +! + nlvl=nlvl+2 + if(nlvl > 20 ) then + write(6,*) 'cloudLayers: Too many cloud layers in grid point:' + write(6,*) i,j + call stop2(114) + endif + cloudlayers_i(i,j,nlvl) = MIN(k_base,nsig-1) + cloudlayers_i(i,j,nlvl+1) = MIN(k_top,nsig-1) + endif +! + k=k+1 + ENDDO ! k +! + cloudlayers_i(i,j,1) = nlvl/2 + ENDDO + ENDDO +! +! +! + DO j = 2,nlat-1 + DO i = 2,nlon-1 + if(cloudlayers_i(i,j,1) > 0 ) then + do k=1,cloudlayers_i(i,j,1) + if(cloudlayers_i(i,j,k) < 0 .or. cloudlayers_i(i,j,k) > 55555) then + write(6,*) 'cloudLayers: ckeck', i,j,k, cloudlayers_i(i,j,k) + endif + enddo + endif + enddo + enddo +! + +END SUBROUTINE cloudLayers + diff --git a/src/GSD/gsdcloud4nmmb/cloudType.f90 b/src/GSD/gsdcloud4nmmb/cloudType.f90 new file mode 100755 index 0000000000..2b97e72509 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloudType.f90 @@ -0,0 +1,147 @@ +SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & + cld_cover_3d,cld_type_3d,wthr_type,cloudlayers_i) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloudType decide cloud type +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine decide cloud type +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! h_bk - 3D background height +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! radar_3d - 3D radar reflectivity in analysis grid (dBZ) +! +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! cloudlayers_i - 3D cloud layer index +! +! output argument list: +! cld_type_3d - 3D cloud type +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000, half + use kinds, only: r_single,i_kind,r_kind + + implicit none + integer(i_kind),INTENT(IN) :: nlat,nlon,nsig +! +! background +! + real(r_single),INTENT(IN) :: h_bk(nlon,nlat,nsig) ! height + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! temperature + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) ! pressure +! +! observation +! + real(r_kind),INTENT(IN) :: radar_3d(nlon,nlat,nsig) ! reflectivity +! +! Variables for cloud analysis +! + real (r_single), INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind), INTENT(IN) :: wthr_type(nlon,nlat) + integer(i_kind),INTENT(OUT) :: cld_type_3d(nlon,nlat,nsig) +! +! cloud layers +! + integer(i_kind), INTENT(IN) :: cloudlayers_i(nlon,nlat,21) ! 5 =different layers +! 1= the number of layers +! 2,4,... bottom +! 3,5,... top +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: itype + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: cld_base_m, cld_top_m + + real (r_single) :: zs_1d(nsig) + real (r_single) :: dte_dz_1d(nsig) + real (r_single) :: t_1d(nsig) + real (r_single) :: p_mb_1d(nsig) +! + CHARACTER (LEN=2) :: c2_type +! +!==================================================================== +! Begin +! +!----------------------------------------------------------------------- +! +! Find Cloud Layers and Computing Output Field(s) +! The procedure works column by column. +! +!----------------------------------------------------------------------- +! + return + + DO j = 2,nlat-1 + DO i = 2,nlon-1 +! + DO k = 1,nsig ! Initialize + t_1d(k) = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp !K + zs_1d(k) = h_bk(i,j,k) + p_mb_1d(k) = p_bk(i,j,k) + END DO +!----------------------------------------------------------------------- + nlvl=cloudlayers_i(i,j,1) + if(nlvl > 10 ) then + write(*,*) 'warning: too many cloud levels' + nlvl=10 + endif + if(nlvl > 0 ) then + DO ilvl = 1, nlvl ! loop through cloud layers + kb=cloudlayers_i(i,j,2*ilvl) + kt=cloudlayers_i(i,j,2*ilvl+1) + + CALL get_stability (nsig,t_1d,zs_1d,p_mb_1d & + ,kb,kt,dte_dz_1d) + + cld_base_m = half * (zs_1d(kb-1) + zs_1d(kb)) + cld_top_m = half * (zs_1d(kt) + zs_1d(kt+1)) + DO k1 = kb,kt + CALL get_cloudtype(t_1d(k1),dte_dz_1d(k1) & + ,cld_base_m,cld_top_m,itype,c2_type) +! + IF(radar_3d(i,j,k1) > 45._r_kind) THEN + itype = 10 ! CB + END IF + + cld_type_3d(i,j,k1) = itype + END DO !k1 + enddo ! ilvl + endif ! nlvl > 0 + + ENDDO ! i + ENDDO ! j + +END SUBROUTINE cloudType + diff --git a/src/GSD/gsdcloud4nmmb/cloud_saturation.f90 b/src/GSD/gsdcloud4nmmb/cloud_saturation.f90 new file mode 100755 index 0000000000..17ffe84670 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/cloud_saturation.f90 @@ -0,0 +1,315 @@ +SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & + nlat,nlon,nsig,q_bk,t_bk,p_bk, & + cld_cover_3d,wthr_type, & + cldwater_3d,cldice_3d,sumqci) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: cloud_saturation to ensure water vapor saturation at all cloudy grid points +! also to ensure sub saturation in clear point +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-20 +! +! ABSTRACT: +! This subroutine calculate liquid water content for stratiform cloud +! +! PROGRAM HISTORY LOG: +! 2010-10-06 Hu check whole 3D mositure field and get rid of supersaturation +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! cldwater_3d - 3D analysis cloud water mixing ratio (g/kg) +! cldice_3d - 3D analysis cloud ice mixing ratio (g/kg) +! cld_cover_3d- 3D cloud cover +! wthr_type - 3D weather type +! l_conserve_thetaV - if .true. conserving thetaV +! i_conserve_thetaV_iternum - iteration number for conserving thetaV +! +! output argument list: +! q_bk - 3D moisture +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use constants, only: rd_over_cp, h1000,one,zero,fv + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig + logical,intent(in):: l_conserve_thetaV + integer(i_kind),intent(in):: i_conserve_thetaV_iternum +! +! background +! + real(r_single),intent(inout) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(inout) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) + REAL(r_kind),intent(in) :: sumqci(nlon,nlat,nsig) ! total liquid water +! +! Variables for cloud analysis +! + real (r_single),intent(in) :: cld_cover_3d(nlon,nlat,nsig) + integer(i_kind),intent(in) :: wthr_type(nlon,nlat) +! +! cloud water and cloud ice +! + real (r_single),intent(in) :: cldwater_3d(nlon,nlat,nsig) ! kg/kg + real (r_single),intent(in) :: cldice_3d(nlon,nlat,nsig) ! kg/kg +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k,ilvl,nlvl + INTEGER(i_kind) :: kb,kt,k1 + real(r_single) :: thv(nsig) + real(r_single) :: cloudqvis,cloudqvis2,ruc_saturation + +! --- Key parameters +! Rh_clear_p = 0.80 RH to use when clearing cloud + + real(r_single) rh_cld3_p + real(r_single) rh_clear_p + data rh_cld3_p /0.98_r_single/ ! mhu, do we need to adjust this number to 0.94, WPP has PBL top set as 0.95 + data rh_clear_p /0.8_r_single/ + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + INTEGER(i_kind) :: kp3,km3,miter,nnn + + REAL(r_kind) :: constantTv, Temp, evs, qvs1, eis, qvi1, watwgt,Temp1 + real(r_single) :: qtemp, qinc,qtemp1 +! +!==================================================================== +! Begin +! +! + miter=i_conserve_thetaV_iternum ! iteration number for conserving Tv + + DO j = 2,nlat-1 + DO i = 2,nlon-1 + DO k = 2,nsig-1 + +!mhu p_pa_1d(k) = p_bk(i,j,k)*100.0_r_single +! qv= q_bk(i,j,k)/(one+q_bk(i,j,k)) ! qv = water vapor specific humidity +! ! q_bk = water vapor mixing ratio +! now, tmperature from GSI s potential temperature. get temperature + Temp = t_bk(i,j,k)*(p_bk(i,j,k)/h1000)**rd_over_cp + Temp1=Temp + +! now, calculate saturation +! + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) +! +! moisture adjustment based on cloud +! +! +! check each grid point to make sure no supersaturation + q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! now, calculate constant virtual temperature + constantTv=Temp*(one + fv*q_bk(i,j,k)) +! + if(cld_cover_3d(i,j,k) > -0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 2.0_r_kind) then + if(cld_cover_3d(i,j,k) <= 0.0001_r_kind) then +! adjust RH to be below 85 percent(50%?) if +! 1) cloudyn = 0 +! 2) at least 100 mb above sfc +! 3) no precip from sfc obs +!make sure that clear volumes are no more than rh_clear_p RH. + if( (sumqci(i,j,k))>0.0_r_kind .and. & + (p_bk(i,j,1) - p_bk(i,j,k))>100._r_kind .and. & + wthr_type(i,j) <=0 ) then + if( q_bk(i,j,k) > cloudqvis * rh_clear_p) then + qtemp = cloudqvis * rh_clear_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_clear_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + q_bk(i,j,k) = qtemp + endif + endif +!C - moisten layers above and below cloud layer + if(cld_cover_3d(i,j,k+1) > 0.6_r_kind .or. & + cld_cover_3d(i,j,k-1) > 0.6_r_kind ) then + if( cloudqvis > q_bk(i,j,k) ) then + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = q_bk(i,j,k) + 0.7_r_single* (cloudqvis-q_bk(i,j,k)) + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + q_bk(i,j,k)=qtemp + endif + endif +! -- If SCT/FEW present, reduce RH only down to rh_cld3_p (0.98) +! corresponding with cloudyn=3 + elseif(cld_cover_3d(i,j,k) > 0.0001_r_kind .and. & + cld_cover_3d(i,j,k) < 0.6_r_kind ) then + if( q_bk(i,j,k) > cloudqvis * rh_cld3_p) then + qtemp = cloudqvis * rh_cld3_p + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = cloudqvis * rh_cld3_p + enddo + t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + endif + q_bk(i,j,k) = qtemp + endif + else ! set qv at 102%RH + if( q_bk(i,j,k) < cloudqvis * 1.02_r_single ) then + qtemp = cloudqvis * 1.02_r_single + q_bk(i,j,k) = q_bk(i,j,k)+0.5*(qtemp-q_bk(i,j,k)) +! q_bk(i,j,k) = qtemp + if(l_conserve_thetaV) then + do nnn=1,miter + Temp=constantTv/(one + fv*qtemp) + cloudqvis= ruc_saturation(Temp,p_bk(i,j,k)) + qtemp = q_bk(i,j,k)+0.5*(qtemp-q_bk(i,j,k)) +! qtemp = cloudqvis * 1.02_r_single + enddo +! t_bk(i,j,k) = Temp*(h1000/p_bk(i,j,k))**rd_over_cp + t_bk(i,j,k) = t_bk(i,j,k)+ 0.5*(Temp*(h1000/p_bk(i,j,k))**rd_over_cp-t_bk(i,j,k)) + endif +! q_bk(i,j,k) = qtemp + endif + endif +! if(abs(temp1-temp)>0)then +! write(6,*)'check temp::',temp1,temp +! end if + else ! cloud cover is missing +! Ensure saturation in all cloudy volumes. +! Since saturation has already been ensured for new cloudy areas (cld_cover_3d > 0.6) +! we now ensure saturation for all cloud 3-d points, whether cloudy from background +! (and not changed - cld_cover_3d < 0) +! If cloud cover is missing, (cldwater_3d(i,j,k)+cldice_3d(i,j,k) = sumqci(i,j,k), +! which is background cloud liquid water. + cloudqvis2 = min (cloudqvis, 0.018_r_single) ! Limit new water vapor mixing ratio + ! in cloud to 18 g/kg + if ((cldwater_3d(i,j,k)+cldice_3d(i,j,k))>1.0e-5_r_kind) & + q_bk(i,j,k) = max(cloudqvis2,q_bk(i,j,k)) + endif +! +! check each grid point to make sure no supersaturation +! +! q_bk(i,j,k) = min(q_bk(i,j,k), cloudqvis * 1.00_r_single) +! + + enddo ! k + enddo ! i + enddo ! j + +END SUBROUTINE cloud_saturation + +function ruc_saturation(Temp,pressure) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: ruc_saturation calculate saturation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-11-28 +! +! ABSTRACT: +! This subroutine calculate saturation +! +! PROGRAM HISTORY LOG: +! 2011-11-28 Hu Initial +! +! +! input argument list: +! pressure - background pressure (hPa) +! Temp - temperature (K) +! +! output argument list: +! ruc_saturation +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ + + use constants, only: rd_over_cp, h1000,one,zero + use kinds, only: r_single,i_kind, r_kind +! + implicit none + real(r_single) :: ruc_saturation + + REAL(r_kind), intent(in) :: Temp ! temperature in K + real(r_single),intent(in) :: pressure ! pressure (hpa) + + real(r_kind) :: es0_p + parameter (es0_p=6.1121_r_kind) ! saturation vapor pressure (mb) + real(r_kind) SVP1,SVP2,SVP3 + data SVP1,SVP2,SVP3/es0_p,17.67_r_kind,29.65_r_kind/ + + real(r_kind) :: temp_qvis1, temp_qvis2 + data temp_qvis1, temp_qvis2 /268.15_r_kind, 263.15_r_kind/ + + REAL(r_kind) :: evs, qvs1, eis, qvi1, watwgt +! + +! +! evs, eis in mb +! For this part, must use the water/ice saturation as f(temperature) + evs = svp1*exp(SVP2*(Temp-273.15_r_kind)/(Temp-SVP3)) + qvs1 = 0.62198_r_kind*evs/(pressure-evs) ! qvs1 is mixing ratio kg/kg + ! so no need next line +! qvs1 = qvs1/(1.0-qvs1) +! Get ice saturation and weighted ice/water saturation ready to go +! for ensuring cloud saturation below. + eis = svp1 *exp(22.514_r_kind - 6.15e3_r_kind/Temp) + qvi1 = 0.62198_r_kind*eis/(pressure-eis) ! qvi1 is mixing ratio kg/kg, + ! so no need next line +! qvi1 = qvi1/(1.0-qvi1) +! watwgt = max(0.,min(1.,(Temp-233.15)/(263.15-233.15))) +! watwgt = max(zero,min(one,(Temp-251.15_r_kind)/& +! (263.15_r_kind-251.15_r_kind))) +! ph - 2/7/2012 - use ice mixing ratio only for temp < 263.15 + watwgt = max(zero,min(one,(Temp-temp_qvis2)/& + (temp_qvis1-temp_qvis2))) + ruc_saturation= (watwgt*qvs1 + (one-watwgt)*qvi1) ! kg/kg +! +end function ruc_saturation diff --git a/src/GSD/gsdcloud4nmmb/constants.f90 b/src/GSD/gsdcloud4nmmb/constants.f90 new file mode 100755 index 0000000000..9d4263197e --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/constants.f90 @@ -0,0 +1,324 @@ +module constants +!$$$ module documentation block +! . . . . +! module: constants +! prgmmr: treadon org: np23 date: 2003-09-25 +! +! abstract: This module contains the definition of various constants +! used in the gsi code +! +! program history log: +! 2003-09-25 treadon - original code +! 2004-03-02 treadon - allow global and regional constants to differ +! 2004-06-16 treadon - update documentation +! 2004-10-28 treadon - replace parameter tiny=1.e-12 with tiny_r_kind +! and tiny_single +! 2004-11-16 treadon - add huge_single, huge_r_kind parameters +! 2005-01-27 cucurull - add ione +! 2005-08-24 derber - move cg_term to constants from qcmod +! 2006-03-07 treadon - add rd_over_cp_mass +! 2006-05-18 treadon - add huge_i_kind +! 2006-06-06 su - add var-qc wgtlim, change value to 0.25 (ECMWF) +! 2006-07-28 derber - add r1000 +! 2007-03-20 rancic - add r3600 +! 2009-02-05 cucurull - modify refractive indexes for gpsro data +! +! Subroutines Included: +! sub init_constants_derived - compute derived constants +! sub init_constants - set regional/global constants +! +! Variable Definitions: +! see below +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use kinds, only: r_single,r_kind,i_kind,r_quad,i_long + implicit none + +! set default as private + private +! set subroutines as public + public :: init_constants_derived + public :: init_constants +! set passed variables to public + public :: one,two,ione,half,zero,izero,deg2rad,pi,three,quarter,one_tenth + public :: rad2deg,zero_quad,r3600,r1000,r60inv,five,four,rd_over_cp,grav + public :: rd,rozcon,rearth_equator,zero_single,tiny_r_kind,tiny_single + public :: omega,rcp,rearth,fv,h300,cp,cg_term,tpwcon,xb,ttp,psatk,xa,tmix + public :: xai,xbi,psat,eps,omeps,wgtlim,one_quad,epsq,climit,epsm1,hvap + public :: hsub,cclimit,el2orc,elocp,h1000,cpr,pcpeff0,pcpeff2,delta,pcpeff1 + public :: factor1,c0,pcpeff3,factor2,dx_inv,dx_min,rhcbot,rhctop,hfus,ke2 + public :: rrow,cmr,cws,r60,huge_i_kind,huge_r_kind,t0c,rd_over_cp_mass + public :: somigliana,grav_equator,grav_ratio,flattening,semi_major_axis + public :: n_b,n_a,eccentricity,huge_single,constoz,g_over_rd,amsua_clw_d2 + public :: amsua_clw_d1,n_c,rd_over_g,zero_ilong + +! Declare derived constants + integer(i_kind):: huge_i_kind + real(r_single):: tiny_single, huge_single + real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g + real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 + real(r_kind):: factor1, huge_r_kind, tiny_r_kind, deg2rad, pi, rad2deg, cg_term + real(r_kind):: eccentricity_linear, cv, rv, rd_over_cp_mass, cliq, rd, cp_mass + real(r_kind):: eccentricity, grav, rearth, r60inv + + +! Define constants common to global and regional applications + real(r_kind),parameter:: rearth_equator= 6.37813662e6_r_kind ! equatorial earth radius (m) + real(r_kind),parameter:: omega = 7.2921e-5_r_kind ! angular velocity of earth (1/s) + real(r_kind),parameter:: cp = 1.0046e+3_r_kind ! specific heat of air @pressure (J/kg/K) + real(r_kind),parameter:: cvap = 1.8460e+3_r_kind ! specific heat of h2o vapor (J/kg/K) + real(r_kind),parameter:: csol = 2.1060e+3_r_kind ! specific heat of solid h2o (ice)(J/kg/K) + real(r_kind),parameter:: hvap = 2.5000e+6_r_kind ! latent heat of h2o condensation (J/kg) + real(r_kind),parameter:: hfus = 3.3358e+5_r_kind ! latent heat of h2o fusion (J/kg) + real(r_kind),parameter:: psat = 6.1078e+2_r_kind ! pressure at h2o triple point (Pa) + real(r_kind),parameter:: t0c = 2.7315e+2_r_kind ! temperature at zero celsius (K) + real(r_kind),parameter:: ttp = 2.7316e+2_r_kind ! temperature at h2o triple point (K) + real(r_kind),parameter:: jcal = 4.1855e+0_r_kind ! joules per calorie () + real(r_kind),parameter:: stndrd_atmos_ps = 1013.25e2_r_kind ! 1976 US standard atmosphere ps (Pa) + +! Numeric constants + integer(i_kind),parameter:: izero = 0_i_kind + integer(i_kind),parameter:: ione = 1_i_kind + + integer(i_long),parameter:: zero_ilong = 0_i_long + + real(r_single),parameter:: zero_single= 0.0_r_single + + real(r_kind),parameter:: zero = 0.0_r_kind + real(r_kind),parameter:: one_tenth = 0.10_r_kind + real(r_kind),parameter:: quarter = 0.25_r_kind + real(r_kind),parameter:: one = 1.0_r_kind + real(r_kind),parameter:: two = 2.0_r_kind + real(r_kind),parameter:: three = 3.0_r_kind + real(r_kind),parameter:: four = 4.0_r_kind + real(r_kind),parameter:: five = 5.0_r_kind + real(r_kind),parameter:: r60 = 60._r_kind + real(r_kind),parameter:: r1000 = 1000.0_r_kind + real(r_kind),parameter:: r3600 = 3600.0_r_kind + + real(r_quad),parameter:: zero_quad = 0.0_r_quad + real(r_quad),parameter:: one_quad = 1.0_r_quad + + +! Constants for gps refractivity (Bevis et al 1994) + real(r_kind),parameter:: n_a = 77.60_r_kind ! K/mb + real(r_kind),parameter:: n_b = 3.739e+5_r_kind ! K^2/mb + real(r_kind),parameter:: n_c = 70.4_r_kind ! K/mb + +! Parameters below from WGS-84 model software inside GPS receivers. + real(r_kind),parameter:: semi_major_axis = 6378.1370e3_r_kind ! (m) + real(r_kind),parameter:: semi_minor_axis = 6356.7523142e3_r_kind ! (m) + real(r_kind),parameter:: grav_polar = 9.8321849378_r_kind ! (m/s2) + real(r_kind),parameter:: grav_equator = 9.7803253359_r_kind ! (m/s2) + real(r_kind),parameter:: earth_omega = 7.292115e-5_r_kind ! (rad/s) + real(r_kind),parameter:: grav_constant = 3.986004418e14_r_kind ! (m3/s2) + +! Derived geophysical constants + real(r_kind),parameter:: flattening = (semi_major_axis-semi_minor_axis)/semi_major_axis + real(r_kind),parameter:: somigliana = & + (semi_minor_axis/semi_major_axis) * (grav_polar/grav_equator) - one + real(r_kind),parameter:: grav_ratio = (earth_omega*earth_omega * & + semi_major_axis*semi_major_axis * semi_minor_axis) / grav_constant + +! Derived thermodynamic constants + real(r_kind),parameter:: dldti = cvap-csol + real(r_kind),parameter:: hsub = hvap+hfus + real(r_kind),parameter:: psatk = psat*0.001_r_kind + real(r_kind),parameter:: tmix = ttp-20._r_kind + real(r_kind),parameter:: elocp = hvap/cp + real(r_kind),parameter:: rcp = one/cp + +! Constants used in GFS moist physics + real(r_kind),parameter:: h300 = 300._r_kind + real(r_kind),parameter:: half = 0.5_r_kind + real(r_kind),parameter:: cclimit = 0.001_r_kind + real(r_kind),parameter:: climit = 1.e-20_r_kind + real(r_kind),parameter:: epsq = 2.e-12_r_kind + real(r_kind),parameter:: h1000 = r1000 + real(r_kind),parameter:: rhcbot=0.85_r_kind + real(r_kind),parameter:: rhctop=0.85_r_kind + real(r_kind),parameter:: dx_max=-8.8818363_r_kind + real(r_kind),parameter:: dx_min=-5.2574954_r_kind + real(r_kind),parameter:: dx_inv=one/(dx_max-dx_min) + real(r_kind),parameter:: c0=0.002_r_kind + real(r_kind),parameter:: delta=0.6077338_r_kind + real(r_kind),parameter:: pcpeff0=1.591_r_kind + real(r_kind),parameter:: pcpeff1=-0.639_r_kind + real(r_kind),parameter:: pcpeff2=0.0953_r_kind + real(r_kind),parameter:: pcpeff3=-0.00496_r_kind + real(r_kind),parameter:: cmr = one/0.0003_r_kind + real(r_kind),parameter:: cws = 0.025_r_kind + real(r_kind),parameter:: ke2 = 0.00002_r_kind + real(r_kind),parameter:: row = r1000 + real(r_kind),parameter:: rrow = one/row + +! Constant used to process ozone + real(r_kind),parameter:: constoz = 604229.0_r_kind + +! Constants used in cloud liquid water correction for AMSU-A +! brightness temperatures + real(r_kind),parameter:: amsua_clw_d1 = 0.754_r_kind + real(r_kind),parameter:: amsua_clw_d2 = -2.265_r_kind + +! Constants used for variational qc + real(r_kind),parameter:: wgtlim = quarter ! Cutoff weight for concluding that obs has been + ! rejected by nonlinear qc. This limit is arbitrary + ! and DOES NOT affect nonlinear qc. It only affects + ! the printout which "counts" the number of obs that + ! "fail" nonlinear qc. Observations counted as failing + ! nonlinear qc are still assimilated. Their weight + ! relative to other observations is reduced. Changing + ! wgtlim does not alter the analysis, only + ! the nonlinear qc data "count" + +contains + + subroutine init_constants_derived +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants_derived set derived constants +! prgmmr: treadon org: np23 date: 2004-12-02 +! +! abstract: This routine sets derived constants +! +! program history log: +! 2004-12-02 treadon +! 2005-03-03 treadon - add implicit none +! 2008-06-04 safford - rm unused vars +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + +! Trigonometric constants + pi = acos(-one) + deg2rad = pi/180.0_r_kind + rad2deg = one/deg2rad + cg_term = (sqrt(two*pi))/two ! constant for variational qc + tiny_r_kind = tiny(zero) + huge_r_kind = huge(zero) + tiny_single = tiny(zero_single) + huge_single = huge(zero_single) + huge_i_kind = huge(izero) + r60inv=one/r60 + +! Geophysical parameters used in conversion of geopotential to +! geometric height + eccentricity_linear = sqrt(semi_major_axis**2 - semi_minor_axis**2) + eccentricity = eccentricity_linear / semi_major_axis + + return + end subroutine init_constants_derived + + subroutine init_constants(regional) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_constants set regional or global constants +! prgmmr: treadon org: np23 date: 2004-03-02 +! +! abstract: This routine sets constants specific to regional or global +! applications of the gsi +! +! program history log: +! 2004-03-02 treadon +! 2004-06-16 treadon, documentation +! 2004-10-28 treadon - use intrinsic TINY function to set value +! for smallest machine representable positive +! number +! 2004-12-03 treadon - move derived constants to init_constants_derived +! 2005-03-03 treadon - add implicit none +! +! input argument list: +! regional - if .true., set regional gsi constants; +! otherwise (.false.), use global constants +! +! output argument list: +! +! attributes: +! language: f90 +! machine: ibm rs/6000 sp +! +!$$$ + implicit none + + logical,intent(in ) :: regional + + real(r_kind) reradius,g,r_d,r_v,cliq_wrf + +! Define regional constants here + if (regional) then + +! Name given to WRF constants + reradius = one/6370.e03_r_kind + g = 9.81_r_kind + r_d = 287.04_r_kind + r_v = 461.6_r_kind + cliq_wrf = 4190.0_r_kind + cp_mass = 1004.67_r_kind + +! Transfer WRF constants into unified GSI constants + rearth = one/reradius + grav = g + rd = r_d + rv = r_v + cv = cp-r_d + cliq = cliq_wrf + rd_over_cp_mass = rd / cp_mass + +! Define global constants here + else + rearth = 6.3712e+6_r_kind + grav = 9.80665e+0_r_kind + rd = 2.8705e+2_r_kind + rv = 4.6150e+2_r_kind + cv = 7.1760e+2_r_kind + cliq = 4.1855e+3_r_kind + cp_mass= zero + rd_over_cp_mass = zero + endif + + +! Now define derived constants which depend on constants +! which differ between global and regional applications. + +! Constants related to ozone assimilation + ozcon = grav*21.4e-9_r_kind + rozcon= one/ozcon + +! Constant used in vertical integral for precipitable water + tpwcon = 100.0_r_kind/grav + +! Derived atmospheric constants + fv = rv/rd-one ! used in virtual temperature equation + dldt = cvap-cliq + xa = -(dldt/rv) + xai = -(dldti/rv) + xb = xa+hvap/(rv*ttp) + xbi = xai+hsub/(rv*ttp) + eps = rd/rv + epsm1 = rd/rv-one + omeps = one-eps + factor1 = (cvap-cliq)/rv + factor2 = hvap/rv-factor1*t0c + cpr = cp*rd + el2orc = hvap*hvap/(rv*cp) + rd_over_g = rd/grav + rd_over_cp = rd/cp + g_over_rd = grav/rd + + return + end subroutine init_constants + +end module constants diff --git a/src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 new file mode 100755 index 0000000000..2c1eb065d9 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref.f90 @@ -0,0 +1,245 @@ +SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning, & + lghtn_region_mask,lghtn_ref_bias,h_bk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2012-10-16 +! +! ABSTRACT: +! This subroutine converts lightning flash density to radar reflectivity based +! on Jing's statistic analysis + +! PROGRAM HISTORY LOG: +! 2015-10-06 s.Liu Add NCO document block +! 2015-10-06 s.liu -add new algorithm from Jing Her to retrieve REF from lghtn for NMMB +! 2015-10-26 s.liu -reduce estimated reflectivity, appears the current +! algorithm overestimated ref (5dBz) +! 2016-05-05 s.liu -add region adjustment parameter. +! 2016-05-08 s.liu -add parameter to control the layers for adjustment based on region. + +! +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D reflectivity in analysis grid +! lightning - 2D lightning flash rate in analysis grid +! h_bk - 3D height +! +! output argument list: +! ref_mos_3d - 3D reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_kind), intent(inout) :: lightning(nlon,nlat) + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: dbz_lightning(nlon,nlat) + real(r_kind) :: lghtn_region_mask(nlon,nlat) + real(r_kind) :: lghtn_ref_bias(nlon,nlat) + + real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_winter/ & + 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & + 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & + 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ + + real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_summer/ & + 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & + 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & + 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ + + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,1) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,2) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,3) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,4) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,1) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,2) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,3) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,4) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + INTEGER(i_kind) :: num_lightning + INTEGER(i_kind) :: i,j, k2, k, mref + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) + real(r_kind) :: profile_wgt + + +! +! map lightning strokes to maximum reflectiivty +! +!* lghtn_region_mask=1.0 outside of radar coverage + Do j=2,nlat-1 + Do i=2,nlon-1 + if(lghtn_region_mask(i,j)==0.0) then + lghtn_ref_bias(i,j)=lghtn_ref_bias(i,j)+16.0 + else + lghtn_ref_bias(i,j)=lghtn_ref_bias(i,j)+8.0 + end if + End do + End do + + season=1 + dbz_lightning = -9999.0_r_kind + DO j=2,nlat-1 + DO i=2,nlon-1 + if(lightning(i,j) > 1.0_r_kind ) then + num_lightning = max(1,min(30,int(lightning(i,j)))) + if(season== 2 ) then + dbz_lightning(i,j) = & + 7.62*log10(lightning(i,j))+30.0-lghtn_ref_bias(i,j) + else if(season== 1 ) then + dbz_lightning(i,j) = & + 7.62*log10(lightning(i,j))+30.0-lghtn_ref_bias(i,j) + endif + endif + ENDDO + ENDDO + + lightning = -999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + lightning(i,j) = dbz_lightning(i,j) + ENDDO + ENDDO + +! +! vertical reflectivity distribution +! + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO + +! ref_mos_3d=-9999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + if( dbz_lightning(i,j) > 30 ) then + mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + if(lghtn_region_mask(i,j)==0.0.and.refprofile_winter(k,mref)<0.995) then + profile_wgt=0.0 + else if(lghtn_region_mask(i,j)==1.0.and.refprofile_winter(k,mref)<0.993) then + profile_wgt=0.0 + else + profile_wgt=refprofile_winter(k,mref) + end if + tempprofile(k)=profile_wgt*dbz_lightning(i,j) + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + if(lghtn_region_mask(i,j)==0.0.and.refprofile_summer(k,mref)<0.995) then + profile_wgt=0.0 + else if(lghtn_region_mask(i,j)==1.0.and.refprofile_summer(k,mref)<0.993) then + profile_wgt=0.0 + else + profile_wgt=refprofile_summer(k,mref) + end if + tempprofile(k)=profile_wgt*dbz_lightning(i,j) + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref=(1-wght)*downref + wght*upref + ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) + endif + ENDDO + endif + ENDDO + ENDDO + +END SUBROUTINE convert_lghtn2ref diff --git a/src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 new file mode 100755 index 0000000000..4d44226dae --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/convert_lghtn2ref_nmmb.f90 @@ -0,0 +1,211 @@ +SUBROUTINE convert_lghtn2ref_nmmb(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: convert_lghtn2ref convert lightning stroke rate to radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2012-10-16 +! +! ABSTRACT: +! This subroutine converts lightning flash density to radar reflectivity based +! on Jing's statistic analysis + +! PROGRAM HISTORY LOG: +! 2015-10-06 S.Liu Add NCO document block +! 2015-10-06 s.liu -add new algorithm from Jing Her to retrieve REF from lghtn for NMMB +! 2015-10-26 s.liu -reduce estimated reflectivity, appears the current +! algorithm overestimated ref (5dBz) + +! +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D reflectivity in analysis grid +! lightning - 2D lightning flash rate in analysis grid +! h_bk - 3D height +! +! output argument list: +! ref_mos_3d - 3D reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat,nsig + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! height + real(r_kind), intent(inout) :: lightning(nlon,nlat) + real(r_kind), intent(inout):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: dbz_lightning(nlon,nlat) + real(r_kind) :: table_lghtn2ref_winter(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_winter/ & + 32.81,33.98,34.93,36.26,36.72,37.07,37.93,38.79,39.65,40.10, & + 40.42,41.42,41.90,42.04,42.19,42.45,42.90,43.20,43.50,43.80, & + 44.10,44.66,44.84,45.56,45.64,45.80,45.95,46.11,46.32,46.50/ + + real(r_kind) :: table_lghtn2ref_summer(30) ! table content the map from lightning strakes + ! to maximum reflectivity + DATA table_lghtn2ref_summer/ & + 30.13,31.61,32.78,33.86,34.68,35.34,36.13,36.15,37.02,37.04, & + 37.74,38.00,38.56,38.85,39.10,39.37,39.78,39.98,40.64,41.33, & + 41.50,41.65,41.85,42.08,42.77,43.03,43.26,43.53,43.74,43.73/ + + integer(i_kind) :: maxlvl + parameter (maxlvl=31) + real(r_kind) :: newlvlAll(maxlvl) ! vertical levels of reflectivity statistic profile + DATA newlvlAll/0.2, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16/ + + real(r_kind) :: refprofile_winter(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_winter(:,1) / & + 0.966,0.958,0.977,0.989,0.998,1.000,0.997,0.992,0.981,0.962, & + 0.933,0.898,0.826,0.752,0.687,0.626,0.578,0.547,0.522,0.526, & + 0.519,0.501,0.482,0.464,0.437,0.430,0.454,0.539,0.662,0.742, & + 0.793/ +! max reflectivity 35-40 dbz + DATA refprofile_winter(:,2) / & + 0.947,0.953,0.980,0.994,1.000,0.996,0.987,0.974,0.956,0.928, & + 0.891,0.848,0.761,0.679,0.613,0.559,0.522,0.491,0.473,0.462, & + 0.451,0.433,0.415,0.403,0.382,0.380,0.406,0.482,0.603,0.707, & + 0.723/ +! max reflectivity 40-45 dbz + DATA refprofile_winter(:,3) / & + 0.937,0.955,0.986,1.000,0.997,0.995,0.988,0.978,0.957,0.920, & + 0.871,0.824,0.735,0.654,0.584,0.518,0.465,0.442,0.435,0.412, & + 0.398,0.385,0.376,0.360,0.340,0.350,0.377,0.446,0.551,0.625, & + 0.656/ +! max reflectivity 45-50 dbz + DATA refprofile_winter(:,4) / & + 0.900,0.949,0.982,0.995,1.000,0.998,0.983,0.954,0.914,0.874, & + 0.834,0.793,0.721,0.664,0.612,0.565,0.530,0.496,0.460,0.431, & + 0.402,0.383,0.370,0.354,0.335,0.321,0.347,0.342,0.441,0.510, & + 0.548/ + + real(r_kind) :: refprofile_summer(maxlvl,4) ! statistic reflectivity profile used to + ! retrieve vertical ref based on lightning +! max reflectivity 30-35 dbz + DATA refprofile_summer(:,1) / & + 0.870,0.885,0.914,0.931,0.943,0.954,0.967,0.975,0.982,0.989, & + 0.995,1.000,0.998,0.973,0.918,0.850,0.791,0.735,0.690,0.657, & + 0.625,0.596,0.569,0.544,0.510,0.479,0.461,0.460,0.477,0.522, & + 0.570/ +! max reflectivity 35-40 dbz + DATA refprofile_summer(:,2) / & + 0.871,0.895,0.924,0.948,0.961,0.971,0.978,0.983,0.988,0.992, & + 0.997,1.000,0.995,0.966,0.913,0.848,0.781,0.719,0.660,0.611, & + 0.576,0.542,0.523,0.513,0.481,0.448,0.416,0.402,0.417,0.448, & + 0.491/ +! max reflectivity 40-45 dbz + DATA refprofile_summer(:,3) / & + 0.875,0.895,0.914,0.936,0.942,0.951,0.964,0.979,0.990,0.998, & + 1.000,0.992,0.961,0.905,0.834,0.772,0.722,0.666,0.618,0.579, & + 0.545,0.518,0.509,0.483,0.419,0.398,0.392,0.403,0.423,0.480, & + 0.440/ +! max reflectivity 45-50 dbz + DATA refprofile_summer(:,4) / & + 0.926,0.920,0.948,0.975,0.988,0.989,0.995,0.997,1.000,1.000, & + 0.997,0.991,0.970,0.939,0.887,0.833,0.788,0.741,0.694,0.655, & + 0.611,0.571,0.551,0.537,0.507,0.470,0.432,0.410,0.420,0.405, & + 0.410/ + + INTEGER(i_kind) :: season ! 1= summer, 2=winter + INTEGER(i_kind) :: num_lightning + INTEGER(i_kind) :: i,j, k2, k, mref + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + REAL(r_kind) :: lowest,highest,tempref, tempprofile(maxlvl) + + +! +! map lightning strokes to maximum reflectiivty +! + season=1 + dbz_lightning = -9999.0_r_kind + DO j=2,nlat-1 + DO i=2,nlon-1 + if(lightning(i,j) > 1.0_r_kind ) then + num_lightning = max(1,min(30,int(lightning(i,j)))) + if(season== 2 ) then + dbz_lightning(i,j) = 7.62*log10(lightning(i,j))+30.0 + else if(season== 1 ) then + dbz_lightning(i,j) = 7.62*log10(lightning(i,j))+30.0 + endif + endif + ENDDO + ENDDO + + lightning = -999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + lightning(i,j) = dbz_lightning(i,j) + ENDDO + ENDDO + +! +! vertical reflectivity distribution +! + DO k=1,maxlvl + newlvlAll(k)=newlvlAll(k)*1000.0_r_kind + ENDDO + +! ref_mos_3d=-9999.0 + DO j=2,nlat-1 + DO i=2,nlon-1 + if( dbz_lightning(i,j) > 30 ) then + mref = min(4,(int((dbz_lightning(i,j) - 30.0_r_kind)/5.0_r_kind) + 1 )) + if(season== 2 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_winter(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(2) + highest=7000.0_r_kind + else if(season== 1 ) then + DO k=1,maxlvl + tempprofile(k)=refprofile_summer(k,mref)*dbz_lightning(i,j) + enddo + lowest=newlvlAll(3) + highest=12000.0_r_kind + endif + DO k2=1,nsig + heightGSI=h_bk(i,j,k2) + if(heightGSI >= lowest .and. heightGSI < highest) then ! lower 12km ? + do k=1,maxlvl-1 + if( heightGSI >=newlvlAll(k) .and. heightGSI < newlvlAll(k+1) ) ilvl=k + enddo + upref=tempprofile(ilvl+1) + downref=tempprofile(ilvl) + wght=(heightGSI-newlvlAll(ilvl))/(newlvlAll(ilvl+1)-newlvlAll(ilvl)) + tempref=(1-wght)*downref + wght*upref + ref_mos_3d(i,j,k2) = max(ref_mos_3d(i,j,k2),tempref) + endif + ENDDO + endif + ENDDO + ENDDO + +END SUBROUTINE convert_lghtn2ref_nmmb diff --git a/src/GSD/gsdcloud4nmmb/diff.sh b/src/GSD/gsdcloud4nmmb/diff.sh new file mode 100755 index 0000000000..9cd06f644c --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/diff.sh @@ -0,0 +1,11 @@ + +set -x +rm -f ttt +flnm=`ls *90` +for iflnm in $flnm +do + echo "**********" >> ttt + echo $iflnm >> ttt + diff $iflnm ../gsdcloud_old/$iflnm >> ttt + echo >> ttt +done diff --git a/src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 b/src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 new file mode 100755 index 0000000000..ca2703ae4f --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/get_sfm_1d_gnl.f90 @@ -0,0 +1,384 @@ +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: get_sfm_1d_gnl +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate liquid water content for convection cloud +! This subroutine is from ARPS cloud analysis package +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +!################################################################## +!################################################################## +!###### ###### +!###### SUBROUTINE GET_SFM_1D ###### +!###### ###### +!###### Developed by ###### +!###### Center for Analysis and Prediction of Storms ###### +!###### University of Oklahoma ###### +!###### ###### +!################################################################## +!################################################################## +! + +SUBROUTINE get_sfm_1d_gnl (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & + l_prt) +! +!----------------------------------------------------------------------- +! +! PURPOSE: +!c----------------------------------------------------------------- +!c +!c This is the streamlined version of the Smith-Feddes +!c and Temperature Adjusted LWC calculation methodologies +!c produced at Purdue University under sponsorship +!c by the FAA Technical Center. +!c +!c Currently, this subroutine will only use the Smith- +!c Feddes and will only do so as if there are solely +!c stratiform clouds present, however, it is very easy +!c to switch so that only the Temperature Adjusted +!c method is used. +!c +!c Dilution by glaciation is also included, it is a +!c linear function of in cloud temperature going from +!c all liquid water at -10 C to all ice at -30 C +!c as such the amount of ice is also calculated +! +!----------------------------------------------------------------------- +! +! AUTHOR: Jian Zhang +! 05/96 Based on the LAPS cloud analysis code of 07/1995 +! +! MODIFICATION HISTORY: +! +! 05/16/96 (Jian Zhang) +! Modified for ADAS format. Added full documentation. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER :: nz ! number of model vertical levels + REAL :: zs_1d(nz) ! physical height (m) at each scalar level + REAL :: p_mb_1d(nz) ! pressure (mb) at each level + REAL :: t_1d(nz) ! temperature (K) at each level + + REAL :: zcb ! cloud base height (m) + REAL :: zctop ! cloud top height (m) +! +! OUTPUT: + REAL :: ql(nz) ! liquid water content (g/kg) + REAL :: qi(nz) ! ice water content (g/kg) + REAL :: cldt(nz) +! +! LOCAL: + REAL :: calw(200) + REAL :: cali(200) + REAL :: catk(200) + REAL :: entr(200) +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + REAL :: dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso + REAL :: c,a1,b1,c1,a2,b2,c2 + REAL :: delz,delt,cldbtm,cldbp,cldtpt,tbar + REAL :: arg,fraclw,tlwc + REAL :: temp,press,zbase,alw,zht,ht,y + REAL :: rl,es,qvs1,p,des,dtz,es2,qvs2 + INTEGER :: i,j,k,nlevel,nlm1,ip,kctop,kctop1,kcb,kcb1 + REAL :: dtdz,dttdz,zcloud,entc,tmpk + LOGICAL :: l_prt +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Initialize 1d liquid water and ice arrays (for 100m layers) +! +!----------------------------------------------------------------------- +! + DO i=1,200 + calw(i)=0.0 + cali(i)=0.0 + END DO +! +!----------------------------------------------------------------------- +! +! Preset some constants and coefficients. +! +!----------------------------------------------------------------------- +! + dz=100.0 ! m + rv=461.5 ! J/deg/kg + rair=287.04 ! J/deg/kg + grav=9.81 ! m/s2 + cp=1004. ! J/deg/kg + rlvo=2.5003E+6 ! J/kg + rlso=2.8339E+6 ! J/kg + dlvdt=-2.3693E+3 ! J/kg/K + eso=610.78 ! pa + c=0.01 + a1=8.4897 + b1=-13.2191 + c1=4.7295 + a2=10.357 + b2=-28.2416 + c2=8.8846 +! +!----------------------------------------------------------------------- +! +! Calculate indices of cloud top and base +! +!----------------------------------------------------------------------- +! + DO k=1,nz-1 + IF(zs_1d(k) < zcb .AND. zs_1d(k+1) > zcb) THEN + kcb=k + kcb1=kcb+1 + END IF + IF(zs_1d(k) < zctop .AND. zs_1d(k+1) > zctop) THEN + kctop=k + kctop1=kctop+1 + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Obtain cloud base and top conditions +! +!----------------------------------------------------------------------- +! + delz = zs_1d(kcb+1)-zs_1d(kcb) + delt = t_1d(kcb+1)-t_1d(kcb) + cldbtm = delt*(zcb-zs_1d(kcb))/delz+t_1d(kcb) + tbar = (cldbtm+t_1d(kcb))/2. + arg = -grav*(zcb-zs_1d(kcb))/rair/tbar + cldbp = p_mb_1d(kcb)*EXP(arg) + delz = zs_1d(kctop+1)-zs_1d(kctop) + delt = t_1d(kctop+1)-t_1d(kctop) + cldtpt = delt*(zctop-zs_1d(kctop))/delz+t_1d(kctop) +! +!----------------------------------------------------------------------- +! +! Calculate cloud lwc profile for cloud base/top pair +! +!----------------------------------------------------------------------- +! + temp = cldbtm + press = cldbp*100.0 + zbase = zcb + nlevel = ((zctop-zcb)/100.0)+1 + IF(nlevel <= 0) nlevel=1 + alw = 0.0 + calw(1)= 0.0 + cali(1)= 0.0 + catk(1)= temp + entr(1)= 1.0 + nlm1 = nlevel-1 + IF(nlm1 < 1) nlm1=1 + zht = zbase + + DO j=1,nlm1 + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es = eso*EXP(arg) + qvs1 = 0.622*es/(press-es) +! rho1 = press/(rair*temp) + arg = -grav*dz/rair/temp + p = press*EXP(arg) + + IF(l_prt) THEN + WRITE(6,605) j,zht,temp,press,1000.0*qvs1,es,rl + 605 FORMAT('get_sfm_1d_gnl:',1X,i2,' ht=',f8.0,' T=',f6.1,' P=',f9.1,' qvs=', & + f7.3,' es=',f6.1,' Lv=',e10.3) + END IF +! +!----------------------------------------------------------------------- +! +! Calculate saturated adiabatic lapse rate +! +!----------------------------------------------------------------------- +! + des = es*rl/temp/temp/rv + dtz = -grav*((1.0+0.621*es*rl/(press*rair*temp))/ & + (cp+0.621*rl*des/press)) + zht = zht+dz + press = p + temp = temp+dtz*dz + rl = rlvo+(273.15-temp)*dlvdt + arg = rl*(temp-273.15)/273.15/temp/rv + es2 = eso*EXP(arg) + qvs2 = 0.622*es2/(press-es2) + + alw = alw+(qvs1-qvs2) ! kg/kg + calw(j+1) = alw + + IF (l_prt) THEN + WRITE(6,9015) j,1000.0*calw(j+1),zht + 9015 FORMAT('get_sfm_1d_gnl',1X,'j=',i3,' adiab.lwc =',f7.3,' alt =',f8.0) + END IF +! +!----------------------------------------------------------------------- +! +! Reduction of lwc by entrainment +! +!----------------------------------------------------------------------- +! + ht = (zht-zbase)*.001 +! +!c ------------------------------------------------------------------ +!c +!c skatskii's curve(convective) +!c +!c ------------------------------------------------------------------ +!c if(ht.lt.0.3) then +!c y = -1.667*(ht-0.6) +!c elseif(ht.lt.1.0) then +!c arg1 = b1*b1-4.0*a1*(c1-ht) +!c y = (-b1-sqrt(arg1))/(2.0*a1) +!c elseif(ht.lt.2.9) then +!c arg2 = b2*b2-4.0*a2*(c2-ht) +!c y = (-b2-sqrt(arg2))/(2.0*a2) +!c else +!c y = 0.26 +!c endif +!c +!c ------------------------------------------------------------------ +!c +!c warner's curve(stratiform) +!c +!c ------------------------------------------------------------------ + IF(ht < 0.032) THEN + y = -11.0*ht+1.0 ! y(ht=0.032) = 0.648 + ELSE IF(ht <= 0.177) THEN + y = -1.4*ht+0.6915 ! y(ht=0.177) = 0.4437 + ELSE IF(ht <= 0.726) THEN + y = -0.356*ht+0.505 ! y(ht=0.726) = 0.2445 + ELSE IF(ht <= 1.5) THEN + y = -0.0608*ht+0.2912 ! y(ht=1.5) = 0.2 + ELSE + y = 0.20 + END IF +! +!----------------------------------------------------------------------- +! +! Calculate reduced lwc by entrainment and dilution +! +! Note at -5 C and warmer, all liquid. ! changed from -10 KB +! at -25 C and colder, all ice ! changed from -30 KB +! Linear ramp between. +! +!----------------------------------------------------------------------- +! + IF(temp < 268.15) THEN + IF(temp > 248.15) THEN + fraclw=0.05*(temp-248.15) + ELSE + fraclw=0.0 + END IF + ELSE + fraclw=1.0 + END IF + + tlwc=1000.*y*calw(j+1) ! g/kg + calw(j+1)=tlwc*fraclw + cali(j+1)=tlwc*(1.-fraclw) + catk(j+1)=temp + entr(j+1)=y + + END DO +! +!----------------------------------------------------------------------- +! +! Alternative calculation procedure using the observed or +! inferred in cloud temperature profile +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Obtain profile of LWCs at the given grid point +! +!----------------------------------------------------------------------- +! + + DO ip=2,nz-1 + IF(zs_1d(ip) <= zcb .OR. zs_1d(ip) > zctop) THEN + ql(ip)=0.0 + qi(ip)=0.0 + cldt(ip)=t_1d(ip) + ELSE + DO j=2,nlevel + zcloud = zcb+(j-1)*dz + IF(zcloud >= zs_1d(ip)) THEN + ql(ip) = (zs_1d(ip)-zcloud+100.)*(calw(j)-calw(j-1))*0.01 & + +calw(j-1) + qi(ip) = (zs_1d(ip)-zcloud+100.)*(cali(j)-cali(j-1))*0.01 & + +cali(j-1) + tmpk = (zs_1d(ip)-zcloud+100.)*(catk(j)-catk(j-1))*0.01 & + +catk(j-1) + entc = (zs_1d(ip)-zcloud+100.)*(entr(j)-entr(j-1))*0.01 & + +entr(j-1) + cldt(ip) = (1.-entc)*t_1d(ip) + entc*tmpk + + EXIT + END IF + END DO + END IF + END DO +! +!----------------------------------------------------------------------- +! +! Write out file of lwc comparisons +! +!----------------------------------------------------------------------- +! + RETURN +END SUBROUTINE get_sfm_1d_gnl diff --git a/src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 b/src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 new file mode 100755 index 0000000000..bd1c8f5bd9 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/hydro_mxr_thompson.f90 @@ -0,0 +1,198 @@ +SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs_3d, istatus, mype ) +! +! PURPOSE: +! Calculate (1) snow mixing ratio, (2) rain mixing ratio, and (3) rain number concentration +! from reflectivity for Thompson microphysics scheme. A Marshall-Palmer drop-size distribution +! is assumed for rain. +! +! HISTORY: +! 2013-01-30: created by David Dowell, Greg Thompson, Ming Hu +! +! ACKNOWLEDGMENTS: +! Donghai Wang and Eric Kemp (code template from pcp_mxr_ferrier) +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qnr_3d - rain number concentration (/kg) +! qs_3d - snow mixing ratio (g/kg) +! istatus - +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single, i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz) ! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow mixing ratio (g/kg) + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio (g/kg) + REAL(r_single),intent(out) :: qnr_3d(nx,ny,nz) ! rain number concentration (/kg) +! +! PARAMETERS: + REAL(r_kind), PARAMETER :: min_ref = 0.0_r_kind ! minimum reflectivity (dBZ) for converting to qs and qr + REAL(r_kind), PARAMETER :: max_ref_snow = 28.0_r_kind ! maximum reflectivity (dBZ) for converting to qs + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: max_ref_rain = 55.0_r_kind ! maximum reflectivity (dBZ) for converting to qr + ! (values above max_ref are treated as max_ref) + REAL(r_kind), PARAMETER :: n0r_mp = 8.0e6_r_kind ! Marshall-Palmer intercept parameter for rain (m**-4) + REAL(r_kind), PARAMETER :: rd= 287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: am_s = 0.069_r_kind + REAL(r_kind), PARAMETER :: bm_s = 2.0_r_kind + REAL(r_kind), PARAMETER :: PI = 3.1415926536_r_kind + REAL(r_kind), PARAMETER :: rho_i = 890.0_r_kind + REAL(r_kind), PARAMETER :: rho_w = 1000.0_r_kind +! +! LOCAL VARIABLES: + INTEGER(i_kind) :: i,j,k + REAL(r_kind) :: rho ! air density (kg m**-3) + REAL(r_kind) :: zes ! reflectivity (m**6 m**-3) associated with snow + REAL(r_kind) :: zer ! reflectivity (m**6 m**-3) associated with rain + REAL(r_kind) :: tc ! temperature (Celsius) + REAL(r_kind) :: rfract ! rain fraction + REAL(r_kind) :: tc0 + REAL(r_kind) :: smo2 + REAL(r_kind) :: rs + REAL(r_kind) :: f + REAL(r_kind) :: loga_ + REAL(r_kind) :: a_ + REAL(r_kind), PARAMETER :: a_min = 1.0e-5_r_kind ! lower bound for a_, to avoid large mixing ratios retrieved + ! for tiny particles sizes in cold temperatures + REAL(r_kind) :: b_ + REAL(r_kind) :: sa(10) + REAL(r_kind) :: sb(10) + REAL(r_kind) :: cse(3) + REAL(r_kind) :: crg(4) + REAL(r_kind) :: am_r + REAL(r_kind) :: oams + REAL(r_kind) :: qs ! snow mixing ratio in kg / kg + REAL(r_kind) :: qr ! rain mixing ratio in kg / kg +! +! for snow moments conversions (from Field et al. 2005) + DATA sa / 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/ + DATA sb / 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/ + +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + istatus=0 + + f = (0.176_r_kind/0.93_r_kind) * (6.0_r_kind/PI)*(6.0_r_kind/PI) * (am_s/rho_i)*(am_s/rho_i) + cse(1) = bm_s + 1.0_r_kind + cse(2) = bm_s + 2.0_r_kind + cse(3) = bm_s * 2.0_r_kind + oams = 1.0_r_kind / am_s + + crg(1) = 24.0_r_kind + crg(2) = 1.0_r_kind + crg(3) = 24.0_r_kind + crg(4) = 5040.0_r_kind + am_r = PI * rho_w / 6.0_r_kind + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + + IF (ref_3d(i,j,k) >= min_ref) THEN + + rho = p_3d(i,j,k) / (rd*t_3d(i,j,k)) + tc = t_3d(i,j,k) - 273.15_r_kind + + IF (tc <= 0.0_r_kind) THEN + rfract = 0.0_r_kind + ELSE IF (tc >= 5.0_r_kind) THEN + rfract = 1.0_r_kind + ELSE + rfract = 0.20_r_kind*tc + ENDIF + + zes = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_snow) ) ) & + * (1.0_r_kind-rfract) & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + zer = ( 10.0_r_kind**( 0.1_r_kind * min(ref_3d(i,j,k), max_ref_rain) ) ) & + * rfract & + * 1.0e-18_r_kind ! conversion from (mm**6 m**-3) to (m**6 m**-3) + + tc0 = MIN(-0.1, tc) + IF (bm_s.lt.(1.999_r_kind) .or. bm_s.gt.(2.001_r_kind)) THEN + PRINT*, 'ABORT (hydro_mxr_thompson): bm_s = ', bm_s + STOP + ENDIF + + ! Calculate bm_s*2 (th) moment. Useful for reflectivity. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(3) & + + sa(4)*tc0*cse(3) + sa(5)*tc0*tc0 & + + sa(6)*cse(3)*cse(3) + sa(7)*tc0*tc0*cse(3) & + + sa(8)*tc0*cse(3)*cse(3) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(3)*cse(3)*cse(3) + a_ = max( 10.0_r_kind ** loga_, a_min ) + b_ = sb(1) + sb(2)*tc0 + sb(3)*cse(3) + sb(4)*tc0*cse(3) & + + sb(5)*tc0*tc0 + sb(6)*cse(3)*cse(3) & + + sb(7)*tc0*tc0*cse(3) + sb(8)*tc0*cse(3)*cse(3) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) + + qs = ( (zes / (f*a_)) ** (1.0_r_kind / b_) ) / (rho*oams) + qs_3d(i,j,k) = 1000.0_r_kind * qs ! convert from kg / kg to g / kg + + qr = n0r_mp * am_r * crg(3) / rho * (zer / (n0r_mp*crg(4)))**(4.0_r_kind/7.0_r_kind) + qnr_3d(i,j,k) = (n0r_mp/rho)**(3.0_r_kind/4.0_r_kind) & + * (qr / (am_r * crg(3)))**(1.0_r_kind/4.0_r_kind) + + qnr_3d(i,j,k) = max(1.0_r_kind, qnr_3d(i,j,k)) + qr_3d(i,j,k) = 1000.0_r_kind * qr ! convert from kg / kg to g / kg + + +! if(mype==51 ) then +! write(*,'(a10,3i5,2f10.5,3f8.2)') 'b=',i,j,k,qs_3d(i,j,k),qr_3d(i,j,k),ref_3d(i,j,k),& +! p_3d(i,j,k)/100.0,tc +! endif + + + ELSE + + qs_3d(i,j,k) = -999._r_kind + qr_3d(i,j,k) = -999._r_kind + qnr_3d(i,j,k) = -999._r_kind + + END IF + + END DO ! k + END DO ! i + END DO ! j +! +! PRINT*,'finish hydro_mxr_thompson...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE hydro_mxr_thompson diff --git a/src/GSD/gsdcloud4nmmb/kinds.f90 b/src/GSD/gsdcloud4nmmb/kinds.f90 new file mode 100755 index 0000000000..73fbe3b568 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/kinds.f90 @@ -0,0 +1,105 @@ +module kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 2 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module kinds diff --git a/src/GSD/gsdcloud4nmmb/make.dependencies b/src/GSD/gsdcloud4nmmb/make.dependencies new file mode 100755 index 0000000000..64f49a7346 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/make.dependencies @@ -0,0 +1,35 @@ +kinds.o : kinds.f90 +constants.o : constants.f90 kinds.o + +ARPS_cldLib.o : ARPS_cldLib.f90 kinds.o constants.o +BackgroundCld.o : BackgroundCld.f90 kinds.o constants.o +BckgrndCC.o : BckgrndCC.f90 kinds.o constants.o +CheckCld.o : CheckCld.f90 kinds.o constants.o +radar_ref2tten.o : radar_ref2tten.f90 kinds.o constants.o +PrecipMxr_radar.o : PrecipMxr_radar.f90 kinds.o constants.o +PrecipType.o : PrecipType.f90 kinds.o constants.o +TempAdjust.o : TempAdjust.f90 kinds.o constants.o +adaslib.o : adaslib.f90 kinds.o constants.o +build_missing_REFcone.o : build_missing_REFcone.f90 kinds.o constants.o +cloudCover_NESDIS.o : cloudCover_NESDIS.f90 kinds.o constants.o +cloudCover_Surface.o : cloudCover_Surface.f90 kinds.o constants.o +cloudCover_radar.o : cloudCover_radar.f90 kinds.o constants.o +cloudLWC.o : cloudLWC.f90 kinds.o constants.o +cloudLayers.o : cloudLayers.f90 kinds.o constants.o +cloudType.o : cloudType.f90 kinds.o constants.o +convert_lghtn2ref.o : convert_lghtn2ref.f90 kinds.o constants.o +cloud_saturation.o : cloud_saturation.f90 kinds.o +get_sfm_1d_gnl.o : get_sfm_1d_gnl.f90 kinds.o constants.o +vinterp_radar_ref.o : vinterp_radar_ref.f90 kinds.o constants.o +map_ctp.o : map_ctp.f90 kinds.o constants.o +map_ctp_lar.o : map_ctp_lar.f90 kinds.o constants.o +mthermo.o : mthermo.f90 kinds.o constants.o +pcp_mxr_ARPSlib.o : pcp_mxr_ARPSlib.f90 kinds.o constants.o +## q_adjust.o : q_adjust.f90 kinds.o constants.o +read_Lightning_cld.o : read_Lightning_cld.f90 kinds.o constants.o +read_Lightningbufr_cld.o : read_Lightningbufr_cld.f90 kinds.o constants.o +read_NESDIS.o : read_NESDIS.f90 kinds.o constants.o +read_radar_ref.o : read_radar_ref.f90 kinds.o constants.o +read_Surface.o :read_Surface.f90 kinds.o constants.o +read_nasalarc_cld.o : read_nasalarc_cld.f90 kinds.o constants.o +smooth.o : smooth.f90 kinds.o constants.o diff --git a/src/GSD/gsdcloud4nmmb/make.filelist b/src/GSD/gsdcloud4nmmb/make.filelist new file mode 100755 index 0000000000..e268baf513 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/make.filelist @@ -0,0 +1,36 @@ +SRC_FILES = ARPS_cldLib.f90 \ + BackgroundCld.f90 \ + BckgrndCC.f90 \ + radar_ref2tten.f90 \ + PrecipMxr_radar.f90 \ + PrecipType.f90 \ + TempAdjust.f90 \ + adaslib.f90 \ + build_missing_REFcone.f90 \ + cloudCover_NESDIS.f90 \ + cloudCover_Surface.f90 \ + cloudCover_radar.f90 \ + cloudLWC.f90 \ + cloudLayers.f90 \ + cloudType.f90 \ + cloud_saturation.f90 \ + convert_lghtn2ref.f90 \ + get_sfm_1d_gnl.f90 \ + vinterp_radar_ref.f90 \ + map_ctp.f90 \ + map_ctp_lar.f90 \ + mthermo.f90 \ + pcp_mxr_ARPSlib.f90 \ + read_Lightning_cld.f90 \ + read_Lightningbufr_cld.f90 \ + read_NESDIS.f90 \ + read_radar_ref.f90 \ + read_Surface.f90 \ + read_nasalarc_cld.f90 \ + smooth.f90 \ + constants.f90 \ + kinds.f90 \ + pbl_height.f90 \ + hydro_mxr_thompson.f90 + +OBJ_FILES =${SRC_FILES:.f90=.o} diff --git a/src/GSD/gsdcloud4nmmb/makefile b/src/GSD/gsdcloud4nmmb/makefile new file mode 100755 index 0000000000..7f2808fff5 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/makefile @@ -0,0 +1,36 @@ +SHELL=/bin/sh + +LIB = ./libgsdcloud.a + +include make.filelist + +FFLAGS = -O3 -g -fp-model strict -convert big_endian -assume byterecl -implicitnone -traceback # -I../../../include +.SUFFIXES: .f90 .o + +.f90.o: +## $(RM) $@ $*.mod + ifort $(FFLAGS) -c $< + + +all: $(LIB) + +$(LIB): $(OBJ_FILES) + $(AR) -ruv $(LIB) $(OBJ_FILES) + +.f90.a: + ifort -c $(FFLAGS) $< +# ar -ruv $(AFLAGS) $@ $*.o +# rm -f $*.o + +.c.a: + $(CC) -c $(CFLAGS) $< +# ar -ruv $(AFLAGS) $@ $*.o +# rm -f $*.o + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +include make.dependencies + +clean: + rm -f *.o *.mod $(LIB) + diff --git a/src/GSD/gsdcloud4nmmb/map_ctp.f90 b/src/GSD/gsdcloud4nmmb/map_ctp.f90 new file mode 100755 index 0000000000..139d46153a --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/map_ctp.f90 @@ -0,0 +1,291 @@ +subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp map GOES cloud product to analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map GOES cloud product to analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=60) + + character header*80 +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt, qc, type + integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ioption + integer(i_kind) :: ipt,ixx,ii,jj,i,med_pt,igrid,jgrid & + ,ncount,ncount1,ncount2,ii1,jj1,nobs,n + + real(r_kind) :: xc + real(r_kind) :: yc + + real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + w_eca (ii,jj) =-99999._r_kind + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind + if(data_s(8,ipt) > 50 ) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-2), min(ny,jj1+2) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-2), min(nx,ii1+2) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(6,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 + Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if (index(ii,jj) < 3 ) then +! sat_ctp(ii,jj) = Pxx(ii,jj,1) +! sat_tem(ii,jj) = Txx(ii,jj,1) +! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. +! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... + + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample + if(ioption == 1) then !nearest neighborhood + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) + w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind + endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_frac(ii,jj) = fr + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp + +subroutine sorting(d,n,is) + use kinds, only: r_kind,i_kind + implicit none + + integer(i_kind), intent(in) :: n + real(r_kind) , intent(inout) :: d(n) + integer(i_kind), intent(inout) :: is(n) +! + integer(i_kind) :: nm1,ip1,iold,i,j + real(r_kind) :: temp +! +! + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(d(i) <= d(j)) goto 10 + temp = d(i) + d(i) = d(j) + d(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sorting + +subroutine sortmed(p,n,is,f) + use kinds, only: r_kind,i_kind + implicit none + real(r_kind), intent(inout) :: p(n) + integer(i_kind), intent(in) :: n + integer(i_kind), intent(inout) :: is(n) +! * count cloudy fov + real(r_kind), intent(out) :: f + integer(i_kind) :: cfov +! + integer(i_kind) :: i,j,nm1,ip1,iold + real(r_kind) :: temp +! +! +! + cfov = 0 + do i=1,n + if(p(i) < 999._r_kind) cfov = cfov + 1 + enddo + f = float(cfov)/(max(1,n)) +! cloud-top pressure is sorted high cld to clear + nm1 = n-1 + do 10 i=1,nm1 + ip1 = i+1 + do 10 j=ip1,n + if(p(i)<=p(j)) goto 10 + temp = p(i) + p(i) = p(j) + p(j) = temp + iold = is(i) + is(i) = is(j) + is(j) = iold + 10 continue + return +end subroutine sortmed diff --git a/src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 b/src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 new file mode 100644 index 0000000000..329b4de0bd --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/map_ctp_lar.f90 @@ -0,0 +1,256 @@ +subroutine map_ctp_lar(ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: map_ctp_lar map Langley cloud product to analysis grid +! +! PRGMMR: Shun Liu ORG: GSD/AMB DATE: 2006-03_10 +! +! ABSTRACT: +! This subroutine map Langley cloud product to analysis grid, copy from map_ctp +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! ib - begin i point of this domain +! jb - begin j point of this domain +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nn_obs - 1st dimension of observation arry data_s +! numsao - number of observation +! data_s - observation array for GOES cloud products +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! adapted according to RUC subroutine rd_cld +! * +! * This routine reads NESDIS (Madison, WI) cloud product produced +! * from GOES sounder data. The original product is reprocessed onto +! * MAPS40 grid boxes. There could be more than one cloud product +! * in a grid-box, so we use the nearest one that falls in the +! * grid. The routine combines GOES-8 and 10 products. +! +! ===== History ===== +! +! * Internal variables: +! CTP_E, CTP_W Soft-linked filename for ascii GOES Clouds +! +! * Working variables: +! +! * Working variables used for sorting max size of 10: +! Pxx, Txx, xdist,xxxdist (R4) +! Fxx, Nxx, index, jndex (I4) +! ioption (I4) = 1 if selection is nearest neighbor +! = 2 if selection is median of samples +! +! +! * Output variables on gridpoint (Nx,Ny): +! sat_ctp, sat_tem (R4) Cloud-top pressure and temperature +! w_frac (R4) Effective fractional cloud coverage, option=1 +! fractional coverage within RUC grid, option=2 +! w_eca (R4) Effective fractional cloud regardless option +! (effective cloud amount - eca) +! nlev_cld (I4) Number of cloud levels. TO BE USED LATER +! to incorporate multi-level cloud +! +! * Calling routines +! sorting +! sortmed +! +! * +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,r_single,i_kind + use constants, only: zero,one_tenth,one,deg2rad + + implicit none + +! input-file variables: + INTEGER(i_kind),intent(in) :: Nx, Ny + INTEGER(i_kind),intent(in) :: ib, jb + INTEGER(i_kind),intent(in) :: numsao, nn_obs + real(r_kind),dimension(nn_obs,numsao):: data_s +! Output + real(r_single), intent(out) :: sat_ctp(Nx,Ny) + real(r_single), intent(out) :: sat_tem(Nx,Ny) + real(r_single), intent(out) :: w_lwp(Nx,Ny) + real(r_single), intent(out) :: w_frac(Nx,Ny) +! +! misc + integer(i_kind) :: nfov + parameter (nfov=650) + + character header*80 +! Working + real(r_kind) :: Pxx(Nx,Ny,nfov),Txx(Nx,Ny,nfov) + real(r_kind) :: PHxx(Nx,Ny,nfov),WPxx(Nx,Ny,nfov) + real(r_kind) :: xdist(Nx,Ny,nfov), xxxdist(nfov) + real(r_kind) :: fr,sqrt, qc, type + integer(i_kind) :: Nxx(Nx,Ny,nfov),index(Nx,Ny), jndex(nfov) + integer(i_kind) :: ioption + integer(i_kind) :: ipt,ixx,ii,jj,i,med_pt,igrid,jgrid & + ,ncount,ncount1,ncount2,ii1,jj1,nobs,n + + real(r_kind) :: xc + real(r_kind) :: yc + + real(r_single) :: w_eca(Nx,Ny) + integer(i_kind) :: nlev_cld(Nx,Ny) + integer(i_kind) :: ios,cfov + +! +! * Initialize outputs since GOES sounder do not scan all MAPS domain +! + do jj=1,Ny + do ii=1,Nx + sat_ctp (ii,jj) =-99999._r_kind + sat_tem (ii,jj) =-99999._r_kind + w_lwp (ii,jj) =-99999._r_kind + w_frac (ii,jj) =-99999._r_kind + nlev_cld (ii,jj) =-99999 + index(ii,jj) = 0 + enddo + enddo + +! -- set ios as failed unless valid data points are found below + ios = 0 + +! ----------------------------------------------------------- +! ----------------------------------------------------------- +! Map each FOV onto RR grid points +! ----------------------------------------------------------- +! ----------------------------------------------------------- + do ipt=1,numsao + + xc=data_s(2,ipt) - ib + 1.0_r_kind + yc=data_s(3,ipt) - jb + 1.0_r_kind +! write(6,*)'sat_tem::',data_s(2,ipt),data_s(3,ipt),ib,jb + if(data_s(8,ipt) > 650 ) cycle + +! * XC,YC should be within subdomain boundary, i.e., XC,YC >0 + + if(XC >= 1._r_kind .and. XC < Nx .and. & + YC >= 1._r_kind .and. YC < Ny) then + ii1 = int(xc+0.5_r_kind) + jj1 = int(yc+0.5_r_kind) + + do jj = max(1,jj1-2), min(ny,jj1+2) + if (jj1-1 >= 1 .and. jj1+1 <= ny) then + do ii = max(1,ii1-2), min(nx,ii1+2) + if (ii1-1 >= 1 .and. ii1+1 <= nx) then + +! * We check multiple data within gridbox + + if (index(ii,jj) < nfov) then + index(ii,jj) = index(ii,jj) + 1 + + Pxx(ii,jj,index(ii,jj)) = data_s(4,ipt) + Txx(ii,jj,index(ii,jj)) = data_s(5,ipt) + PHxx(ii,jj,index(ii,jj)) = data_s(6,ipt) + WPxx(ii,jj,index(ii,jj)) = data_s(7,ipt) +!mhu Nxx(ii,jj,index(ii,jj)) = int(data_s(5,ipt)) +!mhu no cloud amount available, assign to 100 +! Nxx(ii,jj,index(ii,jj)) = 100 + nlev_cld(ii,jj) = 1 +! write(6,*)'sat_tem1::',index(ii,jj),data_s(4,ipt),data_s(5,ipt),data_s(6,ipt),data_s(7,ipt) + xdist(ii,jj,index(ii,jj)) = sqrt( & + (XC+1-ii)**2 + (YC+1-jj)**2) + end if + endif + enddo ! ii + endif + enddo ! jj + endif ! observation is in the domain + enddo ! ipt +! +! * ioption = 1 is nearest neighrhood +! * ioption = 2 is median of cloudy fov + ioption = 2 +! + do jj = 1,Ny + do ii = 1,Nx + if (index(ii,jj) < 3 ) then +! sat_ctp(ii,jj) = Pxx(ii,jj,1) +! sat_tem(ii,jj) = Txx(ii,jj,1) +! w_frac(ii,jj) = float(Nxx(ii,jj,1))/100. +! w_eca(ii,jj) = float(Nxx(ii,jj,1))/100. + + elseif(index(ii,jj) >= 3) then + +! * We decided to use nearest neighborhood for ECA values, +! * a kind of convective signal from GOES platform... + + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = xdist(ii,jj,i) + enddo + call sorting(xxxdist,index(ii,jj),jndex) +! w_eca(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! * Sort to find closest distance if more than one sample +! if(ioption == 1) then !nearest neighborhood +! do i=1,index(ii,jj) +! jndex(i) = i +! xxxdist(i) = xdist(ii,jj,i) +! enddo +! call sorting(xxxdist,index(ii,jj),jndex) +! sat_ctp(ii,jj) = Pxx(ii,jj,jndex(1)) +! sat_tem(ii,jj) = Txx(ii,jj,jndex(1)) +! w_frac(ii,jj) = float(Nxx(ii,jj,jndex(1)))/100._r_kind +! endif +! * Sort to find median value + if(ioption == 2) then !pick median + do i=1,index(ii,jj) + jndex(i) = i + xxxdist(i) = Pxx(ii,jj,i) + enddo + call sortmed(xxxdist,index(ii,jj),jndex,fr) + med_pt = index(ii,jj)/2 + 1 + sat_ctp(ii,jj) = Pxx(ii,jj,jndex(med_pt)) + sat_tem(ii,jj) = Txx(ii,jj,jndex(med_pt)) + w_lwp(ii,jj) = WPxx(ii,jj,jndex(med_pt)) + if (sat_ctp(ii,jj).eq.-20) then + sat_ctp(ii,jj) = 1013. ! hPa - no cloud + w_frac(ii,jj)=0.0 + nlev_cld(ii,jj) = 0 + end if + +! +! cloud fraction based on phase (0 are clear), what about -9 ???? + if( sat_ctp(ii,jj) < 1012.99) then + cfov = 0 + do i=1,index(ii,jj) + if(PHxx(ii,jj,i) .gt. 0.1) cfov = cfov + 1 + enddo + w_frac(ii,jj) = float(cfov)/(max(1,index(ii,jj))) ! fraction + if( w_frac(ii,jj) > 0.01 ) nlev_cld(ii,jj) = 1 + endif + +! write(6,*)'sat_tem2::',index(ii,jj),sat_ctp(ii,jj),sat_tem(ii,jj) + endif + endif + enddo !ii + enddo !jj + + return +end subroutine map_ctp_lar diff --git a/src/GSD/gsdcloud4nmmb/mthermo.f90 b/src/GSD/gsdcloud4nmmb/mthermo.f90 new file mode 100755 index 0000000000..3388a5228a --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/mthermo.f90 @@ -0,0 +1,229 @@ +! +!$$$ subprogram documentation block +! . . . . +! ABSTRACT: +! This file collects subroutines and functions related to thermodynamic calculations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2010-05-03 Hu Clean the code +! +! +! input argument list: +! +! output argument list: +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + FUNCTION esat(t) +! +! this function returns the saturation vapor pressure over +! water (mb) given the temperature (celsius). +! the algorithm is due to nordquist, w.s.,1973: "numerical approxima- +! tions of selected meteorlolgical parameters for cloud physics prob- +! lems," ecom-5475, atmospheric sciences laboratory, u.s. army +! electronics command, white sands missile range, new mexico 88002. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind),intent(in) :: t + real(r_single) :: tk,p1,p2,c1 + real(r_kind) :: esat + + tk = t+273.15 + p1 = 11.344-0.0303998*tk + p2 = 3.49149-1302.8844/tk + c1 = 23.832241-5.02808*ALOG10(tk) + esat = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tk) + RETURN + END FUNCTION esat + + FUNCTION eslo(t) +! +! this function returns the saturation vapor pressure over liquid +! water eslo (millibars) given the temperature t (celsius). the +! formula is due to lowe, paul r.,1977: an approximating polynomial +! for the computation of saturation vapor pressure, journal of applied +! meteorology, vol 16, no. 1 (january), pp. 100-103. +! the polynomial coefficients are a0 through a6. + use kinds, only: r_single,i_kind,r_kind + IMPLICIT NONE +! + real(r_kind), intent(in) :: t + real(r_kind) :: eslo + + real(r_kind) :: a0,a1,a2,a3,a4,a5,a6 + real(r_kind) :: es + + DATA a0,a1,a2,a3,a4,a5,a6 & + /6.107799961, 4.436518521E-01, 1.428945805E-02, & + 2.650648471E-04, 3.031240396E-06, 2.034080948E-08, & + 6.136820929E-11/ + es = a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) + IF (es < 0.) es = 0. + eslo = es + RETURN + END FUNCTION eslo + + FUNCTION tda(o,p) +! +! this function returns the temperature tda (celsius) on a dry adiabat +! at pressure p (millibars). the dry adiabat is given by +! potential temperature o (celsius). the computation is based on +! poisson's equation. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: o,p + real(r_kind) :: tda + + tda= (o+273.15)*((p*.001)**.286)-273.15 + RETURN + END FUNCTION tda + + FUNCTION tmr(w,p) +! +! this function returns the temperature (celsius) on a mixing +! ratio line w (g/kg) at pressure p (mb). the formula is given in +! table 1 on page 7 of stipanuk (1973). +! +! initialize constants + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: w,p + real(r_kind) :: tmr + + real(r_kind) :: c1,c2,c3,c4,c5,c6 + real(r_kind) :: x,tmrk + real(r_single) :: y + + DATA c1/.0498646455/,c2/2.4082965/,c3/7.07475/ + DATA c4/38.9114/,c5/.0915/,c6/1.2035/ + + y=w*p/(622.+w) + x= alog10(y) + tmrk= 10.**(c1*x+c2)-c3+c4*((10.**(c5*x)-c6)**2.) + tmr= tmrk-273.15 + RETURN + END FUNCTION tmr + + FUNCTION tsa(os,p) +! +! this function returns the temperature tsa (celsius) on a saturation +! adiabat at pressure p (millibars). os is the equivalent potential +! temperature of the parcel (celsius). sign(a,b) replaces the +! algebraic sign of a with that of b. +! b is an empirical constant approximately equal to 0.001 of the latent +! heat of vaporization for water divided by the specific heat at constant +! pressure for dry air. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: os,p + real(r_kind) :: tsa + + real(r_kind) :: a,b,d,tq,x,tqk,w + integer :: i + + DATA b/2.6518986/ + a= os+273.15 + +! tq is the first guess for tsa. + + tq= 253.15 + +! d is an initial value used in the iteration below. + + d= 120. + +! iterate to obtain sufficient accuracy....see table 1, p.8 +! of stipanuk (1973) for equation used in iteration. + + DO i= 1,12 + tqk= tq-273.15 + d= d/2. + x= a*EXP(-b*w(tqk,p)/tq)-tq*((1000./p)**.286) + IF (ABS(x) < 1E-7) GOTO 2 + tq= tq+SIGN(d,x) + END DO +2 tsa= tq-273.15 + RETURN + END FUNCTION tsa + + FUNCTION tw(t,td,p) +! this function returns the wet-bulb temperature tw (celsius) +! given the temperature t (celsius), dew point td (celsius) +! and pressure p (mb). see p.13 in stipanuk (1973), referenced +! above, for a description of the technique. +! +! +! determine the mixing ratio line thru td and p. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,td,p + real(r_kind) :: tw + + real(r_kind) :: aw,ao,pi,tmr,tda,ti,aos,tsa,w,x + integer :: i + + aw = w(td,p) +! +! determine the dry adiabat thru t and p. + + ao = (t+273.15)*((1000./p)**.286)-273.15 + pi = p + +! iterate to locate pressure pi at the intersection of the two +! curves . pi has been set to p for the initial guess. + + DO i= 1,10 + x= .02*(tmr(aw,pi)-tda(ao,pi)) + IF (ABS(x) < 0.01) EXIT + pi= pi*(2.**(x)) + END DO + +! find the temperature on the dry adiabat ao at pressure pi. + + ti= tda(ao,pi) + +! the intersection has been located...now, find a saturation +! adiabat thru this point. function os returns the equivalent +! potential temperature (c) of a parcel saturated at temperature +! ti and pressure pi. + + aos= (ti+273.15)*((1000./pi)**.286)*(EXP(2.6518986*w(ti,pi)/(ti+273.15)))-273.15 + +! function tsa returns the wet-bulb temperature (c) of a parcel at +! pressure p whose equivalent potential temperature is aos. + + tw = tsa(aos,p) + RETURN + END FUNCTION tw + + FUNCTION w(t,p) +! +! this function returns the mixing ratio (grams of water vapor per +! kilogram of dry air) given the dew point (celsius) and pressure +! (millibars). if the temperture is input instead of the +! dew point, then saturation mixing ratio (same units) is returned. +! the formula is found in most meteorological texts. + use kinds, only: r_single,i_kind,r_kind + implicit none + real(r_kind), intent(in) :: t,p + real(r_kind) :: w + + real(r_kind) :: esat + + w= 622.*esat(t)/(p-esat(t)) + RETURN + END FUNCTION w diff --git a/src/GSD/gsdcloud4nmmb/pbl_height.f90 b/src/GSD/gsdcloud4nmmb/pbl_height.f90 new file mode 100755 index 0000000000..6466899f01 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/pbl_height.f90 @@ -0,0 +1,103 @@ +SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pbl_height to calculate PBL height or level +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2011-04-06 +! +! ABSTRACT: +! This subroutine calculate PBL height +! +! PROGRAM HISTORY LOG: +! +! +! input argument list: +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! q_bk - 3D moisture +! t_bk - 3D background potential temperature (K) +! p_bk - 3D background pressure (hPa) +! +! output argument list: +! pblh - 2D PBL height (level number) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind, r_kind + + implicit none + + integer(i_kind),intent(in):: mype + integer(i_kind),intent(in):: nlat,nlon,nsig +! +! background +! + real(r_single),intent(in) :: t_bk(nlon,nlat,nsig) ! potential temperature (K) + real(r_single),intent(in) :: q_bk(nlon,nlat,nsig) ! mixing ratio (kg/kg) + real(r_single),intent(in) :: p_bk(nlon,nlat,nsig) ! pressure (hpa) +! +! Variables for cloud analysis +! + real (r_single),intent(out) :: pblh(nlon,nlat) +! +!----------------------------------------------------------- +! +! temp. +! + INTEGER(i_kind) :: i,j,k + real(r_single) :: thetav(nsig) + real(r_single) :: thsfc,qsp + +!==================================================================== +! Begin +! +! + DO j = 1,nlat + DO i = 1,nlon + + DO k = 1,nsig + qsp=q_bk(i,j,k)/(1.0+q_bk(i,j,k)) ! q_bk = water vapor mixing ratio + thetav(k) = t_bk(i,j,k)*(1.0 + 0.61 * qsp) ! qsp = spcific humidity +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',k,thetav(k),t_bk(i,j,k),q_bk(i,j,k) +! endif + ENDDO + + pblh(i,j) = 0.0_r_single + thsfc = thetav(1) + k=1 + DO while (abs(pblh(i,j)) < 0.0001_r_single) + if( thetav(k) > thsfc + 1.0_r_single ) then + pblh(i,j) = float(k) - (thetav(k) - (thsfc + 1.0_r_single))/ & + max((thetav(k)-thetav(k-1)),0.01_r_single) + endif + k=k+1 + ENDDO + if(abs(pblh(i,j)) < 0.0001) pblh(i,j)=2.0_r_single + +! if(mype==10.and.i==10.and.j==10) then +! write(*,*) 'cal PBL=',pblh(i,j),k +! endif + + + enddo ! i + enddo ! j + +END SUBROUTINE calc_pbl_height + diff --git a/src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 b/src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 new file mode 100755 index 0000000000..2548e943b7 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/pcp_mxr_ARPSlib.f90 @@ -0,0 +1,757 @@ + +SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus ) + +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculates hydrometeor mixing ratios based on Kessler radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on Kessler radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old documents from CAPS +! +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Kessler (1969) +! formula: +! qr(g/kg) = a*(rho*arg)**b (1) +! +! Here arg = Z (mm**6/m**3), and dBZ = 10log10 (arg). +! Coeffcients a=17300.0, and b=7/4. +! rho represents the air density. +! +! For snow and graupel/hail, using Rogers and Yau (1989) formula: +! +! qs(g/kg) = c*(rho*arg)**d (2) +! +! where, c=38000.0, d=2.2 +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Jian Zhang) +! 06/13/96 +! +! MODIFICATION HISTORY: +! 07/30/97 (J. Zhang) +! Added precipitation type in the argument list so that +! mixing ratios of different precip. types can be computed. +! 09/04/97 (J. Zhang) +! Changed the radar echo thresholds for inserting precip. +! from radar reflectivities. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + +! +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + integer(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + real(r_single),intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + real(r_single),intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + integer(i_kind),intent(in):: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field +! +! OUTPUT: + INTEGER(i_kind),intent(out) :: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz)! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz)! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz)! graupel/hail mixing ratio in (g/kg) +! +! LOCAL: + REAL(r_kind) :: a,b,c,d ! Coef. for Z-qr relation. + PARAMETER (a=17300.0_r_kind, b=7.0/4.0_r_kind) + PARAMETER (c=38000.0_r_kind, d=2.2_r_kind) + REAL(r_kind) :: rair ! Gas constant (J/deg/kg) + PARAMETER (rair = 287.04_r_kind) + REAL(r_kind) :: thresh_ref + PARAMETER (thresh_ref = 0.0_r_kind) + INTEGER(i_kind) :: pcptype +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + REAL(r_kind) :: arg,rhobar,br,dr + PARAMETER (br=1.0_r_kind/b, dr=1.0_r_kind/d) +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! + istatus=0 +! +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Kessler (1969) or Rogers and Yau (1989). +! +!----------------------------------------------------------------------- +! + DO k = 1,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rhobar = p_3d(i,j,k)/rair/t_3d(i,j,k) + arg = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + + IF (pcptype == 0) THEN ! no precip + PRINT*,'+++ NOTE: radar echo though no precip. +++' + ELSE IF (pcptype == 1.OR.pcptype == 3) THEN ! rain or Z R + qr_3d(i,j,k) = (arg/a)**br/rhobar + ELSE IF (pcptype == 2) THEN ! snow + qs_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE IF (pcptype == 4.OR.pcptype == 5) THEN ! hail or sleet + qg_3d(i,j,k) = (arg/c)**dr/rhobar + ELSE ! unknown + PRINT*,'+++ NOTE: unknown precip type. +++' + END IF + ELSE + qr_3d(i,j,k) = 0._r_kind + qs_3d(i,j,k) = 0._r_kind + qg_3d(i,j,k) = 0._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr + +! +SUBROUTINE pcp_mxr_ferrier_new (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d,q_3d & + ,qr_3d,qs_3d,qg_3d,istatus ) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations +! from Carley's setup_dbz.f90 and old Hu's pcp_mxr_ferrier +! +! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on ferrier radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2014-12-01 Shun Liu create for new NMMB ferrier +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old document from CAPS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Ferrier et al (1995) +! formulation: +! +! +! For rain water: +! +! 18 +! 10 * 720 1.75 +! Zer = --------------------------- * (rho * qr) +! 1.75 0.75 1.75 +! pi * N0r * rhor +! +! +! For dry snow (t <= 0 C): +! +! +! 18 +! 0.224 * 10 * 720 +! 2 +! Zes = ------------------------------------- * (rho * qs) +! 2 2 +! pi * rhol * N0s +! +! n(0)r -> intercept parameter for rain 8x10^-6 (m^-4) +! rho_l -> density of liquid water 1000 (kg/m^3) +! rho -> air density (kg/m^3) +! qr -> rain mixing ratio (kg/kg) +! qli -> precipitation ice mixing ratio (kg/kg) +! N_li -> precipitation ice number concentration 5x10^3 (m^-3) +! +! +! Plugging in the constants yields the following form: +! +! Zer = Cr * (rho*qr)^1.75 +! Zeli = Cli * (rho*qli)^2 +! +! where: +! Cr = 3.6308 * 10^9 +! Cli = 3.268 * 10^9 +! +! Which yields the forward model: +! +! Z = 10*log10(Zer+Zes) +! +! +! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). +! rho represents the air density, rhor,rhos,rhoh are the density of +! rain, snow and hail respectively. Other variables are all constants +! for this scheme, see below. +! +! Zer = Cr * (rho*qr)^1.75 +! Zeli = Cli * (rho*qli)^2 +! +! where: +! Cr = 3.6308 * 10^9 +! Cli = 3.268 * 10^9 + +! (Zer)^(1/1.75)=(rho*qr) +! (Zer/Cr)^(1/1.75)=rho*qr +! [(Zer/Cr)^(1/1.75)]/rho=qr + +! [(Zeli/Cli)^(1/2)]/rho=qs + +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Shun Liu) +! 01/20/2015 +! +! MODIFICATION HISTORY: +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(in) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + REAL(r_single), intent(in) :: q_3d(nx,ny,nz) ! mixing ratio in (g/g) + + INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio + ! in (g/kg) +! + + + + REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind + + REAL(r_kind), PARAMETER :: ze_qr_const=3.6308*1.0e9 + REAL(r_kind), PARAMETER :: ze_qs_const=3.268*1.0e9 + REAL(r_kind) :: ze_d_qrcon,ze_d_qscon + +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + INTEGER(i_kind) :: pcptype + REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract + REAL(r_kind) :: ze,zer,zeh,zes,rho,tc + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, +! respectively, in Ferrier. +! +! These are the inverse of those presented in the reflec_ferrier function. +! +!----------------------------------------------------------------------- +! +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Ferrier et al (1995). +! +!----------------------------------------------------------------------- +! + +! qr_3d = -999._r_kind +! qs_3d = -999._r_kind + qg_3d = -999._r_kind + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rho = p_3d(i,j,k)/(rd*t_3d(i,j,k))*(1.0+0.608*(q_3d(i,j,k)/1.0+q_3d(i,j,k))) + ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + tc = t_3d(i,j,k) - 273.15_r_kind + IF (tc >= 0.0_r_kind) THEN + ze_d_qrcon=ze/ze_qr_const + qr_3d(i,j,k) = (ze_d_qrcon)**(1/1.75) !/ rho + else + ze_d_qscon=ze/ze_qs_const + qs_3d(i,j,k) = (ze_d_qscon)**(0.5) !/ rho + ENDIF + END IF + END DO ! k + END DO ! i + END DO ! j + +! qr_3d=qr_3d*1000.0 !kg/kg to g/kg +! qs_3d=qs_3d*1000.0 !kg/kg to g/kg + +! PRINT*,'Finish Ferrier ...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr_ferrier_new + +! +SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & + ,cldpcp_type_3d & + ,qr_3d,qs_3d,qg_3d,istatus,mype ) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: pcp_mxr calculate hydrometeor type based on ferrier radar reflectivity equations +! +! PRGMMR: ORG: DATE: +! +! ABSTRACT: +! This subroutine calculate precipitation based on ferrier radar reflectivity equations +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! nx - no. of lons on subdomain (buffer points on ends) +! ny - no. of lats on subdomain (buffer points on ends) +! nz - no. of levels +! t_3d - 3D background temperature (K) +! p_3d - 3D background pressure (hPa) +! ref_3d - 3D reflectivity in analysis grid (dBZ) +! cldpcp_type_3d - 3D precipitation type +! +! output argument list: +! qr_3d - rain mixing ratio (g/kg) +! qs_3d - snow mixing ratio (g/kg) +! qg_3d - graupel/hail mixing ratio (g/kg) +! istatus - +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! Old document from CAPS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +! PURPOSE: +! +! Perform 3D precipitation mixing ratio (in g/kg) analysis using +! radar reflectivity data. For rain water, using Ferrier et al (1995) +! formulation: +! +! +! For rain water: +! +! 18 +! 10 * 720 1.75 +! Zer = --------------------------- * (rho * qr) +! 1.75 0.75 1.75 +! pi * N0r * rhor +! +! +! For dry snow (t <= 0 C): +! +! +! 18 2 0.25 +! 10 * 720 * |K| * rhos +! ice 1.75 +! Zes = ----------------------------------------- * (rho * qs) t <= 0 C +! 1.75 2 0.75 2 +! pi * |K| * N0s * rhoi +! water +! +! +! For wet snow (t >= 0 C): +! +! +! 18 +! 10 * 720 1.75 +! Zes = ---------------------------- * (rho * qs) t > 0 C +! 1.75 0.75 1.75 +! pi * N0s * rhos +! +! +! For hail water: +! +! +! / 18 \ 0.95 +! / 10 * 720 \ 1.6625 +! Zeh = | ---------------------------- | * (rho * qg) +! \ 1.75 0.75 1.75 / +! \ pi * N0h * rhoh / +! +! Here Zx (mm**6/m**3, x=r,s,h), and dBZ = 10log10 (Zx). +! rho represents the air density, rhor,rhos,rhoh are the density of +! rain, snow and hail respectively. Other variables are all constants +! for this scheme, see below. +! +! +!----------------------------------------------------------------------- +! +! AUTHOR: (Donghai Wang and Eric Kemp) +! 07/20/2000 +! +! MODIFICATION HISTORY: +! +! 11/09/2000 Keith Brewster +! Moved some parameters with real-valued exponentiation to be +! computed at runtime due to compiler complaint. +! +! 04/07/2003 Keith Brewster +! Restructured code to make more tractable.and consistent with +! the reflec_ferrier subroutine. +! +!----------------------------------------------------------------------- +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + +!----------------------------------------------------------------------- +! +! Variable Declarations. +! +!----------------------------------------------------------------------- +! + use kinds, only: r_single,i_kind, r_kind + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! +! INPUT: + INTEGER(i_kind),intent(in) :: nx,ny,nz ! Model grid size +! + REAL(r_kind), intent(inout) :: ref_3d(nx,ny,nz)! radar reflectivity (dBZ) + REAL(r_single), intent(in) :: t_3d(nx,ny,nz) ! Temperature (deg. Kelvin) + REAL(r_single), intent(in) :: p_3d(nx,ny,nz) ! Pressure (Pascal) + + INTEGER(i_kind),intent(in) :: cldpcp_type_3d(nx,ny,nz) ! cloud/precip type field + INTEGER(i_kind),intent(in) :: mype +! +! OUTPUT: + INTEGER(i_kind),intent(out):: istatus +! + REAL(r_single),intent(out) :: qr_3d(nx,ny,nz) ! rain mixing ratio in (g/kg) + REAL(r_single),intent(out) :: qs_3d(nx,ny,nz) ! snow/sleet/frz-rain mixing ratio + ! in (g/kg) + REAL(r_single),intent(out) :: qg_3d(nx,ny,nz) ! graupel/hail mixing ratio + ! in (g/kg) +! + + REAL(r_kind),PARAMETER :: ki2 = 0.176_r_kind ! Dielectric factor for ice if other + ! than melted drop diameters are used. + REAL(r_kind),PARAMETER :: kw2=0.93_r_kind ! Dielectric factor for water. + + REAL(r_kind),PARAMETER :: m3todBZ=1.0E+18_r_kind ! Conversion factor from m**3 to + ! mm**6 m**-3. + REAL(r_kind),PARAMETER :: Zefact=720.0_r_kind ! Multiplier for Ze components. + REAL(r_kind),PARAMETER :: lg10div=0.10_r_kind ! Log10 multiplier (1/10) + + REAL(r_kind),PARAMETER :: pi=3.1415926_r_kind! Pi. + REAL(r_kind),PARAMETER :: N0r=8.0E+06_r_kind ! Intercept parameter in 1/(m^4) for rain. + REAL(r_kind),PARAMETER :: N0s=3.0E+06_r_kind ! Intercept parameter in 1/(m^4) for snow. + REAL(r_kind),PARAMETER :: N0h=4.0E+04_r_kind ! Intercept parameter in 1/(m^4) for graupel/hail. + + REAL(r_kind),PARAMETER :: N0xpowf=3.0/7.0_r_kind ! Power to which N0r,N0s & N0h are + ! raised. + REAL(r_kind),PARAMETER :: K2powf=4.0/7.0_r_kind ! Power to which K-squared + ! of ice, water are raised + REAL(r_kind),PARAMETER :: zkpowf=4.0/7.0_r_kind ! Power to which Zk is raised + REAL(r_kind),PARAMETER :: zepowf=4.0/7.0_r_kind ! Power to which Ze is raised + REAL(r_kind),PARAMETER :: zehpowf=(4.0/7.0)*1.0526_r_kind ! Power to which Zeh is raised + + REAL(r_kind),PARAMETER :: rhoi=917._r_kind ! Density of ice (kg m**-3) + REAL(r_kind),PARAMETER :: rhor=1000._r_kind ! Density of rain (kg m**-3) + REAL(r_kind),PARAMETER :: rhos=100._r_kind ! Density of snow (kg m**-3) + REAL(r_kind),PARAMETER :: rhoh=913._r_kind ! Density of graupel/hail (kg m**-3) + + REAL(r_kind),PARAMETER :: rhoipowf=8.0/7.0_r_kind ! Power to which rhoi is raised. + REAL(r_kind),PARAMETER :: rhospowf=1.0/7.0_r_kind ! Power to which rhos is raised. + + REAL(r_kind), PARAMETER :: rd=287.0_r_kind ! Gas constant for dry air (m**2/(s**2*K)) + REAL(r_kind), PARAMETER :: thresh_ref = 0.0_r_kind +! +!----------------------------------------------------------------------- +! +! Misc local variables +! +!----------------------------------------------------------------------- +! + INTEGER(i_kind) :: i,j,k, iarg + INTEGER(i_kind) :: pcptype + REAL(r_kind) :: zkconst,zerf,zesnegf,zesposf,zehf,rfract + REAL(r_kind) :: ze,zer,zeh,zes,rho,tc + +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! Beginning of executable code... +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! +!----------------------------------------------------------------------- +! +! Intiailize constant factors in the Ze terms for rain, snow and graupel/hail, +! respectively, in Ferrier. +! +! These are the inverse of those presented in the reflec_ferrier function. +! +!----------------------------------------------------------------------- +! + istatus=0 + + zkconst = (Zefact*m3todBZ) ** zkpowf + + zerf=1000._r_kind*(pi * (N0r**N0xpowf) * rhor )/zkconst + + zesnegf=1000._r_kind*(pi*(kw2**k2powf)*(N0s**N0xpowf)*(rhoi**rhoipowf)) / & + ( zkconst * (ki2**k2powf) * (rhos**rhospowf) ) + + zesposf=1000._r_kind*( pi * (N0s**N0xpowf) * rhos) / zkconst + + zehf=1000._r_kind*( pi * (N0h**N0xpowf) * rhoh) / zkconst + +!----------------------------------------------------------------------- +! +! Compute the precip mixing ratio in g/kg from radar reflectivity +! factor following Ferrier et al (1995). +! +!----------------------------------------------------------------------- +! +!mhu if(mype==51 ) then +!mhu write(*,*) 'c=',mype,zesnegf,zepowf,rd +!mhu ref_3d(10,10,:)=10.0 +!mhu ref_3d(11,11,:)=20.0 +!mhu ref_3d(12,12,:)=30.0 +!mhu ref_3d(13,13,:)=40.0 +!mhu ref_3d(14,14,:)=50.0 +!mhu endif + + DO k = 2,nz-1 + DO j = 2,ny-1 + DO i = 2,nx-1 + IF (ref_3d(i,j,k) >= thresh_ref) THEN ! valid radar refl. + rho = p_3d(i,j,k)/(rd*t_3d(i,j,k)) + ze = 10.0_r_kind**(0.1_r_kind*ref_3d(i,j,k)) + iarg = cldpcp_type_3d(i,j,k) + pcptype = iarg/16 ! precip. type + tc = t_3d(i,j,k) - 273.15_r_kind +!mhu temporal fix + IF (tc <= 0.0_r_kind) THEN + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + qr_3d(i,j,k) = 0.0_r_kind + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze +! qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho +! qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qs_3d(i,j,k) = zesnegf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + else + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + qs_3d(i,j,k) = 0.0_r_kind + ENDIF + cycle +!mhu + IF (pcptype == 1) THEN ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 2) THEN ! snow + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF (tc < 5.0_r_kind) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 3) THEN ! ZR + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + ELSE IF (pcptype == 4) THEN ! sleet + IF (tc <= 0.0_r_kind) THEN ! graupel/hail category + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE IF( tc < 10._r_kind ) THEN + rfract=0.10_r_kind*tc + zer=rfract*ze + zeh=(1.-rfract)*ze + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + qg_3d(i,j,k) = zehf * (zeh**zehpowf) / rho + ELSE + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + ELSE IF (pcptype == 5) THEN ! graupel/hail + qg_3d(i,j,k) = zehf * (ze**zehpowf) / rho + ELSE ! unknown + IF (tc <= 0.0_r_kind) THEN !dry snow + qs_3d(i,j,k) = zesnegf * (ze**zepowf) / rho + ELSE IF ( tc < 5.0_r_kind ) THEN !wet snow + rfract=0.20_r_kind*tc + zer=rfract*ze + zes=(1.-rfract)*ze + qs_3d(i,j,k) = zesposf * (zes**zepowf) / rho + qr_3d(i,j,k) = zerf * (zer**zepowf) / rho + ELSE ! rain + qr_3d(i,j,k) = zerf * (ze**zepowf) / rho + END IF + END IF + ELSE + qr_3d(i,j,k) = -999._r_kind + qs_3d(i,j,k) = -999._r_kind + qg_3d(i,j,k) = -999._r_kind + END IF + END DO ! k + END DO ! i + END DO ! j +! PRINT*,'Finish Ferrier ...' +! +!----------------------------------------------------------------------- +! + istatus = 1 +! + RETURN +END SUBROUTINE pcp_mxr_ferrier diff --git a/src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 b/src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 new file mode 100755 index 0000000000..70570af91d --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/radar_ref2tten.f90 @@ -0,0 +1,631 @@ +SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d, & + cld_cover_3d,p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh,sat_ctp) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: radar_ref2tten convert radar reflectivity to 3-d temperature tendency +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 +! +! ABSTRACT: +! This subroutine converts radar observation (dBZ) to temperature tendency for DFI +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2016-05-08 S.Liu tune the relation between ref and tten +! +! +! input argument list: +! mype - processor ID +! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D radar reflectivity (dBZ) +! cld_cover_3d - 3D cloud cover (0-1) +! p_bk - 3D background pressure (hPa) +! t_bk - 3D background potential temperature (K) +! sat_ctp - 2D NESDIS cloud top pressure (hPa) +! ges_tten - 3D radar temperature tendency +! dfi_rlhtp - dfi radar latent heat time period. DFI forward integration window in minutes +! krad_bot_in - radar bottome height +! pblh - PBL height in grid unit +! +! output argument list: +! ges_tten - 3D radar temperature tendency +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use constants, only: rd_over_cp, h1000 + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),INTENT(IN) :: mype + INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig + INTEGER(i_kind),INTENT(IN) :: istat_radar + INTEGER(i_kind),INTENT(IN) :: istat_lightning + real(r_kind),INTENT(IN) :: dfi_rlhtp + real(r_single),INTENT(IN) :: krad_bot_in + real(r_single),INTENT(IN) :: pblh(nlon,nlat) + + real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) ! potential temperature + real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) + real(r_single),INTENT(IN),OPTIONAL :: sat_ctp(nlon,nlat) + + real (r_single) :: tbk_k + + real(r_kind), allocatable :: tten_radar(:,:,:) ! + real(r_kind), allocatable :: dummy(:,:) ! + + integer krad_bot ! RUC bottom level for TTEN_RAD +! +! convection suppression +! + real(r_kind), allocatable :: radyn(:,:) + real(r_kind) :: radmax, dpint + integer(i_kind) :: nrad + real(r_kind) :: radmaxall, dpintmax + +! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) +! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS +!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT +!** R* = 8.31451 +!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR +!** MD = 0.0289645 +!jmb--Old value MD = 0.0289644 +!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR +!** RD = R*>/-100) then ! no echo + tten_radar(i,j,k) = 0._r_kind + else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo + iskip=0 + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + iskip=iskip+1 +! write (6,*)' Radar ref > 5 dbZ, GOES indicates clear' +! write (6,*)' i,j,k / refl / lat-lon',i,j,k,ref_mos_3d(i,j,k) +! Therefore, if GOES indicates clear, tten_radar +! will retain the zero value + endif + endif + if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then + iskip=iskip+1 +! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) +! ALSO, if T > 4C and refl < 28dBZ, again +! tten_radar = 0. + endif + if(iskip == 0 ) then +! tten_radar set as non-zero ONLY IF +! - not contradicted by GOES clear, and +! - ruc_refl > 28 dbZ for temp > 4K, and +! - for temp < 4K, any ruc_refl dbZ is OK. +! - cloudy and under GOES cloud top +! - dfi_rlhtp in minutes + if (k>=krad_bot) then +! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d +! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind .and. (sat_ctp(i,j)>p_bk(i,j,k))) then + if (sat_ctp(i,j)>p_bk(i,j,k)) then + addsnow=0.0_r_kind + else + addsnow = 10**(ref_mos_3d(i,j,k)/(17.8_r_kind*2.0))/264083._r_kind*9.0_r_kind + endif + tten = ((1000.0_r_kind/p_bk(i,j,k))**(1._r_kind/cpovr_p)) & + *(((LV_P+LF0_P)*addsnow)/ & + (2.0*dfi_rlhtp*60.0_r_kind*CPD_P)) + tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) + end if + end if + end if ! ref_mos_3d + + ENDDO + ENDDO + ENDDO + +! DO k=1,nsig +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5) +! ENDDO + +!================================================================================ +! At this point +! 1. put tten_radar into ges_tten array +! for use as tten_radar in subsequent model DFI. +! 2. calculate convection suppression array (RADYN), by +! first smoothing further the tten_radar array +! (available since it is already copied to ges_tten) +! and with adding clear areas from GOES cloud data. + +! KEY element -- Set tten_radar to no-coverage AFTER smoothing +! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) +!================================================================================ + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,k,1)=tten_radar(i,j,k) + if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs + ENDDO + ENDDO + ENDDO +! DO k=1,nsig +! write(6,*)' k,max,min check=',mype,k,maxval(ges_tten(:,:,k,1)),minval(ges_tten(:,:,k,1)) +! enddo + +! -- Whack (smooth) the tten_radar array some more. +! for convection suppression in the radyn array. + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + + deallocate(dummy) + +! RADYN array = convection suppression array +! Definition of RADYN values +! -10 -> no information +! 0 -> no convection +! 1 -> there might be convection nearby +! NOTE: 0,1 values are only possible if +! deep radar coverage is available (i.e., > 300 hPa deep) + +! RADYN is read into RUC model as array PCPPREV, +! where it is used to set the cap_depth (cap_max) +! in the Grell-Devenyi convective scheme +! to a near-zero value, effectively suppressing convection +! during DFI and first 30 min of the forward integration. + + allocate(radyn(nlon,nlat)) + radyn = -10._r_kind + + radmaxall=-999 + dpintmax=-999 + DO j=1,nlat + DO i=1,nlon + + nrad = 0 + radmax = 0._r_kind + dpint = 0._r_kind + DO k=2,nsig-1 + if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p + if (tten_radar(i,j,k)>-15._r_kind) then + nrad=nrad+1 + dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) + radmax = max(radmax,tten_radar(i,j,k)) + end if + ENDDO + if (dpint>=300._r_kind ) then + radyn(i,j) = 0._r_kind + if (radmax>0.00002_r_kind) radyn(i,j) = 1. + if( abs(radyn(i,j)) < 0.00001_r_kind ) then + krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height + do k=krad_bot,nsig-1 + ges_tten(j,i,k,1) = 0._r_kind + end do + endif + else +! outside radar coverage area where satellite shows clear conditions, +! then add this area to the convection suppress area. + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>1010._r_kind .and. sat_ctp(i,j)<1100._r_kind) then + radyn(i,j) = 0._r_kind + endif + endif + endif + +! 2. Extend depth of no-echo zone from dpint zone down to PBL top, +! similarly to how lowest echo (with convection) is extended down to PBL top +! 5/27/2010 - Stan B. +! if (dpint >= 300. .and. radmax<=0.001) then +! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! do k=krad_bot,nsig-1 +! ges_tten(j,i,k,1) = 0._r_kind +! end do +! end if + + if(dpintmax < dpint ) dpintmax=dpint + if(radmaxall< radmax) radmaxall=radmax + ENDDO + ENDDO + + DO j=1,nlat + DO i=1,nlon +! ges_tten(j,i,nsig,1)=radyn(i,j) + ges_tten(j,i,nsig,1)=0.0 + ENDDO + ENDDO + + deallocate(tten_radar) + deallocate(radyn) + + else ! no radar observation i this subdomain + + ges_tten=-spval_p + ges_tten(:,:,nsig,1)=-10.0_r_kind + + DO j=1,nlat + DO i=1,nlon + +! outside radar observation domain and satellite show clean, the suppress convection + if (PRESENT(sat_ctp) ) then + if (sat_ctp(i,j)>=1010._r_kind .and. sat_ctp(i,j)<=1100._r_kind) then + ges_tten(j,i,nsig,1) = 0. + endif + endif + ENDDO + ENDDO + + endif + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs + ENDDO + ENDDO + ENDDO + +END SUBROUTINE radar_ref2tten + +SUBROUTINE radar_ref2tten_nosat(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mos_3d,cld_cover_3d,& + p_bk,t_bk,ges_tten,dfi_rlhtp,krad_bot_in,pblh) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: radar_ref2tten convert radar observation to temperature tedency +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-27 +! +! ABSTRACT: +! This subroutine converts radar reflectivity (dBZ) to temperature tendency for DFI +! +! PROGRAM HISTORY LOG: +! 2009-01-02 Hu Add NCO document block +! 2016-05-08 S.Liu tune the relation between ref and tten +! +! +! input argument list: +! mype - processor ID +! istat_radar - radar data status: 0=no radar data; 1=use radar reflectivity +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! ref_mos_3d - 3D radar reflectivity (dBZ) +! cld_cover_3d - 3D cloud cover (0-1) +! p_bk - 3D background pressure (hPa) +! t_bk - 3D background potential temperature (K) +! ges_tten - 3D radar temperature tendency +! dfi_rlhtp - dfi radar latent heat time period +! krad_bot_in - radar bottome height +! pblh - PBL height in grid unit +! +! output argument list: +! ges_tten - 3D radar temperature tendency +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use constants, only: rd_over_cp, h1000 + use kinds, only: r_kind,i_kind,r_single + implicit none + + INTEGER(i_kind),INTENT(IN) :: mype + INTEGER(i_kind),INTENT(IN) :: nlon,nlat,nsig + INTEGER(i_kind),INTENT(IN) :: istat_radar + INTEGER(i_kind),INTENT(IN) :: istat_lightning + real(r_kind),INTENT(IN) :: dfi_rlhtp + real(r_single),INTENT(IN) :: krad_bot_in + real(r_single),INTENT(IN) :: pblh(nlon,nlat) + + real(r_kind),INTENT(IN) :: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid + real(r_single),INTENT(IN) :: cld_cover_3d(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: p_bk(nlon,nlat,nsig) + real(r_single),INTENT(IN) :: t_bk(nlon,nlat,nsig) + real(r_kind), INTENT(INOUT):: ges_tten(nlat,nlon,nsig,1) + + real (r_single) :: tbk_k + + real(r_kind), allocatable :: tten_radar(:,:,:) ! + real(r_kind), allocatable :: dummy(:,:) ! + + integer(i_kind) :: krad_bot ! RUC bottom level for TTEN_RAD + ! and for filling from above +! +! convection suppression +! + real(r_kind), allocatable :: radyn(:,:) + real(r_kind) :: radmax, dpint + integer(i_kind) :: nrad + real(r_kind) :: radmaxall, dpintmax + +! adopted from: METCON of RUC (/ihome/rucdev/code/13km/hybfront_code) +! CONTAINS ATMOSPHERIC/METEOROLOGICAL/PHYSICAL CONSTANTS +!** R_P R J/(MOL*K) UNIVERSAL GAS CONSTANT +!** R* = 8.31451 +!** MD_P R KG/MOL MEAN MOLECULAR WEIGHT OF DRY AIR +!** MD = 0.0289645 +!jmb--Old value MD = 0.0289644 +!** RD_P R J/(KG*K) SPECIFIC GAS CONSTANT FOR DRY AIR +!** RD = R*>/-100) then ! no echo + tten_radar(i,j,k) = 0._r_kind + else if (ref_mos_3d(i,j,k)>=0.001_r_kind) then ! echo + iskip=0 + if (tbk_k>277.15_r_kind .and. ref_mos_3d(i,j,k)<28._r_kind) then + iskip=iskip+1 +! write (6,*)' t is over 277 ',i,j,k,ref_mos_3d(i,j,k) +! ALSO, if T > 4C and refl < 28dBZ, again +! tten_radar = 0. + endif + if(iskip == 0 ) then +! tten_radar set as non-zero ONLY IF +! - not contradicted by GOES clear, and +! - ruc_refl > 28 dbZ for temp > 4K, and +! - for temp < 4K, any ruc_refl dbZ is OK. +! - cloudy and under GOES cloud top + if (k>=krad_bot) then +! can not use cld_cover_3d because we don't use reflectivity to build cld_cover_3d +! if (abs(cld_cover_3d(i,j,k))<=0.5_r_kind) then +! addsnow=0.0_r_kind +! else + addsnow = 10**(ref_mos_3d(i,j,k)/(17.8_r_kind*2.0))/264083._r_kind*9.0_r_kind +! endif + tten = ((1000.0_r_kind/p_bk(i,j,k))**(1./cpovr_p)) & + *(((LV_P+LF0_P)*addsnow)/ & + (2.0*dfi_rlhtp*60.0_r_kind*CPD_P)) +! 60 = sec/min, and dfi_rlhtp is in minutes. +! NOTE: tten is in K/seconds + tten_radar(i,j,k)= min(0.01_r_kind,max(-0.01_r_kind,tten)) + end if + end if + end if ! ref_mos_3d + + ENDDO + ENDDO + ENDDO + + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + +! KEY element -- Set tten_radar to no-coverage AFTER smoothing +! where ref_mos_3d had been previously set to no-coverage (-99.0 dbZ) + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + ges_tten(j,i,k,1)=tten_radar(i,j,k) + if(ref_mos_3d(i,j,k)<=-200.0_r_kind ) ges_tten(j,i,k,1)=-spval_p ! no obs + ENDDO + ENDDO + ENDDO + +! -- Whack (smooth) the tten_radar array some more. +! for convection suppression in the radyn array. + DO k=1,nsig + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + call smooth(tten_radar(1,1,k),dummy,nlon,nlat,0.5_r_kind) + ENDDO + + deallocate(dummy) + +! RADYN array = convection suppression array +! Definition of RADYN values +! -10 -> no information +! 0 -> no convection +! 1 -> there might be convection nearby +! NOTE: 0,1 values are only possible if +! deep radar coverage is available (i.e., > 300 hPa deep) + +! RADYN is read into RUC model as array PCPPREV, +! where it is used to set the cap_depth (cap_max) +! in the Grell-Devenyi convective scheme +! to a near-zero value, effectively suppressing convection +! during DFI and first 30 min of the forward integration. + + allocate(radyn(nlon,nlat)) + radyn = -10. + + radmaxall=-999 + dpintmax=-999 + DO j=1,nlat + DO i=1,nlon + + nrad = 0 + radmax = 0._r_kind + dpint = 0._r_kind + DO k=2,nsig-1 + if ((ref_mos_3d(i,j,k))<=-200.0_r_kind) tten_radar(i,j,k) = -spval_p + if (tten_radar(i,j,k)>-15._r_kind) then + nrad=nrad+1 + dpint = dpint + 0.5_r_kind*(p_bk(i,j,k-1)-p_bk(i,j,k+1)) + radmax = max(radmax,tten_radar(i,j,k)) + end if + ENDDO + if (dpint>=300._r_kind ) then + radyn(i,j) = 0._r_kind + if (radmax>0.00002_r_kind) radyn(i,j) = 1._r_kind + if( abs(radyn(i,j)) < 0.00001_r_kind ) then + krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height + do k=krad_bot,nsig-1 + ges_tten(j,i,k,1) = 0._r_kind + end do + endif + endif + +! 2. Extend depth of no-echo zone from dpint zone down to PBL top, +! similarly to how lowest echo (with convection) is extended down to PBL top +! 5/27/2010 - Stan B. +! if (dpint.ge.300. .and. radmax.le.0.00001) then +! krad_bot= int( max(krad_bot_in,pblh(i,j)) + 0.5_r_single ) ! consider PBL height +! do k=krad_bot,nsig-1 +! ges_tten(j,i,k,1) = 0. +! end do +! end if + + if(dpintmax < dpint ) dpintmax=dpint + if(radmaxall< radmax) radmaxall=radmax + ENDDO + ENDDO + + DO j=1,nlat + DO i=1,nlon +! ges_tten(j,i,nsig,1)=radyn(i,j) + ges_tten(j,i,nsig,1)=0.0 + ENDDO + ENDDO + + deallocate(tten_radar) + deallocate(radyn) + + else + + ges_tten=-spval_p + ges_tten(:,:,nsig,1)=-10.0_r_kind + + endif + + DO k=1,nsig + DO j=1,nlat + DO i=1,nlon + if(ges_tten(j,i,k,1) <= -200.0_r_kind ) ges_tten(j,i,k,1)=-20.0_r_kind ! no obs + ENDDO + ENDDO + ENDDO + +END SUBROUTINE radar_ref2tten_nosat diff --git a/src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 b/src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 new file mode 100755 index 0000000000..9cf7c14539 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_Lightning_cld.f90 @@ -0,0 +1,95 @@ +SUBROUTINE read_Lightning2cld(mype,lunin,regional_time,istart,jstart, & + nlon,nlat,numlight,lightning) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in lightning flash rate +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 +! +! ABSTRACT: +! This subroutine read in lightning flash rate +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numlight - number of observation +! +! output argument list: +! lightning - lightning flash rate in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numlight + + real(r_single), intent(out):: lightning(nlon,nlat) +! +! local +! + real(r_kind),allocatable :: light_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj,k2, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + + read(lunin) obstype,isis,nreal,nchanl + + allocate( light_in(nreal,numlight) ) + light_in=-9999.0_r_kind + + read(lunin) light_in + DO i=1,numlight + ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & + 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & + 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb + lightning(ii,jj)=light_in(3,i) + ENDDO + deallocate(light_in) + +END SUBROUTINE read_Lightning2cld diff --git a/src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 b/src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 new file mode 100755 index 0000000000..0be3482eac --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_Lightningbufr_cld.f90 @@ -0,0 +1,109 @@ +SUBROUTINE read_Lightningbufr2cld(mype,lunin,regional_time,istart,jstart, & + nlon,nlat,numlight,lightning) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in lightning flash rate +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2008-11-30 +! +! ABSTRACT: +! This subroutine read in lightning flash rate +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2015-10-04 S.Liu using Lightning density from bufr data +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numlight - number of observation +! +! output argument list: +! lightning - lightning density + +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_kind,i_kind, r_single + implicit none + + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numlight + + real(r_kind), intent(out):: lightning(nlon,nlat) +! +! local +! + real(r_kind),allocatable :: light_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj,k2, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + ilon1s=1 + ilat1s=2 + +! write(6,891)mype,ib,jb +! read(lunin) obstype,isis,nreal,nchanl + read(lunin) obstype,isis,nreal,nchanl +! write(6,*)obstype,isis,nreal,nchanl,numlight + lightning=-999.0 + + allocate( light_in(nreal,numlight) ) + light_in=-9999.0_r_kind + read(lunin) light_in + + DO i=1,numlight + ii=int(light_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(light_in(ilat1s,i)+0.001_r_kind) - jb + 2 + + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_Lightning_cld: ', & + 'Error in read in lightning ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_Lightning_cld:', & + 'Error in read in lightning jj:',mype,ii,jj,i,ib,jb + lightning(ii,jj)=light_in(3,i) +! write(6,89)mype,light_in(ilon1s,i),light_in(ilat1s,i),light_in(3,i),light_in(ilon1s,i),ib,jb,ii,jj + ENDDO +! write(6,892)nreal,nchanl,numlight + + deallocate(light_in) +89 format('readLightningbufr0::',i8,4f12.2,4i6) +893 format('readLightningbufr0::',i8,3f9.2) +891 format('readLightningbufr0::',4i8) +892 format('readLightningbufr1::',3i8) + + +END SUBROUTINE read_Lightningbufr2cld diff --git a/src/GSD/gsdcloud4nmmb/read_NESDIS.f90 b/src/GSD/gsdcloud4nmmb/read_NESDIS.f90 new file mode 100755 index 0000000000..644a725a0a --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_NESDIS.f90 @@ -0,0 +1,125 @@ +SUBROUTINE read_NESDIS(mype,lunin,numobs,regional_time,istart,jstart,nlon,nlat, & + sat_ctp,sat_tem,w_frac) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in NESDIS cloud products and map them into analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + + real(r_single), intent(out):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single), intent(out):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single), intent(out):: w_frac(nlon,nlat) ! cloud fraction +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j, itmp, jtmp + INTEGER(i_kind) :: ib, jb + character*12 :: adate +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp (ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_frac(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + +END SUBROUTINE read_NESDIS diff --git a/src/GSD/gsdcloud4nmmb/read_Surface.f90 b/src/GSD/gsdcloud4nmmb/read_Surface.f90 new file mode 100755 index 0000000000..0a2d02bbea --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_Surface.f90 @@ -0,0 +1,251 @@ +SUBROUTINE read_Surface(mype,lunin,regional_time,istart,jstart,nlon,nlat,& + numsao,NVARCLD_P,OI,OJ,OCLD,OWX,Oelvtn,Odist,cstation, & + OIstation,OJstation) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_Surface read in cloud observations in surface observation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in cloud observations in surface observation +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numsao - maximum observation number (observation number) +! NVARCLD_P - first dimension of OLCD +! +! output argument list: +! +! OI - observation x location +! OJ - observation y location +! OLCD - cloud amount, cloud height, visibility +! OWX - weather observation +! Oelvtn - observation elevation +! Odist - distance from the nearest station +! cstation - station name + +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! + + use kinds, only: r_single,i_kind,r_kind,r_double + + implicit none + + integer(i_kind), intent(in) :: mype + integer(i_kind), intent(in) :: lunin + integer(i_kind), intent(in) :: regional_time(6) + integer(i_kind), intent(in) :: istart + integer(i_kind), intent(in) :: jstart + INTEGER(i_kind), intent(in) :: nlon,nlat + INTEGER(i_kind), intent(in) :: numsao + INTEGER(i_kind), intent(in) :: NVARCLD_P + + real(r_single), intent(out) :: OI(numsao) ! x location, grid + real(r_single), intent(out) :: OJ(numsao) ! y location, grid + INTEGER(i_kind), intent(out) :: OCLD(NVARCLD_P,numsao) ! cloud amount, cloud height, + ! visibility + CHARACTER*10, intent(out) :: OWX(numsao) ! weather + real(r_single), intent(out) :: Oelvtn(numsao) ! elevation + real(r_single), intent(out) :: Odist(numsao) ! distance from the nearest station + character(8), intent(out) :: cstation(numsao) ! station name + real(r_single), intent(out) :: OIstation(numsao) ! x location, station + real(r_single), intent(out) :: OJstation(numsao) ! y location, station + +! +! temp. +! + character*12 :: adate + character*9 :: STANAM ! stattion name + real(r_single) :: LAT ! latitude + real(r_single) :: LON ! longitude + + real(r_single) :: VIS ! horizontal visibility + real(r_single) :: CLD(3) ! cloud base height + character*10 :: WX ! weather + character*8 :: sky(3) ! cloud cover or amount + +! +! misc. +! + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse + character(10) :: obstype + integer(i_kind):: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: nn_obs + real(r_kind) :: cldamt,awx,cldhgt + character*3 :: msky,mwx + INTEGER(i_kind) :: i,j,k,k2,ic,jb,ib + integer(i_kind) :: start, end + + real(r_kind) :: spval_p + parameter (spval_p = 99999.) + + real(r_double) rstation_id + character(8) :: cstation1,cc,ci + equivalence(cstation1,rstation_id) + + +!==================================================================== +! Begin + OWX='' + OCLD=-99999 + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + +! + read(lunin) obstype,isis,nreal,nchanl + + nn_obs = nreal + nchanl + allocate(luse(numsao),data_s(nn_obs,numsao)) + read(lunin) data_s, luse +! +! read in ruface observations: +! station name, x location, y location, longitude, latitude, elevation +! visibility, cloud amount, cloud height, weather +! + DO i=1,numsao + rstation_id=data_s(1,i) + cstation(i)=cstation1 + OI(i) = data_s(2,i) - ib + 2 ! covert it to the local grid + OJ(i) = data_s(3,i) - jb + 2 ! covert it to the local grid + if( OI(i) < 1 .or. OI(i) > nlon ) write(6,*) 'read_Surface: Error in reading ii:',mype,OI(i),ib,jb + if( OJ(i) < 1 .or. OJ(i) > nlat ) write(6,*) 'read_Surface: Error in reading jj:',mype,OJ(i),ib,jb + Oelvtn(i) = data_s(4,i) + Odist(i) = data_s(23,i) + OIstation(i) = data_s(24,i) + OJstation(i) = data_s(25,i) + if(data_s(22,i) > 50 ) cycle ! do not use this data + VIS = data_s(5,i) +! cloud amonut and base height +! C 020011 +! 0 0 oktas (0/10) +! 1 1 okta or less, but not zero (1/10 or less, but not zero) +! 2 2 oktas (2/10 - 3/10) +! 3 3 oktas (4/10) +! 4 4 oktas (5/10) +! 5 5 oktas (6/10) +! 6 6 oktas (7/10 - 8/10) +! 7 7 oktas or more, but not 8 oktas (9/10 or more, but not 10/10) +! 8 8 oktas (10/10) +! 9 Sky obscured by fog and/or other meteorological phenomena +! 10 Sky partially obscured by fog and/or other meteorological phenomena +! 11 Scattered +! 12 Broken +! 13 Few +! 14 Reserved +! 15 Cloud cover is indiscernible for reasons other than +! fog or other meteorological phenomena, or observation is not made + + DO j=1,3 + cldamt = data_s(5+j,i) ! cloud amount + cldhgt = int(data_s(11+j,i)) ! cloud bottom height + if(cldamt < spval_p .and. cldhgt < spval_p) then + if(abs(cldamt-0._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=0 !msky='CLR' + cldhgt=spval_p + elseif(abs(cldamt-13._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 !msky='FEW' + elseif(abs(cldamt-11._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=2 !msky='SCT' + elseif(abs(cldamt-12._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=3 !msky='BKN' + elseif((abs(cldamt-8._r_kind) < 0.0001_r_kind) .or. & + (abs(cldamt-9._r_kind) < 0.0001_r_kind)) then + OCLD(j,i)=4 ! msky='OVC' msky='VV ' + elseif(abs(cldamt-1._r_kind) < 0.0001_r_kind) then + OCLD(j,i)=1 + elseif(abs(cldamt-2._r_kind) < 0.0001_r_kind .or. & + abs(cldamt-3._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=2 + elseif(cldamt > 3.5_r_kind .and. cldamt < 6.5_r_kind ) then + OCLD(j,i)=3 + elseif(abs(cldamt-7._r_kind) < 0.0001_r_kind ) then + OCLD(j,i)=4 + else + OCLD(j,i) = spval_p ! wrong cloud observation type + cldhgt = spval_p + endif + if(cldhgt > 0.0_r_kind ) then + OCLD(6+j,i) = cldhgt + else + OCLD(j,i) = spval_p + OCLD(6+j,i) = spval_p + endif + else + OCLD(j,i) = 99 + OCLD(6+j,i) = spval_p + endif + enddo ! j +! weather + DO j=1,3 + awx = data_s(17+j,i) ! weather + mwx=' ' + if(awx>=10._r_kind .and.awx<=12._r_kind ) mwx='BR ' + if(awx>=110._r_kind.and.awx<=112._r_kind) mwx='BR ' + if(awx==5._r_kind .or. awx==105._r_kind) mwx='HZ ' + if(awx>=40._r_kind .and.awx<=49._r_kind ) mwx='FG ' + if(awx>=130._r_kind.and.awx<=135._r_kind) mwx='FG ' + if(awx>=50._r_kind .and.awx<=59._r_kind ) mwx='DZ ' + if(awx>=150._r_kind.and.awx<=159._r_kind) mwx='DZ ' + if(awx>=60._r_kind .and.awx<=69._r_kind ) mwx='RA ' + if(awx>=160._r_kind.and.awx<=169._r_kind) mwx='RA ' + if(awx>=70._r_kind .and.awx<=78._r_kind ) mwx='SN ' + if(awx>=170._r_kind.and.awx<=178._r_kind) mwx='SN ' + if(awx==79._r_kind .or. awx==179._r_kind) mwx='PE ' + + if(awx>=80._r_kind .and.awx<=90._r_kind ) mwx='SH ' + if(awx>=180._r_kind.and.awx<=187._r_kind) mwx='SH ' + if(awx>=91._r_kind .and.awx<=99._r_kind ) mwx='TH ' + if(awx>=190._r_kind.and.awx<=196._r_kind) mwx='TH ' + + if (j==1) start=1 + if (j==2) start=4 + if (j==3) start=7 + end=start+2 + OWX(i)(start:end)=mwx + enddo +! visiblity + IF(VIS > spval_P) then + OCLD(13,i)=spval_P + else + IF(VIS > 100.0_r_kind ) then + OCLD(13,i)=int(VIS) + elseif(VIS <=100.0_r_kind .and. VIS > 0.0_r_kind ) then + OCLD(13,i)=100 +! write(6,*) 'read_Surface, Warning: change visibility to 100 m !!!' + ENDIF + endif + + ENDDO ! i = numsao +! + +END SUBROUTINE read_Surface + diff --git a/src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 b/src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 new file mode 100755 index 0000000000..8b26f7b284 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_nasalarc_cld.f90 @@ -0,0 +1,167 @@ +SUBROUTINE read_nasalarc(mype,lunin,numobs,regional_time,istart,jstart,nlon,nlat, & + nasalarc) +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in NESDIS cloud products and map them into analysis grid +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-10-30 +! +! ABSTRACT: +! This subroutine read in NESDIS cloud products and map them into analysis grid +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! 2013-12-20 S.Liu modify to read bufr file and do interpolation in GSI +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! numobs - number of observation +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! +! output argument list: +! sat_ctp - GOES cloud top pressure in analysis grid +! sat_tem - GOES cloud top temperature in analysis grid +! w_frac - GOES cloud coverage in analysis grid +! +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + + use kinds, only: r_single,i_kind,r_kind + + implicit none + + integer(i_kind),intent(in) :: mype + integer(i_kind),intent(in) :: lunin + INTEGER(i_kind),intent(in) :: numobs + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + + real(r_single):: sat_ctp(nlon,nlat) ! cloud top pressure + real(r_single):: sat_tem(nlon,nlat) ! cloud top temperature + real(r_single):: w_frac(nlon,nlat) ! cloud fraction + real(r_single):: w_lwp(nlon,nlat) ! cloud fraction + integer(i_kind):: nlev_cld(nlon,nlat) ! cloud fraction + real(r_single):: nasalarc(nlon,nlat,5) +! + INTEGER(i_kind) :: nn_obs + real(r_kind),allocatable,dimension(:,:):: data_s + logical,allocatable,dimension(:):: luse +! +! misc. +! + character(10) :: obstype + integer(i_kind) :: mm1 + integer(i_kind) :: nreal,nchanl + character(20) :: isis + + INTEGER(i_kind) :: i, j, itmp, jtmp + INTEGER(i_kind) :: ib, jb + character*12 :: adate +! +! =============================================================== +! + + mm1=mype+1 + + read(lunin) obstype,isis,nreal,nchanl + nn_obs = nreal + nchanl + allocate(luse(numobs),data_s(nn_obs,numobs)) + read(lunin) data_s, luse + +! do i=1,numobs +! write(6,*)'sliu larcclddata::',data_s(1,i),data_s(2,i),data_s(3,i) +! end do + +! write(6,*)'read_NESDIS::',mype, maxval(data_s(7,:)),numobs + + + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + call map_ctp_lar(ib,jb,nlon,nlat,nn_obs,numobs,data_s,sat_ctp,sat_tem,w_frac,w_lwp,nlev_cld) +!! +! filling boundarys +! + DO i=2,nlon-1 + sat_ctp(i,1) =sat_ctp(i,2) + sat_tem(i,1) =sat_tem(i,2) + w_frac(i,1) =w_frac(i,2) + w_lwp(i,1) =w_lwp(i,2) + nlev_cld(i,1) =nlev_cld(i,2) + sat_ctp(i,nlat)=sat_ctp(i,nlat-1) + sat_tem(i,nlat)=sat_tem(i,nlat-1) + w_frac(i,nlat) =w_frac(i,nlat-1) + w_lwp(i,nlat) =w_lwp(i,nlat-1) + nlev_cld(i,nlat) =nlev_cld(i,nlat-1) + enddo + DO j=2,nlat-1 + sat_ctp(1,j) =sat_ctp(2,j) + sat_tem(1,j) =sat_tem(2,j) + w_frac(1,j) =w_lwp(2,j) + w_lwp(1,j) =w_lwp(2,j) + nlev_cld(1,j) =nlev_cld(2,j) + sat_ctp(nlon,j)=sat_ctp(nlon-1,j) + sat_tem(nlon,j)=sat_tem(nlon-1,j) + w_frac(nlon,j) =w_frac(nlon-1,j) + w_lwp(nlon,j) =w_lwp(nlon-1,j) + nlev_cld(nlon,j) =nlev_cld(nlon-1,j) + enddo + sat_ctp(1,1) =sat_ctp(2,2) + sat_tem(1,1) =sat_tem(2,2) + w_frac(1,1) =w_frac(2,2) + w_lwp(1,1) =w_lwp(2,2) + nlev_cld(1,1) =nlev_cld(2,2) + + sat_ctp(1,nlat) =sat_ctp(2,nlat-1) + sat_tem(1,nlat) =sat_tem(2,nlat-1) + w_frac(1,nlat) =w_frac(2,nlat-1) + w_lwp(1,nlat) =w_lwp(2,nlat-1) + nlev_cld(1,nlat) =nlev_cld(2,nlat-1) + + sat_ctp(nlon,1) =sat_ctp(nlon-1,2) + sat_tem(nlon,1) =sat_tem(nlon-1,2) + w_frac(nlon,1) =w_frac(nlon-1,2) + w_lwp(nlon,1) =w_lwp(nlon-1,2) + nlev_cld(nlon,1) =nlev_cld(nlon-1,2) + + sat_ctp(nlon,nlat)=sat_ctp(nlon-1,nlat-1) + sat_tem(nlon,nlat)=sat_tem(nlon-1,nlat-1) + w_frac(nlon,nlat) =w_frac(nlon-1,nlat-1) + + do i=1,nlon + do j=1,nlat + nasalarc(i,j,1)=sat_ctp(i,j) + nasalarc(i,j,2)=sat_tem(i,j) + nasalarc(i,j,3)=w_frac(i,j) !/100.0 + nasalarc(i,j,4)=w_lwp(i,j) !/100.0 + nasalarc(i,j,5)=nlev_cld(i,j) +! if(abs(sat_tem(i,j))>0.and.abs(sat_tem(i,j))<400) then +! write(6,*)'sat_tem2 in read_cloud::',sat_ctp(i,j),sat_tem(i,j),nasalarc(i,j,1) +! end if + end do + end do + + +END SUBROUTINE read_nasalarc diff --git a/src/GSD/gsdcloud4nmmb/read_radar_ref.f90 b/src/GSD/gsdcloud4nmmb/read_radar_ref.f90 new file mode 100755 index 0000000000..1a7931ae67 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/read_radar_ref.f90 @@ -0,0 +1,107 @@ +SUBROUTINE read_radar_ref(mype,lunin,regional_time,istart,jstart, & + nlon,nlat,Nmsclvl,numref,ref_mosaic31) +! +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: read_NESDIS read in radar reflectivity +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-30 +! +! ABSTRACT: +! This subroutine read in radar reflectivity +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! lunin - unit in which data are read in +! regional_time - analysis time +! jstart - start lon of the whole array on each pe +! istart - start lat of the whole array on each pe +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! numref - number of observation +! +! output argument list: +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and +! vertically in mosaic grid (height) +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind + implicit none + + INTEGER(i_kind),intent(in) :: mype + INTEGER(i_kind),intent(in) :: nlon,nlat + integer(i_kind),intent(in) :: lunin + integer(i_kind),intent(in) :: regional_time(6) + integer(i_kind),intent(in) :: istart + integer(i_kind),intent(in) :: jstart + INTEGER(i_kind),intent(in) :: numref + + INTEGER(i_kind),intent(out):: Nmsclvl + real(r_kind), intent(out):: ref_mosaic31(nlon,nlat,31) +! +! local +! + real(r_kind),allocatable :: ref_in(:,:) + + character(10) :: obstype + integer(i_kind):: nreal,nchanl,ilat1s,ilon1s + character(20) :: isis + + INTEGER(i_kind) :: i,j, ii,jj,k2, k + INTEGER(i_kind) :: ib,jb + +! + ib=jstart ! begin i point of this domain + jb=istart ! begin j point of this domain + + read(lunin) obstype,isis,nreal,nchanl + + ilon1s=1 + ilat1s=2 + Nmsclvl = nreal - 2 + IF( Nmsclvl .ne. 21 .and. Nmsclvl .ne.31) then + write(6,*) ' read_radar_ref: ', & + 'vertical dimesion inconsistent when read in reflectivty mosaic' + write(6,*) 'read in:',Nmsclvl + write(6,*) 'need:', 21, 'or', 31 + call stop2(114) + ENDIF + allocate( ref_in(nreal,numref) ) + ref_mosaic31=-9999.0_r_kind + + read(lunin) ref_in + DO i=1,numref + ii=int(ref_in(ilon1s,i)+0.001_r_kind) - ib + 2 + jj=int(ref_in(ilat1s,i)+0.001_r_kind) - jb + 2 + if( ii < 1 .or. ii > nlon ) write(6,*) 'read_radar_ref: ', & + 'Error in read in ref ii:',mype,ii,jj,i,ib,jb + if( jj < 1 .or. jj > nlat ) write(6,*) 'read_radar_ref: ', & + 'Error in read in ref jj:',mype,ii,jj,i,ib,jb + DO k=1,Nmsclvl + ref_mosaic31(ii,jj,k)=ref_in(2+k,i) + ENDDO + ENDDO + deallocate(ref_in) + +END SUBROUTINE read_radar_ref diff --git a/src/GSD/gsdcloud4nmmb/smooth.f90 b/src/GSD/gsdcloud4nmmb/smooth.f90 new file mode 100755 index 0000000000..73f6208091 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/smooth.f90 @@ -0,0 +1,98 @@ + SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C$$$ SUBPROGRAM DOCUMENTATION BLOCK +!C . . . . +!C SUBPROGRAM: SMOOTH SMOOTH A METEOROLOGICAL FIELD +!C PRGMMR: STAN BENJAMIN ORG: FSL/PROFS DATE: 90-06-15 +!C +!C ABSTRACT: SHAPIRO SMOOTHER. +!C +!C PROGRAM HISTORY LOG: +!C 85-12-09 S. BENJAMIN ORIGINAL VERSION +!C +!C USAGE: CALL SMOOTH (FIELD,HOLD,IX,IY,SMTH) +!C INPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C METEOROLOGICAL FIELD +!C HOLD - REAL ARRAY HOLD(IX,2) +!C HOLDING THE VALUE FOR FIELD +!C IX - INTEGER X COORDINATES OF FIELD +!C IY - INTEGER Y COORDINATES OF FIELD +!C SMTH - REAL +!C +!C OUTPUT ARGUMENT LIST: +!C FIELD - REAL ARRAY FIELD(IX,IY) +!C SMOOTHED METEOROLOGICAL FIELD +!C +!C REMARKS: REFERENCE: SHAPIRO, 1970: "SMOOTHING, FILTERING, AND +!C BOUNDARY EFFECTS", REV. GEOPHYS. SP. PHYS., 359-387. +!C THIS FILTER IS OF THE TYPE +!C Z(I) = (1-S)Z(I) + S(Z(I+1)+Z(I-1))/2 +!C FOR A FILTER WHICH IS SUPPOSED TO DAMP 2DX WAVES COMPLETELY +!C BUT LEAVE 4DX AND LONGER WITH LITTLE DAMPING, +!C IT SHOULD BE RUN WITH 2 PASSES USING SMTH (OR S) OF 0.5 +!C AND -0.5. +!C +!C ATTRIBUTES: +!C$$$ +!C********************************************************************** +!C********************************************************************** + + + use kinds, only: r_kind,i_kind,r_single + implicit none +!C********************************************************************** + INTEGER(i_kind),INTENT(IN) :: IX,IY + real(r_kind),intent(inout) :: FIELD(IX,IY) + real(r_kind),intent(inout) :: HOLD (IX,2) + real(r_kind),intent(in) :: SMTH +!C********************************************************************** + real(r_kind) :: SMTH1,SMTH2,SMTH3,SMTH4,SMTH5 + INTEGER(i_kind) :: I1,I2,I,J,IT + real(r_kind) :: SUM1,SUM2 + + SMTH1 = 0.25 * SMTH * SMTH + SMTH2 = 0.5 * SMTH * (1.-SMTH) + SMTH3 = (1.-SMTH) * (1.-SMTH) + SMTH4 = (1.-SMTH) + SMTH5 = 0.5 * SMTH + I1 = 2 + I2 = 1 + DO J=2,IY-1 + IT = I1 + I1 = I2 + I2 = IT + DO I = 2,IX-1 + SUM1 = FIELD (I-1,J+1) + FIELD (I-1,J-1) & + + FIELD (I+1,J+1) + FIELD (I+1,J-1) + SUM2 = FIELD (I ,J+1) + FIELD (I+1,J ) & + + FIELD (I ,J-1) + FIELD (I-1,J ) + HOLD(I,I1) = SMTH1*SUM1 + SMTH2*SUM2 + SMTH3*FIELD(I,J) + ENDDO + IF (J /= 2) THEN + DO I=2,IX-1 + FIELD(I,J-1) = HOLD(I,I2) + ENDDO + ENDIF + ENDDO + + + DO I = 2,IX-1 + FIELD (I,IY-1) = HOLD(I,I1) + ENDDO + + DO I = 2,IX-1 + FIELD(I,1) = SMTH4* FIELD(I,1) & + + SMTH5 * (FIELD(I-1,1) + FIELD(I+1,1)) + FIELD(I,IY) = SMTH4* FIELD(I,IY) & + + SMTH5 * (FIELD(I-1,IY) + FIELD(I+1,IY)) + ENDDO + + DO J = 2,IY-1 + FIELD(1,J) = SMTH4* FIELD(1,J) & + + SMTH5 * (FIELD(1,J-1) + FIELD(1,J+1)) + FIELD(IX,J) = SMTH4* FIELD(IX,J) & + + SMTH5 * (FIELD(IX,J-1) + FIELD(IX,J+1)) + ENDDO + + RETURN + END diff --git a/src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 b/src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 new file mode 100755 index 0000000000..cdbadf3873 --- /dev/null +++ b/src/GSD/gsdcloud4nmmb/vinterp_radar_ref.f90 @@ -0,0 +1,143 @@ +SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31,h_bk,zh) +! +! +!$$$ subprogram documentation block +! . . . . +! subprogram: interp_radar_ref radar observation vertical interpolation +! +! PRGMMR: Ming Hu ORG: GSD/AMB DATE: 2006-11-17 +! +! ABSTRACT: +! This subroutine interpolate radar reflectivity vertically +! +! PROGRAM HISTORY LOG: +! 2009-01-20 Hu Add NCO document block +! +! +! input argument list: +! mype - processor ID +! nlon - no. of lons on subdomain (buffer points on ends) +! nlat - no. of lats on subdomain (buffer points on ends) +! nsig - no. of levels +! Nmsclvl - vertical level of radar observation ref_mosaic31 +! ref_mosaic31- radar reflectivity horizontally in analysis grid and vertically +! in mosaic grid (height) +! h_bk - 3D background height +! zh - terrain +! +! output argument list: +! ref_mos_3d - 3D radar reflectivity in analysis grid +! +! USAGE: +! INPUT FILES: +! +! OUTPUT FILES: +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE: Linux cluster (WJET) +! +!$$$ +! +!_____________________________________________________________________ +! + use kinds, only: r_kind,i_kind, r_single + implicit none + + INTEGER(i_kind), intent(in) :: mype + INTEGER(i_kind), intent(in) :: nlon + INTEGER(i_kind), intent(in) :: nlat + INTEGER(i_kind), intent(in) :: nsig + INTEGER(i_kind), intent(in) :: Nmsclvl + real(r_single), intent(in) :: h_bk(nlon,nlat,nsig) ! 3D height + real(r_single), intent(in) :: zh(nlon,nlat) ! terrain + real(r_kind), intent(in) :: ref_mosaic31(nlon,nlat,Nmsclvl) + real(r_kind), intent(out):: ref_mos_3d(nlon,nlat,nsig) ! reflectivity in grid +! +! local +! + real(r_kind) :: msclvl21(21),msclvlAll(31) + INTEGER(i_kind) :: mscX,mscY + DATA msclvl21/1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 6, 7, & + 8, 9, 10, 11, 12, 13, 14, 15, 16, 17/ + DATA msclvlAll/0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, & + 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, & + 9, 10, 11, 12, 13, 14, 15, 16, 18/ +! + REAL(r_kind) :: heightGSI,upref,downref,wght + INTEGER(i_kind) :: ilvl,numref + + real(r_kind) :: ref_mosaic + INTEGER(i_kind) :: i,j, k2, k + +! + if(Nmsclvl < -888 ) then + write(6,*) 'interp_radar_ref: No radar reflectivity data in this subdomain !' + return + endif +! + ref_mos_3d=-99999.0_r_kind + numref=0 + if (Nmsclvl == 31 ) then + DO k=1,Nmsclvl + msclvlAll(k)=msclvlAll(k)*1000.0_r_kind + ENDDO + elseif( Nmsclvl == 21 ) then + msclvlAll=0 + DO k=1,Nmsclvl + msclvlAll(k)=msclvl21(k)*1000.0_r_kind + ENDDO + else + write(6,*) 'interp_radar_ref: Wrong vertical radar mosaic levels' + write(6,*) ' the level read in is:', msclvlAll + call stop2(114) + endif + + DO k2=1,nsig + DO j=2,nlat-1 + DO i=2,nlon-1 + heightGSI=h_bk(i,j,k2)+zh(i,j) + if(heightGSI >= msclvlAll(1) .and. heightGSI < msclvlAll(Nmsclvl) ) then + do k=1,Nmsclvl-1 + if( heightGSI >=msclvlAll(k) .and. heightGSI < msclvlAll(k+1) ) ilvl=k + enddo + upref=ref_mosaic31(i,j,ilvl+1) + downref=ref_mosaic31(i,j,ilvl) + if(abs(upref) <90.0_r_kind .and. abs(downref) <90.0_r_kind ) then + wght=(heightGSI-msclvlAll(ilvl))/(msclvlAll(ilvl+1)-msclvlAll(ilvl)) + ref_mosaic=(1-wght)*downref + wght*upref + numref=numref+1 + elseif( abs(upref+99.0_r_kind) < 0.1_r_kind .or. & + abs(downref+99.0_r_kind) <0.1_r_kind ) then + ref_mosaic=-99.0_r_kind + else + ref_mosaic=-99999.0_r_kind + endif + ref_mos_3d(i,j,k2)=max(ref_mos_3d(i,j,k2),ref_mosaic) + else + ref_mos_3d(i,j,k2)=-99999.0_r_kind + endif + ENDDO + ENDDO + ENDDO + +! + DO k2=1,nsig + DO i=2,nlon-1 + ref_mos_3d(i,1,k2)=ref_mos_3d(i,2,k2) + ref_mos_3d(i,nlat,k2)=ref_mos_3d(i,nlat-1,k2) + ENDDO + DO j=2,nlat-1 + ref_mos_3d(1,j,k2)=ref_mos_3d(2,j,k2) + ref_mos_3d(nlon,j,k2)=ref_mos_3d(nlon-1,j,k2) + ENDDO + ref_mos_3d(nlon,nlat,k2)=ref_mos_3d(nlon-1,nlat-1,k2) + ref_mos_3d(nlon,1,k2)=ref_mos_3d(nlon-1,2,k2) + ref_mos_3d(1,nlat,k2)=ref_mos_3d(2,nlat-1,k2) + ref_mos_3d(1,j,k2)=ref_mos_3d(2,2,k2) + ENDDO + + +END SUBROUTINE vinterp_radar_ref diff --git a/src/bufr/.gitrepo b/src/bufr/.gitrepo new file mode 100644 index 0000000000..5613b78622 --- /dev/null +++ b/src/bufr/.gitrepo @@ -0,0 +1,11 @@ +; DO NOT EDIT (unless you know what you are doing) +; +; This subdirectory is a git "subrepo", and this file is maintained by the +; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme +; +[subrepo] + remote = none + branch = master + commit = 3048cc07ded08e77a5d60d1ae0ba8eaa39c873d1 + parent = c8258179932d604e01f94d641f526f314d2ad27d + cmdver = 0.3.1 diff --git a/src/bufr/CMakeLists.txt b/src/bufr/CMakeLists.txt new file mode 100644 index 0000000000..db24ca0793 --- /dev/null +++ b/src/bufr/CMakeLists.txt @@ -0,0 +1,22 @@ +cmake_minimum_required(VERSION 2.6) +#message("in bufr") +if(BUILD_BUFR) + file(GLOB BUFR_F77_SRC ${BUFR_DIR}/*.f ${BUFR_DIR}/*.F) + file(GLOB BUFR_C_SRC ${BUFR_DIR}/*.c) + file(GLOB BUFR_PRM ${BUFR_DIR}/*.PRM) + + ADD_CUSTOM_COMMAND( OUTPUT "${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm" + PRE_BUILD + COMMAND cpp -P -D_REAL8_ -DWRF -DLINUX -DPGI -traditional-cpp ${BUFR_DIR}/bufrlib0.PRM -o ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm + DEPENDS ${BUFR_DIR}/bufrlib0.PRM + ) + add_custom_target(bufrlib_prm DEPENDS ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm ) + if( BUFR_F77_SRC ) + set_source_files_properties( ${BUFR_F77_SRC} COMPILE_FLAGS ${BUFR_Fortran_FLAGS}) + endif() + set_source_files_properties( ${BUFR_C_SRC} COMPILE_FLAGS ${BUFR_C_FLAGS} ) + + add_library( ${bufr} STATIC ${BUFR_C_SRC} ${BUFR_F77_SRC} ) + add_dependencies(${bufr} bufrlib_prm) + set_target_properties( ${bufr} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) +endif() diff --git a/src/bufr/README.libbufr b/src/bufr/README.libbufr new file mode 100755 index 0000000000..a5b7926f55 --- /dev/null +++ b/src/bufr/README.libbufr @@ -0,0 +1,1617 @@ + + Original Implementation of BUFR Archive Library - 12Z 6 January 1994 + +Implemented on Cray-YMP as a single monolithic source bufr.f. Only the AVN +and FNL PREPBUFR processing and q.c. codes used the BUFR Archive Library +initially. These were: PREPDATA, SYNDATA, CQCBUFR, OIQCBUFR, and SSIANL. +These had actually been implemented with a non-production version of the +library in Jack Woollen's directory on 12Z 21 September 1993. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 10 January 1995 + +The BUFR Archive Library was modified slightly to allow for changes in the AVN +and FNL PREPBUFR and Q.C. Processing codes (PREPDATA, CQCBUFR, OIQCBUFR, +SSIANL). + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 28 June 1995 + +The BUFR Archive Library was modified to increase the size of internal arrays +in order to handle bigger files. Coding was also added in order to process +ERS scatterometer data which is input from compressed BUFR messages (new +subroutine READERME). + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 09 September 1996 + +The BUFR Archive Library was separated into 121 BUFR interface routines, +which include upgrades and devices for operating the BUFR database. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 21Z 09 October 1996 + +The BUFR Archive Library was modified to include 9 additional routines to +process ERS scatterometer data (IREADERS, RDTRER, READERS, UNCMPS), perform +fault tolerant reading (IREADFT, READFT), and support report part merging +(INVMRG, MRGINV, NWORDS). + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 25 November 1996 + +Several routines in the BUFR Archive Library are being modified to provide +more machine independence. The data merging routine is being modified +for radiosonde call signs, a return code is being added to UFBINT when +mnemonics are not found, and READMG is being modified to exit gracefully when +the file is positioned after an end of file + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 11 December 1996 + +The following subroutines were modified in the BUFR Archive Library: + + STATUS - Fixed a long standing bug which occurs in unusual situations. Very + low impact. + + UFBINT - Removed a hard abort for users who try to write non-existing + mnemonics. + + UFBRW - Removed a hard abort for users who try to write non-existing + mnemonics. + + ADDATE - New date arithmetic subroutine added to the library. + + DUMPBF - New dump date reader added to the library. + + MSGINI - Modified to allow inclusion of minutes in writing the message date + into a BUFR message. + + READTJ - Specific database ingest message reader added to the library which + can attach different BUFR tables if the message type is not + recognized in the current ones. Works with a user subroutine + called OPENBT which specifies the location(s) of different tables. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 21Z 17 December 1996 + +The BUFR Archive Library was modified to make the following changes: + + DUMPBF - Corrected error in dump date reader. + + RDUSDX - Fixed for some MVS compiler's treatment of internal reads. + + RDBFDX - Fixed for some MVS compiler's treatment of internal reads. + + UFBINT - Modified to always initialize "USR" array to missing (10E10) when + BUFR file is being read. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 29 July 1997 + +Three BUFR Archive Library subroutines were modified to update the current +BUFR version information written into Section 0 of each message: DXMINI, +MSGINI and MSGWRT. Version 3 replaces version 2. + +Three additional subroutines were modified to enable them to process GOES +soundings from NESDIS: IRDERM, RDTRER and READERME. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 03 September 1997 + +Changes are being made to the BUFR Archive Library to recompile all routines +without the -ez compiler option. The removal of this debugging option should +speed up the execution of all modules which are linked with BUFR Archive +Library routines. + +In addition, a new subroutine, STANDARD, is being added to the library. This +subroutine "standardizes" NCEP BUFR messages for transmission. It was +requested to process hurricane location data. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 02 April 1998 + +BUFR Archive Library subroutine STRCLN, which initializes the mnemonic string +cache in the BUFR interface, is being modified to enlarge the cache from 50 +elements to 1000, maximum. + +BUFR Archive Library subroutine STRING manages the mnemonic string cache in +the BUFR interface. The mnemonic string cache is a performance enhancing +device which saves time when the same mnemonic strings are encountered in a +user program, over and over again (the typical scenario). It is being +modified to operate a bigger cache, and some optimization of the cache search +algorithm is being made in support of a bigger cache. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 20Z 08 July 1998 + +The new version of the BUFR Archive Library is Y2K compliant, with additional +changes to support expanded machine independence of the code, and to refine, +correct, or improve some of the routines within. Although nearly every one of +library routines has some change made (mainly because of the introduction of a +more general error exit subroutine), the changes largely fall into the first +two categories. Three new routines were also added to the BUFR Archive Library +for micellaneous puposes. + +1) Y2K Compliance + +Y2K compliance in the BUFR Archive Library is downwardly compatible. That is, +the new library will read non-Y2K BUFR files as the old one does. However, all +two digit years read are represented internally as four digit years, and any +files written with the new library will be in Y2K format. A functional +conversion of two digit year inputs assumes the years 21-99 are in the +twentieth century, while years numbered 00-20 are in the twenty-first. A Y2K +BUFR file is identified by a non-zero value in the 18th byte of the message +section one, the century byte. At this point users of the library have access +to the full four digit year values read by including a signal in their programs +via a new entry point called DATELEN. The plan is to have the default set to +return two digits of the year during a transition period. This allows +implementation of the new BUFR Archive Library into a non-Y2K compliant +environment. The susbsequent list of subroutines have been changed for Y2K +compliance: BFRINI, DATEBF, DUMPBF, MSGINI, OPENMB, OPENMG, RDMEMM, READERME, +READFT, READMG, READTJ. + +2) Machine Independence + +Since the last implementation of the BUFR Archive Library, several areas in the +code have been identified which are problematic in some way with regards to +compiling the library on some computers. Upgrades have been made to the +following list of subroutines to address these: CONWIN, INVCON, PARUSR, +RDTRER, READERM, READERME, TRYBUMP, UFBEVN, UFBGET, UFBINT, UFBRP, UFBRW, +UFBTAB and UNCMPS. + +3) Refinements, Corrections, and Improvements + +This is a list of BUFR Archive Library routines which were either in error, +or in need of some improvement: IRDERM, NEMTBB, NENUCK, RDBFDX, RDUSDX, STRCLN, +STRING, TABENT, UNCMPS and WRTREE. +4) New Error Exit Subroutine + +Many of the BUFR Archive Library routines perform internal testing during +operation in order to prevent certain situation from generating mysterious +aborts, or, even worse, giving the wrong answers. The original library utilized +the Cray library routine ABORT to terminate a program when such a situation was +found. The new library uses a new inernal subroutine, BORT, to accomplish +this. The list of routines changed for this purpose is as follows: ADN30, +CHEKSTAB, CLOSMG, COPYBF, COPYMG, COPYSB, CPYMEM, CPYUPD, DATEBF, DRSTPL, +DUMPBF, DXMINI, ELEMDX, GETWIN, IDN30, IFBGET, INCTAB, INVMRG, IPKM, IUPM, +JSTIFY, LSTJPB, LSTRPC, LSTRPS, MAKESTAB, MSGINI, MSGUPD, MSGWRT, MVB, NEMTBA, +NEMTBB, NEMTBD, NENUCK, NEWWIN, NMSUB, NVNWIN, NXTWIN, OPENMB, OPENMG, OPENBF, +PAD, PARSEQ, PARUSR, PARUTG, PKC, POSAPN, POSAPX, RCSTPL, RDBFDX, RDMEMM, +RDMEMS, RDUSDX, READDX, READERM, READERME, READERS, READFT, READMG, READNS, +READSB, READTJ, SEQSDX, STANDARD, STATUS, STRING, TABENT, TABSUB, UFBCNT, +UFBCPY, UFBCUP, UFBDMP, UFBEVN, UFBGET, UFBINT, UFBMEM, UFBMMS, UFBMNS, +UFBOVR, UFBQCD, UFBQCP, UFBREP, UFBRMS, UFBTAM, UPTDD, USRTPL, VAL$, WRDLEN, +WRITDX, WRITSA, WRITSB, WTSTAT + +5) New Code Added + +I4DY the two/four digit year conversion function +LJUST a character left justify function +OPENBT A dummy entry point which is relevant to users of the READTJ + subroutine + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 31 August 1998 + +BUFR Archive Library subroutine DATEBF, which returns the center date-time for +a BUFR data dump file, is being modified to correct an error which lead to the +year being returned in the second argument as 2-digit year when a 4-digit year +was requested via a prior call to subroutine DATELEN. The center date +returned in the sixth argument, in the form YYYYMMDDHH, was correct in the +previous version of this subroutine. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 27 October 1998 + +The BUFR Archive Library is being modified to correct problems caused by +in-lining code with fpp directives. The following subroutines are being +changed: DATEBF, MVB, RCSTPL, RDMEMS, RDTREE, RDTRER, UFBGET, UFBRW, UFBTAB, +UFBTAM and UPBB. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 24 November 1998 + +Fuction I4DY and subroutine MSGWRT were changed as a result of final Y2K +testing of the decoder/ingest system. + +I4DY was changed to conform to the NCEP 2-digit year time-window of 1921-2020. + +MSGWRT was changed to zero out the padding bytes written at the end of +Section 4. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 14 December 1998 + +Subroutine MSGUPD was updated to bybass the processing of reports that are +longer than the length of a BUFR message. Prior to this change, the BUFR +Archive Library would issue an abort in the event of this rare, but possible +occurrence which occurred at 12Z on 4 December in the RGL suite. + +In addition, function I4DY was modified to use 20 as the 2-digit year for +windowing to a 4-digit year (00-20 ==> add 2000; 21-99 ==> add 1900). This +windowing technique was inadvertently changed to 10 in the previous +implementation of the BUFR Archive Library. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 18 November 1999 + +The BUFR Archive Library on the IBM-SP was implemented into productuction when +this machine became operational (replacing the Cray-YMP/J-90's). + +The following changes were actually implemented on the IBM-SP on 18Z 13 July +1999 prior to it's operational status): + + +1) A number of routines in the BUFR Archive Library have been modified to +increase the number of BUFR files which can be opened at one time from 10 to +32. This is necessary in order to process multiple BUFR files under the MPI. +The following routines were modified: BFRINI, CHEKSTAB, CLOSMG, CONWIN, COPYMG, +COPYSB, CPBFDX, CPYMEM, CPYUPD, DXINIT, ELEMDX, GETWIN, IFBGET, INVCON, INVMRG, +INVTAG, INVWIN, LSTJPD, LSTRPC, LSTRPS, MAKESTAB, MSGINI, MSGUPD, NEMTAB, +NEMTBA, NEMTBD, NENUCK, NEWWIN, NMSUB, NUMTAB, NVNWIN, NWORDS, NXTWIN, OPENBF, +OPENMB, OPENMG, PARUTG, PKTDD, RCSTPL, RDBFDX, RDMEMM, RDMEMS, RDTREE, RDTRER, +RDUSDX, READERM, READERME, READERS, READFT, READMG, READNS, READSB, READTJ, +STATUS, STRING, TRYBUMP, UFBCNT, UFBCPY, UFBCUP, UFBDMP, UFBEVN, UFBGET, +UFBINT, UFBOVR, UFBREP, UFBRP, UFBRW, UFBTAB, UFBTAM, UNCMPS, UPTDD, USRTPL, +WRITDX, WRTREE, WTSTAT. + +2) Subroutines READFT, READMG, and READTJ have been modified with semantic +adjustments to ameliorate compiler complaints from LINUX boxes. + +3) Added the new subroutine READIBM in order to process "foreign" (non-NCEP) +BUFR files which may not be padded. Unlike the subroutine READERM, which +performs a similar fuction, READIBM works properly on all platforms and should +replace calls to READERM in application programs. (READERM does not work +properly on the NCEP IBM-SP machine.) + +4) Added the new subroutine NEMTBAX. It is like subroutine NEMTBA except if +the requested mnemonic is not found, it returns rather than calls BORT. This +is necessary to support the logic in the new BUFR Archive Library subroutine +READIBM (see 3). + +5) Added the new subroutine READMM. It is like subroutine RDMEMM except it +advances the value of the message (record) number by one prior to returning +to the calling program. This adds another option for application programs +which read BUFR files in random access mode (e.g., PREPOBS_OIQCBUFR). + +6) Function IREADMG has been modified to contain two new function entries +called IREADMM and IREADIBM. The IREADIBM function calls the new library +subroutine READIBM (see 3) and the IREADMM function calls the new library +subroutine READMM (see 5). + +7) RDTRER, READERM, READERME and UNCMPS have been modified to expand the +maximum number of possible descriptors in a subset from 1000 to 3000. + +8) The maximum number of bytes required to store all messages internally was +increased from 4 Mbytes to 8 Mbytes in the following subroutines: RDMEMM, +UFBMEM, UFBMMS, UFBMNS and UFBRMS. + +9) The function formerly called VAL$ has been renamed to VALX to remove the +possibility of the "$" symbol causing problems on other platforms. In turn +subroutine NEMTBB has been modified to call function VALX rather than VAL$. + +10) New subroutines UFBSTP and UFBSP added (UFBSP is called by UFBSTP). + N O T S U R E W H A T T H E S E D O ! ! ! + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 19 September 2000 + +A number of routines in the BUFR Archive Library have been modified. These +changes include: + +1) Consolidated logic that had been replicated in message decoding subroutines +READMG, READFT, READTJ, READERM, READERME, RDMEMM and READIBM into a single +new subroutine CKTABA (called by these subroutines). On top of this CKTABA +now recognizes a variety of Section 3 formats, including compression +indicators and "standard" BUFR. Thus, compressed and standard BUFR messages +can now be read in via these message decoding subroutines. + +2) The subset decoding subroutine READSB now calls a new subroutine RDCMPS +which allows it to read subsets from compressed BUFR messages. + +3) Subroutine RDTRER has been removed. It had been called by READERS to decode +ERS scatterometer data from compressed BUFR messages. The change in READSB +(see 2) allows READERS to be changed from a subroutine to an entry point at the +top of READSB since it is now essentially an alias to READSB. + +4) Subroutine UNCMPS has been removed. It had been called by READERM, READERME +and READIBM to uncompress BUFR messages in foreign (i.e., standard ) BUFR files +(e.g., ERS scatterometer data). This is a result of change 1 above. + +5) Added capability to encode and decode data using the operator descriptors +(BUFR Table C) for changing width and changing scale. Subroutines modified +were: NEMTAB, NEMTBD, NUMTAB and TABSUB + +6) Enlarged arrays to allow processing messages up to 20000 bytes. Routines +modified were: BFRINI, CLOSMG, COPYBF, COPYMG, COPYSB, CPYMEM, CPYUPD, IRDERM, +MESGBF, MINIMG, MSGINI, MSGUPD, MSGWRT, POSAPN, POSAPX, RCSTPL, RDBFDX, RDMEMM, +RDMEMS, RDTREE, READERM, READERME, READFT, READIBM, READMG, READMM, READSB, +READTJ, UFBGET, UFBMEM, UFBTAB, UFBTAM, WRITDX, WRITSA and WRTREE. + +7) Added subroutine UFBSEQ, like UFBINT except processes specific sequences +instead of specific elements. + +8) Added function NMBYT, returns the number of bytes in a message opened for +input. + + +The BUFR Archive Library is now compiled using both optimization level 3 (-O3) +and optimization level 4 (-O4). The previous BUFR Archive Library had used +only -O4. The -O3 compilation here generates the same archive library names as +before. Thus, any code that is recompiled from an unchanged makefile will now +link in the appropriate -O3 library, rather than the -O4 library as before. +The new -O4 libraries all have the string "_O4" appended to the end of the +filename. + +Any program that must link to the -O4 BUFR Archive Library when compiled will +have to modify its makefile. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 19Z 15 August 2001 + + +Parameter MAXMEM (the maximum number of bytes required to store all messages +internally) was increased from 8 MBYTES TO 16 MBYTES in the following +subroutines: CPYMEM, RDMEMM, RDMEMS, READMM, UFBMEM, UFBMMS, UFBMNS, UFBRMS and +UFBTAM. + +Subroutine UFBTAM modified to not abort when there are too many subsets coming +in (i.e., .gt. array limit passed in), but rather to just process the limiting +number of reports and print a diagnostic. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 14 May 2002 + +A number of routines in the BUFR Archive Library have been modified. These +changes include: + +1) Entries IREADMM, IREADNS, IREADSB, IREADERS, IREADIBM, IREADFT and +ICOPYSB changed to functions. Entries MRGINV, MINIMG, DATELEN, NENUBD, +NENUAA, JSTNUM, JSTCHR and READERS changed to subroutines (note that READERS +now simply calls READSB since it was an entry point at the top of READSB and +was thus already an alias to it). Converted all entry points to subroutines or +functions in order to increase portability to other platforms (e.g., the NESDIS +CEMSCS machine). + +2) Entries DXMINA, DXMINB, DXMIND and SUBUPD removed because they are +obsolete. + +3) Added XMSGINI for capacity to expand section three. XMSGINI has the +capacity to write a fully expanded section three descriptor set into BUFR +messages. Created specifically for NESDIS so they can send files out without +local sequence descriptors. This "capacity" is not fully functional, it is +currently activated by changing WRCMPS.to call it rather than CMSGINI, which +writes sections 0,1,2,3 for compressed messages in the usual way. XMSGINI +is included because it is useful for particular situations as is (aka +NESDIS), and at some point could be integrated as a more direct form of +STANDARDizing messages for export or whatever. + +4) Included in-line compression function (subr. CMSGINI, WRITCP, WRCMPS +added). + +5) Improved RDCMPS and UFBSEQ for generality. Previously RDCMPS and UFBSEQ +would not recognise compressed delayed replication as a legitimate data +structure. + +6) Removed old CRAY compiler directives in: COPYSB, CPYUPD, DRSTPL, GETWIN, +INVMRG, MVB, NEWWIN, NXTWIN, RCSTPL, READSB, UFBDMP, UFBGET, UFBINT, UFBOVR, +UFBRW, UFBTAB, UFBTAM and USRTPL. + +7) Added new subroutine UFDUMP which is like UFBDMP, but prints subset element +contents in more detail, omitting the pointers, counters, and other more +esoteric information describing the internal subset structures. Each +subroutine, UFBDMP and UFDUMP, is useful for different diagnostic purposes, +but in general UFDUMP is more useful for just looking at the data elements. + +8) Corrected error in READSB relating to certain foreign filetypes. + +9) Added new subroutine DRFINI which initializes delayed replication factors, +and allocates the space in the full word buffer for their contents +explicitly. This is done implictly by UFBINT in a more limited way. DRFINI +enables, for instance, the subsequent use of UFBSEQ to write data directly +into delayed replicated sequences. + +10) Added new subroutine MAXOUT which allows users to control the record +length of output BUFR messages created. + +11) Added new subroutine NUMTBD which is used by XMSGINI, in expanding the +section 3 descriptor list. + +12) Added new subroutine CAPIT which capitalizes a string of characters. This +enables the use of mixed case in the unit section of the ASCII BUFR tables. +An example; a program which generates an ASCII BUFR table from the "Master +Table B", might end up copying some units fields in mixed or lower case. If +the units are 'Code table' or 'Flag table' or certain other unit +designations, the table will be parsed incorrectly, and the data read or +written incorrectly as a result. This makes sure all unit designations are +seen by the parser in upper case to avoid these types of problems. + +13) Removed subroutine JSTIFY because it was a dummy subroutine with two +entry points for left justifying two different types of character strings. +Part of conversion of entry points to separate subroutines or functions. See +number 1 above. + +14) Removed subroutine NENUCK because it was a dummy subroutine with two +entry points for checking the BUFR mnemonic table. Part of conversion of +entry points to separate subroutines or functions. See number 1 above. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 27 May 2003 + (Actually implemented into productuction 12Z 19 May 2003 when the IBM + Frost and Snow machines became operational at NCEP) + +The following changes have been made in the BUFR Archive Library: + +1) Subroutine CLOSMG - to correct a problem introduced in the previous +(May 2002) implementation which prevented the dump center time and initiation +time messages from being written out (affected program BUFR_DUMPMD, if it were +recompiled, in the data dumping process) + +2) Subroutine UFBREP - to work properly for descriptors tied to a pivot +descriptor in delayed replicated sequences (involved disabling the parsing +switch which controlled checking for presence in the same replication group - +UFBREP does not need this check, and it interferes with what UFBREP can do +otherwise) + +3) Subroutine UFBSEQ - to fix cases where delayed replication is at end of +subset, or when a requested sequence is missing; also corrected the logic +array of exit conditions for the subroutine, previously, in some cases, proper +exits were missed, generating bogus error messages, because of several +miscellaneous bugs which are now removed + +4) Subroutine UPB - to make certain zero is returned for zero bits input + +5) The following subroutines are modified to replace calls to Fortran +Insrinsic Function ICHAR with calls to NCEP W3LIB c-function MOVA2I: DATEBF +and DUMPBF. This change increases portability of the BUFR Archive Library +because MOVA2I copies a bit string from a Character*1 variable to an integer +variable. It is intended to replace the Fortran Intrinsic Function ICHAR, +which only supports 0 <= ICHAR(A) <= 127 on the IBM SP. If "A" is greater +than 127 in the collating sequence, ICHAR(A) does not return the expected bit +value. This function can be used for all values of ICHAR(A) between 0 and +255. This change increases portability of the BUFR Archive Library and is, in +fact, necessary on the NCEP IBM Frost and Snow machines. + + +The BUFR Archive Library on Frost and Snow is compiled using optimization +level 4 (-O4) for Fortran routines and optimization level 3 (-O3) for c +routines. The previous BUFR Archive Library on the IBM-SP's had used -O3 for +the default filenames and -O4 for a second set of filenames with the string +"_O4" appended to the end. + +The following libraries are generated on the NCEP IBM Frost and Snow machines: + +libbufr_4.a -- 4-byte reals, 4-byte integers, 64-bit executable compilation +libbufr_8.a -- 8-byte reals, 8-byte integers, 64-bit executable compilation +libbufr_d.a -- 8-byte reals, 4-byte integers, 64-bit executable compilation + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 12Z 04 November 2003 + +This is the first "unified" BUFR Archive Library including components from the +regular NCEP production machine version (whose implementation history is +documented to this point), the decoder version (previously on a workstation but +now on the IBM Frost and Snow machines), and a checkout NCEP/EMC grid-to-obs +verification version. This version is portable to all platforms (as necessary +for WRF), contains docblocks for each routine with a complete program history +log, and outputs more complete diagnostic information when routines terminate +abnormally, unusual things happen or for informational purposes. + +The following libraries are now generated on the NCEP IBM Frost and Snow +machines: + +libbufr_4_64.a -- 4-byte reals, 4-byte integers, 64-bit executable compilation +libbufr_8_64.a -- 8-byte reals, 8-byte integers, 64-bit executable compilation +libbufr_d_64.a -- 8-byte reals, 4-byte integers, 64-bit executable compilation +libbufr_4_32.a -- 4-byte reals, 4-byte integers, 32-bit executable compilation + +The first three are compiled exactly the same as the three libraries noted in +the previous 05-27-2003 implementation (they are just renamed). The fourth +library is compiled identically to the previous decoder-specific version on +Frost and Snow (libdecod_bufr_32.a). It is compiled with optimization level 3 +(-O3) for both Fortran and c routines and will be linked into the production +decoder programs in place of libdecod_bufr_32.a. + + +The following routines have been added to the BUFR archive library: + +1) Subroutine BORT2 which prints (to STDOUT) two given error strings and +then calls BORT_EXIT (see 7 below) to abort the application program calling +the BUFR Archive Library software. It is similar to existing subroutine BORT, +except BORT prints only one error string. + +2) Function IUPBS1 which, given a BUFR message contained within array MBAY, +unpacks and returns the binary integer contained within byte NBYT of +Section 1 of the BUFR message. This was present in the original decoder- +specific version of the library. + +3) Subroutine OVRBS1 which, given a BUFR message contained within array MBAY, +packs and stores the value of a binary integer into byte NBYT of Section 1 +of the BUFR message, overwriting the value previously stored there. + +4) Subroutine UPDS3 which, given a BUFR message contained within array MBAY, +unpacks and returns the descriptors contained within Section 3 of the BUFR +message. This was present in the original decoder-specific version of the +library. + +5) Function MOVA2I (see "Changes to BUFR Archive Library, 12Z 27 May 2003" +number 5 for more info). This Fortran version replaces the W3LIB c-version +previously called by DATEBF and DUMPBF. It is now called by new subroutines +MESGBC (see 6) and REWNBF (see 11) as well. This change removes any +dependency upon the W3LIB, since no other BUFR Archive Library routines call +any W3LIB routines. It was converted to Fortran 77 because the c-version does +not work properly when compiled with 32-bit executable compilation and linked +into a Fortran source copiled with 8-byte real and integer word length. + +6) Subroutine MESGBC reads past any BUFR table (dictionary) or dummy +(center or dump time in dump files) messages in a BUFR file (if there are +any) and returns the message type for the first report data message found. +It also determines whether or not this first report data message is +compressed BUFR. This subroutine is identical to MESGBF except MESGBF +only reads past dictionary messages and MESGBF does not return any +information about compression. + +7) C subroutine BORT_EXIT terminates the application program calling the +BUFR software and returns an implementation-defined non-zero status code to +the executing shell script. (See 1 and 26.) + +8) Subroutine RDMGSB opens a BUFR file in logical unit LUNIT for input +operations, then reads a particular subset into internal subset arrays from a +particular BUFR message in a message buffer. This is based on the subset +number in the message and the message number in the BUFR file. This was +present in the original verification-specific version of the library. + +9) Subroutine SUBUPD packs up the current subset within memory and then tries +to add it to the BUFR message that is currently open within memory for +LUNIT. If the subset will not fit into the currently open message, then that +message is flushed to LUNIT and a new one is created in order to hold the +current subset. If the subset is larger than an empty message, the subset is +discarded and a diagnostic is printed. This subroutine is identical to +existing BUFR Archive Library subroutine MSGUPD except SUBUPD does NOT pad the +packed subset. This was present in the original verification-specific version +of the library. + +10) Subroutine UFBINX either opens a BUFR file for input operations (if it is +not already opened as such), or saves its position and rewinds it to the first +data message (if BUFR file already opened), then (via a call to BUFR Archive +Library subroutine UFBINT) reads specified values from internal subset arrays +associated with a particular subset from a particular BUFR message in a message +buffer. The particular subset and BUFR message are based based on the subset +number in the message and the message number in the BUFR file. Finally, this +subroutine either closes the BUFR file (if is was opened here) or restores it +to its previous read/write status and position (if is was not opened here). +This was present in the original verification-specific version of the library. + +11) Subroutine REWNBF which will either: 1) store the current parameters +associated with a BUFR file (read/write pointers, etc.), set the file status +to read, then rewind the BUFR file and position it such that the next BUFR +message read will be the first message in the file containing actual subsets +with data; or 2) restore the BUFR file to the parameters it had prior to 1) +using the information saved in 1). This allows information to be extracted +from a particular subset in a BUFR file which is in the midst of being read +from or written to by an application program. This was present in the original +verification-specific version of the library. + +12) Subroutine UFBIN3 reads specified values from the current BUFR data subset +where the data values correspond to mnemonics which are part of a multiple- +replication "level" sequence within another multiple-replication "event stack" +sequence. This subroutine is designed to read event information from +"PREPFITS" type BUFR files (currently the only application which reads +PREPFITS files is the verification program GRIDTOBS, where UFBIN3 was +previously an in-line subroutine). The existing analogous subroutine UFBEVN +should be used to read information from "PREPBUFR" type BUFR files. This was +present in the original verification-specific version of the library. + +13) Function NEVN accumulates all data events for a particular data value and +level and returns them to the calling program. The value of the function +itself is the total number of events found. {This function should only be +called by UFBIN3 (see 12), which, itself, is called only by verification +application program GRIDTOBS, where it was previously an in-line subroutine. +In general, NEVN does not work properly in other application programs at this +time.} This was present in the original verification-specific version of the +library. + +14) Subroutine READLC returns a character data element associated with a +particular subset mnemonic from the internal message buffer. It is designed +to be used to return character elements greater than the usual length of 8 +bytes. It currently will not work for compressed BUFR mesaages. + +15) Subroutine WRITLC packs a character data element associated with a +particular subset mnemonic from the internal message buffer. It is designed +to be used to store character elements greater than the usual length of 8 +bytes. + +16) Subroutine WRITST generates a standardized version of the current BUFR +message in internal memory and writes it to the output file (not sure if +it works properly). + +17) Subroutine COPYST generates a standardized version of the current BUFR +message read using READMG and writes it intact as a record to the output +file. + +18) Subroutine COMPRES compresses subsets in BUFR messages previously read +using BUFR Archive Library subroutine READMG or equivalent. It then +generates a new bufr message consisting of the compressed subsets. Note +that subsets in the output compressed message may have been read from +different (adjacent) input messages. Currently the only application program +which calls this subroutine is BUFR_COMPRESS, where COMPRES was previously +an in-line subroutine). + +19) Subroutine READ2C reads a subset into compression maxtrix arrays in +preparation for generating compressed BUFR messages. This had been an in- +line subroutine in the application program BUFR_COMPRESS and is currently +called only by BUFR Archive Library subroutine COMPRES (see 18). + + + +The following routines in the BUFR archive library have been modified: + +20) Subroutine UPBB modified to make certain zero is returned for zero bits +input and to make logic consistent with logic in UPB. (See also 30 for UPBB.) + +21) Subroutine UFBTAB modified to not abort when there are too many subsets +coming in (i.e., .gt. array limit passed in), but rather to just process the +limiting number of reports and print a diagnostic. It is also modified to +call subroutine REWNBF when the BUFR file is already opened (this is taken +from the verification version of UFBTAB and allows specific subset information +to be read from a file in the midst of being read from or written to), before +OPENBF was always called and this would have led to an abort of the +application program. (See also 29 for UFBTAB.) + +22) Subroutine CKTABA modified to not abort when the Section 1 message subtype +does not agree with the Section 1 message subtype in the dictionary IF the +message type mnemonic is not of the form "NCtttsss", where ttt is the BUFR type +and sss is the BUFR subtype. This allows program PREPOBS_PREPDATA to specify +different message subtypes for the same message type. (See also 27 and 43.) + +23) Subroutine OPENBF modified to accept 'NUL' as the second (I/O) argument. +IO='NUL' prevents the BUFR Archive Library software from actually trying to +access or write to the BUFR file (designed only for use with library +subroutine WRITSA). This was present in the original decoder-specific version +of the library. + +24) Subroutine CLOSBF modified to not close the BUFR file if it was opened as +'NUL' by OPENBF (see 23). This was present in the original decoder-specific +version of the library. + +25) Subroutine MSGWRT modified to not write to the BUFR file if it was opened +as 'NUL' by OPENBF (see 23). This was present in the original decoder- +specific version of the library. + +26) Subroutine BORT modified to call new BUFR Archive Library subroutine +BORT_EXIT (see 7 above) rather than c function EXIT with argument 49 {"CALL +EXIT(49)"}. Since EXIT is an intrinsic c function, it expects arguments to be +passed by value rather than by reference as in done in Fortran. This has +caused an unpredictable status code to be passed back to the executing shell +script, in some cases even ZERO!! This change will ensure an non-zero status +is always returned. + +27) Suboutines CKTABA, DATEBF, DUMPBF and function I4DY modified such that +date calculations no longer use floating point arithmetic. This can lead to +round off error and an improper resulting date on some machines (e.g., NCEP +IBM Frost/Snow). This change increases portability of the BUFR Archive +Library. (See also 22 and 43 for CKTABA.) + +28) Parameter MAXMSG (the maximum number of BUFR messages which can be stored +internally) increased from 50000 to 200000 in the following subroutines: +CPYMEM, RDMEMM, RDMEMS, READMM, UFBMEM, UFBMMS, UFBMNS, UFBRMS and UFBTAM. +This may be necessary in the future for BUFR files with many, many messages. + +29) Parameter MAXJL (the maximum number of Jump/Link table entries) increased +from 15000 to 16000 in the following routines: BFRINI, CONWIN, COPYMG, CPYMEM, +DRFINI, DRSTPL, GETWIN, INCTAB, INVCON, INVMRG, INVTAG, INVWIN, LSTJPB, +LSTRPC, LSTRPS, MAKESTAB, MSGINI, NEWWIN, NVNWIN, NWORDS, NXTWIN, PARUTG, +RCSTPL, RDCMPS, RDTREE, READNS, TABENT, TABSUB, TRYBUMP, UFBCPY, UFBCUP, +UFBDMP, UFBEVN, UFBGET, UFBINT, UFBOVR, UFBREP, UFBRP, UFBRW, UFBSEQ, UFBSP, +UFBSTP, UFBTAB, UFBTAM, UFDUMP, USRTPL, WRCMPS and WRTREE. This was present +in the original verification-specific version of the library. + +30) The following routines are modified to make the BUFR Archive Library +big-endian/little-endian independent: IPKM, IUPM, PKB, PKC, UPB and UPBB. This +was present in the original decoder-specific version of the library and +increases the portability of the BUFR Archive Library. + +31) Subroutine BFRINI modified to initialize variable JSR as ZERO in new +COMMON block /BUFRSR/. This was present in the original verification-specific +version of the library. (See also 29 for BFRINI.) + +32) Subroutine RCSTPL modified to increase the maximum number of levels of +recursion (parameter MAXRCR) from 50 to 100. This was present in the original +verification-specific version of the library. (See also 29 and 43 for RCSTPL.) + +33) Subroutine WRCMPS modified to save logical variables WRIT1 and FLUSH in +global memory. This fixed a bug in this subroutine which could lead to +messages being written out before being full. (See also 29 for WRCMPS.) + +34) Subroutine RDTREE modified to fix a bug which could only occur when the +last element in a subset is a character. (See also 29 for RDTREE.) + +35) Subroutine UFDUMP modified to handle print of character values greater +than 8 bytes. (See also 29 for UFDUMP.) + +36) Subroutine UFBEVN modified to save the maximum number of events found for +all data values specified amongst all levels returned as variable MAXEVN in +new COMMON block /UFBN3C/ and to add call to BORT if BUFR file is open for +output. (See also 29 for UFBEVN.) + +37) Subroutine NEMOCK modified to expand non-zero return into -1 for length +not 1-8 characters and -2 for invalid characters (return only -1 before for +all problematic cases) + +38) Subroutine NUMBCK modified to expand non-zero return into -1 for invalid +character in position 1, -2 for invalid characters in positions 2 through 6, +-3 for invalid characters in positions 2 and 3 due to being out of range, and +-4 for invalid characters in positions 4 through 6 due to being out of range +(return only -1 before for all probelmatic cases) + +39) Subroutine WTSTAT modified to correct a "typo" in test for valid value for +"IM". + +40) Subroutines ELEMDX, PARSEQ, PARUSR, PARUTG, PKC, RDUSDX, SEQSDX, STRING, +UFBINT, UFBOVR, UFBREP, UFBSTP and VALX modified to call new BUFR Archive +Library subroutine BORT2 (see 1). + +41) Subroutine MAKESTAB modified to allow for the possibility that a connected +file may not contain any dictionary table info (e.g., an empty file). +Subsequent connected files which are not empty will no longer get tripped up +by this. (This change avoids the need for an application program to +disconnect any empty files via a call to CLOSBF.) (See also 29 for MAKESTAB.) + +42) Subroutine READTJ modified to simply call BUFR Archive Library subroutine +READMG rather than being a clone of it. At one time it performed different +functions than READMG, but that has not been the case since the 2000-09-19 +BUFR Archive Library implementation. + +43) Subroutines CKTABA, CMSGINI, NUMTAB, PARUSR, PARUTG, RCSTPL, USRTPL, +WRDLEN, WRTREE and XMSGINI modified to correct some minor bugs (uninitialized +variables, etc.) (see subroutine DOCBLOCKS for more information). (See also +29 for PARUTG, RCSTPL, USRTPL, WRTREE and 32 for RCSTPL.) + +44) Subroutine UFBDMP modified to add "fuzziness" about 10E10 in test for a +missing value (rather than true equality as before) because some missing values +(e.g., character strings < 8 characters) were not getting stamped out as +"MISSING". Also added option to print values using format edit descriptor +"F15.6" if input argument LUNIN is < zero. If LUNIN is > zero edit descriptor +expanded from "G10.3" to "G15.6". (See also 29 for UFBDMP.) + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 18Z 21 December 2004 + (Blue/White only) + +1) New subroutines ISTDESC, RESTD, WRDESC, CADN30, STDMSG and STNDRD have been +added to provide the capability to expand Section 3 of output BUFR messages +until they are completely "standard" according to the WMO FM-94 regulations. +The logic is activated via an initial call to STDMSG. + +2) Subroutine XMSGINI has been removed. It had been included in a previous +BUFRLIB version as an indirect way of "standardizing" compressed messages, but +the same logic is now fully integrated into CMSGINI and is activated via a +separate initial call to new subroutine STDMSG (see 1). + +3) Subroutine STANDARD has been marked as obsolete (for future removal from +BUFRLIB) in favor of a new subroutine STNDRD which more completely +"standardizes" Section 3. The old subroutine (i.e. STANDARD) would always just +break down the top-level Table A descriptor by one level, so that, unless this +"one level deep" expansion happened to consist of all standard descriptors, the +resulting BUFR message was still non-standard. Contrarily, the new logic will +recursively break down successive sequence descriptors for as long as needed +until all appearing in Section 3 are themselves standard or else, at a +minimum, preceded with the 206YYY "bypass" operator (note: this recursive logic +is written using C for portability reasons, since not all FORTRAN 77 compilers +support recursion!). In addition, STNDRD has other advantages over STANDARD +as well; namely, it contains safety checks which prevent overflow of the +message array that is passed to it, and it also is more directly integrated +into BUFRLIB and can be automatically activated in-line via a separate initial +call to new subroutine STDMSG (see 1). + +4) Subroutine WRITSA was modified to fix a bug which, in certain situations, +prevented one or more BUFR messages from being returned to the calling program +within the memory arrays. In addition, a new subroutine WRITCA was added which +functions exactly like WRITSA except that it works on compressed messages. + +5) Subroutines WRCMPS and RDCMPS were modified to fix a bug in the compression +algorithm which occurred when all subsets in a single message contained +identical character strings. Separate corrections were also made to each of +these subroutines to fix a few unrelated minor bugs. + +6) Subroutine UFDUMP was modified to add a fuzziness test for the "missing" +value and to add an interactive, scrolling print capability similar to UFBDMP. + +7) Subroutine UFBDMP was modified to automatically use READLC when reading +"long" character strings, similar to an existing capability within UFDUMP. + +8) Documentation was improved and/or clarified in many existing subroutines +throughout BUFRLIB. + +9) Subroutines COMPRES and READ2C have been removed. The same functionality +can be obtained by using subroutine WRITCP. + +10) Subroutines IREADERS, READERS and READTJ have been removed, as they were +nothing more than wrappers for READMG and had been marked as obsolete within +a previous BUFRLIB version. + +11) Subroutines READERM, IREADERM and IRDERM have been removed. They had +been superseded functionally by (the more-portable!) subroutine READIBM and +had been marked as obsolete within a previous BUFRLIB version. + +12) Parameter MXMSGL (the maximum number of bytes in a BUFR message) was +increased from 20K TO 50K bytes in the following subroutines: BFRINI, CKTABA, +CLOSMG, CMSGINI, COPYBF, COPYMG, COPYSB, CPYMEM, CPYUPD, DXMINI, MAXOUT, +MESGBC, MESGBF, MINIMG, MSGINI, MSGUPD, MSGWRT, NMBYT, POSAPN, POSAPX, +RCSTPL, RDBFDX, RDCMPS, RDMEMM, RDMEMS, RDMGSB, RDTREE, READERME, READFT, +READIBM, READLC, READMG, READMM, READSB, REWNBF, SUBUPD, UFBGET, UFBINX, +UFBMEM, UFBTAB, UFBTAM, WRCMPS, WRITDX, WRITLC, WRITSA and WRTREE. (Note: +this is not included in the Docblock history in these routines.) + +13) Subroutines READERME, READIBM, DATEBF and DUMPBF were modified to make +the test for the string 'BUFR' portable to EBCDIC machines. + +14) Subroutine WRTREE was modified to use double-precision arithmetic within +an internal statement function, in order to correct for a truncation problem +that could occur in the case of very large computed values. + +15) Subroutine COPYST has been marked as obsolete (for future removal from +BUFRLIB). The same functionality can be obtained by calling new subroutine +STDMSG, followed by a call to COPYMG. + +16) Subroutine WRITST has been marked as obsolete (for future removal from +BUFRLIB). The same functionality can be obtained by calling new subroutine +STDMSG, followed by a call to CLOSMG. + +17) A new option IO="NODX" has been added to subroutine OPENBF. In this +case, the subroutine behaves exactly as if it had been called with IO="OUT", +except that DX dictionary messages are not written out to logical unit LUNIT. + +18) Subroutine WRDLEN was modified to keep track of whether it has already +been called by one of the other BUFRLIB subroutines and, if so, to then +immediately return (without proceeding any further) every time it is +subsequently called. + +19) Subroutines OPENBF, UFBINT, UFBOVR, UFBREP, UFBSEQ, UFBSTP and WRDLEN +were all modified to fix similar portability bugs whereby the values of some +internal variable(s) which keep track of whether the subroutine has already +been called were not being explicitly preserved with a SAVE statement. + +20) New subroutine PKVS1 was added which calls OVRBS1 in an in-line fashion +and therefore allows easier overwriting of default values in Section 1 of +output BUFR messages. The new methodology can also overwrite the value of +byte 8 in Section 0 (i.e. BUFR edition number) if desired. + +21) New function IUPVS1 was added which calls IUPBS1 in an in-line fashion +and therefore allows easy unpacking of Section 1 values from BUFR messages +that have already been read into the internal memory arrays by subroutine +READMG or equivalent. The new methodology can also unpack the value of +byte 8 in Section 0 (i.e. BUFR edition number) if desired. + +22) Subroutine ADDATE was modified to fix a bug in calculating the number of +days in February for years which are multiples of 100 but not of 400. + +23) Subroutine MESGBC was modified to allow the option of operating on a +BUFR message that has already been read into the internal memory arrays by +subroutine READMG or equivalent. + +24) New subroutine DXDUMP was added which outputs an ASCII-formatted copy of +the information embedded within the DX dictionary messages of a BUFR file. +It is especially useful for learning the contents of archived BUFR files, +and the output is in a format suitable for subsequent input to OPENBF as a +user-defined dictionary tables file. + +25) Subroutines DATELEN, DATEBF and DUMPBF were all modified to call +subroutine WRDLEN to initialize local machine information (in case it has +not already been called). These routines do not require this information +but they may now or someday call other routines that do require it. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 31 January 2006 + +1) Documentation was improved and/or clarified within many existing routines +throughout BUFRLIB. + +2) Global parameter MAXMEM (the maximum number of bytes that can be used to +store BUFR messages internally) was increased from 16Mb to 50Mb, and global +parameter MAXTBA (the maximum number of entries in the internal BUFR Table A) +was increased from 50 to 60. In addition, all global parameters were moved +into a new global INCLUDE file "bufrlib.PRM", rather than continuing to +hardcode the same parameter values in every individual source file where +they were needed. This will allow future changes to any of these parameter +values to be made much more easily. + +3) An additional CCS compilation of BUFRLIB (libbufr_s_64.a) is now being +maintained via the makefile. This new version is identical to the existing +libbufr_4_64.a compilation, except that several parameter values within +"bufrlib.PRM" are set much larger in order to allow extremely large BUFR +messages (i.e. up to 2.5Mb) to be processed. + +4) The capability to compress output BUFR messages has now been directly +incorporated into subroutines WRITSB and WRITSA, whereas previously it had +been necessary to instead call the separate subroutines WRITCP and WRITCA, +respectively. The use of compression can now be easily toggled on or off +(with "off" as the default if left unspecified) via new subroutine CMPMSG. +As such, subroutine WRITCA has now been marked as obsolete (for future removal +from BUFRLIB), since the same functionality can now be obtained by calling the +new subroutine CMPMSG, followed by a call to WRITSA. In a similar manner, +WRITCP has now been modified to directly call subroutines CMPMSG and WRITSB, +although it is being retained as a distinct subroutine within BUFRLIB (rather +than also being marked as obsolete) out of consideration for the large number +of existing application programs which use it. + +5) A new function IUPBS01 was added which works like existing function +IUPBS1, except that it uses a descriptive mnemonic rather than a hardcoded +byte number in order to specify the value to be unpacked from Section 0 or +Section 1 of a BUFR message. This allows the same function call to work on +messages encoded using either BUFR edition 3 or BUFR edition 4 (rather than +having to pass in different byte numbers depending on the edition!), and it +also allows values encoded across multiple bytes (e.g. section lengths, +4-digit years, etc.) to be easily unpacked as well. As such, the existing +function IUPBS1 has been marked as obsolete (for future removal from BUFRLIB), +and many other subroutines throughout BUFRLIB (e.g. UPDS3, DATEBF, DUMPBF, +STNDRD, CKTABA, NMBYT, MSGWRT, RDBFDX, etc.) have been modified to now use +the new function IUPBS01. In addition, a new function IUPVS01 was added which +calls IUPBS01 in an in-line fashion, and existing function IUPVS1 (which had +similarly called IUPBS1 in an in-line fashion) has now been marked as obsolete. + +6) A new subroutine PKVS01 was added which works like existing subroutine +PKVS1, except that it uses a descriptive mnemonic rather than a hardcoded +byte number in order to specify the value to be stored into Section 0 or +Section 1 of all future output BUFR messages. This allows the same +subroutine call to work on messages encoded using either BUFR edition 3 +or BUFR edition 4 (rather than having to pass in different byte numbers +depending on the edition!), and it also allows values encoded across multiple +bytes (e.g. 4-digit years, originating centers and subcenters, etc.) to be +easily overwritten as well. As such, the existing subroutine PKVS1 has been +marked as obsolete (for future removal from BUFRLIB). In a similar manner, +a new subroutine PKBS1 was also added to replace existing subroutine OVRBS1, +which has now itself also been marked as obsolete. + +7) A new subroutine CNVED4 was added which, given a BUFR message encoded using +BUFR edition 3, creates and outputs an equivalent message encoded using BUFR +edition 4. This subroutine can be called by an application program, or it can +alternatively be activated in an in-line fashion via a call to new subroutine +PKVS01 using the descriptive mnemonic "BEN" (i.e. BUFR edition number) with a +corresponding value of "4". + +8) Subroutines NEMTAB, NUMTAB, TABENT and TABSUB were modified to support +the Table C operators 2-07-YYY and 2-08-YYY, which are new to BUFR with the +advent of edition 4. + +9) Subroutines COPYST, WRITST and STANDARD, which had been marked as obsolete +within a previous version of BUFRLIB, have now been deleted. + +10) The default BUFR master table version number was changed from "4" to "12" +within subroutines CMSGINI, DXMINI and MSGINI. + +11) A bug was corrected in subroutine STNDRD in order to ensure that byte 4 of +Section 4 is always properly zeroed out. + +12) A bug was corrected in subroutine PARUTG which was preventing 1-bit delayed +replication factors from being directly read via a call to subroutine UFBINT. + +13) A bug was corrected in subroutine WRCMPS which was causing a character +compression array to be improperly initialized. In addition, a local parameter +was increased to allow up to 4000 subsets to be written into a single compressed +BUFR message. + +14) Subroutine UFBMEM was modified to not abort when there are either too many +messages read in or too many bytes read in (i.e., .gt. array limits passed in), +but rather to just process the limiting number of messages and/or bytes and +print a diagnostic. + +15) Subroutine CLOSMG was modified to override logic that had always written +out messages 1 and 2 even when they contained zero subsets (it assumed these +contained the dump center and processing time in Section 1). Now, if the unit +number argument is passed in as a negative number the first time this routine +is called by an application program, ALL empty messages are skipped (i.e., +assumes that messages 1 and 2 do not contain dump center and processing time). +This remains set for all subsequent calls to CLOSMG for a particular file, +regardless of the sign of the unit number (CLOSMG is called by other BUFRLIB +routines which always pass in a positive unit number). + +16) A new function IGETDATE was added which unpacks and returns the Section 1 +date-time from an input BUFR message, in format of either YYYYMMDDHH or YYMMDDHH +depending on the value requested via the most recent call to subroutine DATELEN. +The same logic had been repeated within numerous existing subroutines throughout +BUFRLIB and has now been consolidated into this single subroutine that can +itself be called from wherever it is needed. + +17) A new subroutine GETLENS was added which unpacks and returns the individual +section lengths from an input BUFR message. The same logic had been repeated +within numerous existing subroutines throughout BUFRLIB and has now been +consolidated into this single subroutine that can itself be called from +wherever it is needed. + +18) A new subroutine RDMSGW was added which reads the next padded BUFR message +from a given BUFR file. The same logic had been repeated within numerous +existing subroutines throughout BUFRLIB and has now been consolidated into +this single subroutine that can itself be called from wherever it is needed. + +19) A new function PKFTBV was added which computes and returns the value +equivalent to the setting of a specified bit within a flag table of a +specified width. In addition, a new subroutine UPFTBV was also added which +functions as the logical inverse, i.e. given a mnemonic and corresponding flag +table value, it computes and returns the equivalent bit settings. + +20) A new subroutine UFBPOS, which allows a user to directly point at and read +a specified subset from within a specified message in an input BUFR file, was +added to BUFRLIB. Previously, this logic existed as an in-line subroutine +within a separate application program. + +21) A new subroutine GETABDB, which returns internal BUFR table information +in a pre-defined ASCII format, was added to BUFRLIB. Previously, this logic +existed as an in-line subroutine within a separate application program. + +22) Subroutine READMG was modified to be able to handle BUFR messages which are +not padded out to an 8-byte boundary and for which it had therefore previously +been necessary to instead call the separate subroutine READIBM. Logic was also +added to allow the option of having READMG behave like the separate subroutine +READFT, so that it will not abort when a read error is encountered but rather +will treat it the same as an end-of-file condition. This option is activated +by passing in the negative of the usual logical unit number. In summary, READMG +can now itself properly read from any FORTRAN-blocked file of BUFR messages, and +therefore the existing subroutines READIBM, IREADIBM, READFT and IREADFT have +now all been marked as obsolete (for future removal from BUFRLIB). + +23) A set of generic C-language functions for reading/writing BUFR messages +from/to generic BUFR files (which may or may not contain FORTRAN-blocking and/or +message padding) was added to BUFRLIB. These functions (CCBFL, COBFL, CRBMG, +CWBMG and RBYTES) are primarily intended for use by separate application +programs (such as cwordsh), but are themselves being directly incorporated into +BUFRLIB in order to prevent such application programs from having to directly +link to certain COMMON blocks and parameter sizes internal to BUFRLIB. + +24) Function MOVA2I is marked as obsolete (for future removal from BUFRLIB). It +is present in the W3 Libraries (in C language) and is no longer called by any +BUFR Archive Library routines. A warning message is now printed instructing +users to migrate to MOVA2I in the W3 Libraries. + +25) Subroutine UFBTAB was modified to work for compressed BUFR messages. An +option to return only the subset count (when the input unit number is less than +zero) was also added. + +26) Subroutine COPYSB was modified to now write out a compressed subset/message +if the input subset/message is compressed (before this subroutine could only +write out an uncompressed subset/message regardless of the compression status +of the input subset/message). + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 06 February 2007 + +1) Several global parameters were increased in "bufrlib.PRM". Specifically, +MAXTBA, MAXTBB and MAXTBD (the maximum numbers of internal Table A, B and D +entries, respectively) were increased from 60, 250 and 250 to 120, 500 and 500, +respectively, and MAXJL (the maximum number of internal jump/link table +entries) was increased from 16000 to 20000. + +2) Subroutine CKTABA was modified to allow "FRtttsss" and "FNtttsss" (where ttt +is the message type and sss is the message subtype) as valid Table A mnemonics +for foreign BUFR messages. Previously, only "NCtttsss" had been allowed. + +3) Subroutines GETS1LOC and IUPBS01 were modified to provide two additional +options for unpacking values from Section 1 of a BUFR message. Specifically, +"CENT" now unpacks the century and "YCEN" now unpacks the year of the century. + +4) Subroutine PKBS1 was modified to provide several additional options for +directly packing values into Section 1 of a BUFR message. Specifically, +"YEAR", "MNTH", "DAYS", "HOUR", "CENT" and "YCEN" now pack the message year, +month, day, hour, century and year of century, respectively, and "MTYP" and +"MSBT" now pack the message type and subtype, respectively. + +5) Subroutine MAXOUT was modified to allow it to be called with a special flag +value of "0", indicating that output BUFR messages should be set to the maximum +allowable record length. In addition, a sanity check was added to prevent this +record length from being set to a value greater than the maximum allowable. + +6) For the printing of flag table values, subroutines UFBDMP and UFDUMP were +modified to include an equivalent listing of the bits that were actually set. + +7) Subroutine UFBPOS was modified to remove an unnecessary (and incorrect!) +initialization statement. This had been silently ignored by the IBM CCS +compiler but was a portability issue for other compilers. + +8) Subroutine UFBTAB was modified to add a required declaration for a local +character variable. This had been silently ignored by the IBM CCS compiler +but was a portability issue for other compilers. + +9) Subroutine RDUSDX was modified to abort if it encounters a user-defined +BUFR message whose message type is set to 11. This value is reserved for +internal dictionary messages. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, 28 May 2008 + +1) Subroutine BORT_EXIT was modified to fix a faulty ANSI-C declaration. +This had been silently ignored by the IBM CCS compiler but was a portability +issue for other compilers. + +2) Subroutines RDTREE and WRTREE were modified to fix a bug which, on rare +occasions, caused a segmentation fault due to overflow of internal arrays. +This bug only occurred when working with long character strings (i.e. longer +than 8 bytes) while using a non-optimized compilation of BUFRLIB. + +3) Subroutine WRITCA, which had been marked as obsolete within a previous +version of BUFRLIB, has now been deleted. + +4) A new subroutine PARSTR was added which works like existing subroutine +PARSEQ, except that it allows substrings within a string to be separated by +one or more occurrences of any given single character (and not just by one +or more blank characters). As such, the existing subroutine PARSEQ has +been marked as obsolete (for future removal from BUFRLIB), and many other +subroutines throughout BUFRLIB have been modified to now use the new +subroutine PARSTR. + +5) Subroutine JSTCHR was modified to add a return argument indicating +whether the input string was empty. This allows the subroutine to be used +in any context where existing subroutine LJUST was being used, and LJUST +has now been marked as obsolete (for future removal from BUFRLIB). + +6) Several new subroutines have been added to enable the capability to read +BUFR table information from external ASCII master tables instead of from +pre-defined DX dictionary files. This is in preparation for the planned +future capability to be able to directly decode a BUFR message according to +its internal data description section. + +7) The value BMISS (i.e. the BUFR "missing" value), which was defined as a +local data value within many separate subroutines, has now been defined as a +global parameter within the "bufrlib.PRM" include file. In addition, a new +function IBFMS has been added which safely tests a given value to determine +whether or not it is "missing", and several existing subroutines throughout +BUFRLIB have been modified to now use this new function. + +8) The determination as to whether the local host machine uses the +"big-endian" or "little-endian" byte-ordering scheme is now determined at +compile time and integrated into BUFRLIB via the use of conditional +compilation statements. This allows BUFRLIB to run much more efficiently +since it no longer has to constantly re-check the local byte-ordering +scheme at run time. + +9) Subroutine DXDUMP was modified to correct a bug which caused the +truncation of output reference values longer than 8 digits. + +10) Several global parameters were increased in "bufrlib.PRM". +Specifically, MXCDV (the maximum number of data values per subset in a +compressed BUFR message) was increased from 2000 to 3000, and MAXMEM (the +maximum number of bytes that can be used to store BUFR messages within +internal memory) was increased from 50Mb to 75Mb within the "supersized" +BUFRLIB. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.0.0 + +1) Subroutines PKVS1, OVRBS1, NMBYT, READIBM, IREADIBM, READFT, IREADFT and +MOVA2I, which had been marked as obsolete within a previous version of +BUFRLIB, have now been deleted. + +2) A new global parameter MAXSS was defined for use as the maximum number of +data values that can be read from or written into a single data subset by the +BUFRLIB software. Previously, the separate global parameter MAXJL was used +to define this limit. MAXJL will now be used solely to define the maximum +number of internal jump/link table entries. + +3) The size of a string declaration was increased within subroutine RDUSDX. + +4) Subroutine READLC was modified to enable the extraction of "long" (i.e. +greater than 8 bytes) character strings from compressed messages. In +addition, it is now possible to access all occurrences of such a string +from within a given data subset, via the use of the new mnemonic condition +character '#'. Previously, READLC could only ever access the first +occurrence of any "long" character string from within a data subset. + +5) Subroutine WRITLC was modified to allow the writing of "long" (i.e. +greater than 8 bytes) character strings within compressed messages. In +addition, it is now possible to write all occurrences of such a string into +a given data subset, via the use of the new mnemonic condition character '#'. +Previously, WRITLC could only ever locate and write the first occurrence of +any "long" character string within a data subset. + +6) Subroutine UFDUMP was modified to label each output level for sequences +where the replication count is greater than 1. In addition, it will now +output all occurrences of "long" (i.e. greater than 8 bytes) character +strings from within a given data subset. + +7) Subroutine RDCMPS was modified to fix a bug which could cause the overflow +of internal arrays when working with long character strings (i.e. longer +than 8 bytes). + +8) Subroutine NVNWIN was modified to fix a bug which could cause the overflow +of an internal array during initialization on certain operating systems. + +9) A new subroutine BVERS was added as a resource for managing and reporting +library version numbers. + +10) The fuzziness threshold in function IBFMS was increased for improved +accuracy when testing for the BUFRLIB "missing" value. + +11) A new subroutine IUPBS3 was added which unpacks specified values from +Section 3, including subset counts and compression indicators. The same +logic had been repeated within numerous existing subroutines throughout +BUFRLIB and has now been consolidated into this single subroutine that can +itself be called from wherever it is needed. + +12) Subroutines READERME, RDMSGW and RDMSGB were modified to prevent the +overflow of an internal array for extremely large BUFR messages. + +13) Subroutine UPDS3 was modified to pass in a new input argument containing +the dimensioned size of the output array, in order to prevent the subroutine +from possibly overflowing the array. + +14) Subroutine WRITSA was modified to pass in a new input argument containing +the dimensioned size of the output array, in order to prevent the subroutine +from possibly overflowing the array. + +15) A new capability was added to BUFRLIB to enable the decoding of a BUFR +message according to its data description section (Section 3). This is +activated by setting IO="SEC3" when opening the file via subroutine OPENBF. +Master tables containing all possible BUFR descriptors are also required, and +these may be specified via a call to new subroutine MTINFO or by using default +values specified within subroutine BFRINI. If the default values are used, +then FORTRAN logical unit numbers 98 and 99 will be allocated by the BUFRLIB +for opening and reading the master tables. This new capability allows BUFR +messages to be decoded without pre-defined DX dictionary files. + +16) Subroutine READMM was re-written to directly call subroutine RDMEMM +instead of duplicating all of the code logic in RDMEMM. + +17) Subroutine UPB was re-written to directly call subroutine UPBB instead of +duplicating all of the code logic in UPBB. + +18) Subroutine POSAPN has been marked as obsolete (for future removal from +BUFRLIB). The same functionality can now be obtained via the use of +subroutine POSAPX. + +19) Subroutine WRCMPS was modified to fix a bug involving the writing of +compressed subsets which contain delayed replication. In certain situations, +the values of two internal variables were not being properly saved between +successive calls to the subroutine. + +20) Changes were made so that the BUFRLIB will automatically read and adjust +to any DX table (dictionary) messages internal to a file. Previously, the +software would only ever process such messages at the beginning of a file, +so that all subsequent data messages in that file were required to conform +to these initial dictionary messages, and any subsequent dictionary messages +in the file were simply ignored. Now, any subsequent dictionary messages +will cause the BUFRLIB to adjust its internal processing tables and treat all +subsequent data messages as conforming to these new dictionary messages, up +through the end of the file or until yet another set of dictionary messages +is encountered. These changes affect all BUFRLIB subroutines which read BUFR +messages from a file, including READMG, IREADMG, READMM, IREADMM, RDMEMM, +READNS and IREADNS. + +21) Subroutine ADDATE has been marked as obsolete (for future removal from +BUFRLIB) since it is no longer called by any BUFRLIB routines. The same +functionality can now be obtained via the use of subroutine W3MOVDAT in the +NCEP W3 library. + +22) Subroutine SUBUPD has been marked as obsolete (for future removal from +BUFRLIB) since it is no longer called by any BUFRLIB routines and is almost +an exact replica of subroutine MSGUPD. The same functionality can now be +obtained via the use of subroutine MSGUPD. + +23) A new logical function MSGFULL was added which determines whether there is +enough room to store the current data subset within the current BUFR message +for output. The same logic had been repeated within numerous existing +subroutines throughout BUFRLIB and has now been consolidated into this single +subroutine that can itself be called from wherever it is needed. + +24) A new capability was added to BUFRLIB to allow it to append a tank receipt +time to Section 1 within all future BUFR messages written to output by +subroutines WRITSB, COPYMG or equivalent. The tank receipt time is a local +extension to Section 1; however, its inclusion in a message is still fully +compliant with the WMO BUFR regulations. This new capability is activated via +an initial call to new subroutine STRCPT, specifying the time to be appended +to Section 1 within all future BUFR messages written to output. This same +information can then be read back from an input BUFR message via a call to new +subroutine RTRCPT. + +25) Subroutine NUMTAB was re-written to directly call subroutine NUMTBD +instead of duplicating all of the code logic in NUMTBD. + +26) Subroutine NEMTBA was re-written to directly call subroutine NEMTBAX +instead of duplicating all of the code logic in NEMTBAX. + +27) Documentation was improved within numerous subroutines throughout BUFRLIB, +including the addition of docblocks where none previously existed. + +28) The default BUFR master table version number was changed from "12" to "13" +within subroutines CMSGINI, DXMINI and MSGINI. + +29) A new capability was added to allow BUFRLIB print diagnostics and other +runtime messages to be redirected somewhere other than the default FORTRAN +logical unit #6 (i.e. standard output). This is enabled within an application +program by supplying an in-line version of subroutine ERRWRT to override the +new default version of this subroutine provided within the BUFRLIB. The +default version will continue to write to standard output when included within +a compilation. + +30) Subroutines CMSGINI, STNDRD and MSGWRT were modified to remove a logical +error which assumed that any message whose data section (Section 4) was +compressed was also fully standard. In reality, the use of compression only +implies that the data section is fully standard and does not necessarily imply +that the data description section (Section 3) is also fully standard. BUFRLIB +will now address the standardization of Section 3 solely within subroutine +STNDRD, independent of whether or not the data in Section 4 are compressed. + +31) Functions LSTRPC and LSTRPS have been marked as obsolete (for future removal +from BUFRLIB). The same functionality can now be obtained via the use of +function LSTJPB. + +32) Subroutine UFBTAB was modified to fix a bug involving the unpacking of +character strings which are identical within each subset of a single +compressed BUFR message. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.0.1 + +1) Subroutine REWNBF was modified to fix a bug which skipped the first data +message after a file rewind. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.1.0 + +1) Subroutine UFDUMP was modified to fix a bug when checking for the "missing" +value in long character strings (i.e. longer than 8 bytes). + +2) A new subroutine UFBMEX was added for use with certain application +programs. UFBMEX functions similarly to UFBMEM, but has an additional return +argument containing an array of message types corresponding to the array of +messages that were read into internal memory. + +3) Subroutines ADDATE, IUPBS1, IUPVS1, LJUST, LSTRPC, LSTRPS, SUBUPD, POSAPN +and PARSEQ, which had been marked as obsolete within a previous version of +BUFRLIB, have now been deleted. + +4) Several global parameters were increased in "bufrlib.PRM". +Specifically, MAXTBA (the maximum number of Table A entries for a BUFR file) +was increased from 120 to 150, and MXDXTS (the maximum number of dictionary +tables that can be stored for use with BUFR messages in internal memory) was +increased from 10 to 200. + +5) Subroutine CONWIN was modified to fix a bug and remove an obsolete call +argument. + +6) Subroutine WRCMPS was modified to fix a bug involving embedded tables +within a file of compressed BUFR messages. + +7) Documentation was improved in many subroutines throughout the library. + +8) Support has been added for the 2-03-YYY "change reference values" operator. + +9) Subroutine USRTPL was modified to fix a bug that was incorrectly using +parameter MAXJL instead of parameter MAXSS when checking for overflow of an +internal template array. + +10) Subroutine WRDXTB was modified to prevent it from trying to store more +than 255 Table A, Table B or Table D descriptors in a single DX dictionary +message. The maximum value was set to 255 since regular 8-bit delayed +replication is used to store descriptor information in these messages. + +11) Subroutine TABSUB was modified to correctly generate the jump/link table +for subsets where a Table C operator immediately follows a Table D sequence. + + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.2.0 + +1) The makebufrlib.sh script was modified to streamline the endianness check +and make it more portable. + +2) Subroutine WRTREE was modified to ensure that "missing" character strings +are properly encoded with all bits set to 1. + +3) A new function ICBFMS was added which tests whether decoded character +strings are "missing" by checking if all of the equivalent bits are set to 1. +This was done because, on certain platforms, the BUFRLIB REAL*8 "missing" value +BMISS is not always equivalent to all bits set to 1 when viewed as a character +string, and thus the existing BUFRLIB function IBFMS did not always work +properly in such cases. However, users can continue to use the existing IBFMS +function in application programs, because the new ICBFMS function has now been +incorporated internally within the logic of many BUFRLIB subroutines, in +addition to also being available for direct calling by application programs. + +4) Subroutines READMG and READERME were modified to prevent the BUFRLIB from +internally adjusting to DX (dictionary) table messages when Section 3 decoding +is being used. Otherwise, contention can occur between the table information +in the DX messages and the table information specified within the Section 3 +descriptors. From now on, whenever Section 3 decoding is used (as specified +by setting IO="SEC3" when opening a file via OPENBF), the BUFRLIB will now +treat any DX (dictionary) table message the same as any other message and +decode the actual data (i.e. table) values according to Section 3. + +5) Subroutine OPENBF was modified to allow a new option for input call +argument IO. If this argument is set to 'INUL', then the BUFRLIB will behave +the same as when IO='IN', except that it will never try to actually read +anything from the file attached to input call argument LUNIT. This can be +useful for some special cases, such as when the user plans to pass input +messages to the BUFRLIB using subsequent calls to subroutine READERME. + +6) A new subroutine GETTAGPR was added which returns the mnemonic corresponding +to a parent sequence in a subset definition, given the mnemonic corresponding +to a child descriptor within that sequence. This can be useful in certain +application codes, especially when Section 3 decoding is being used. + +7) A new function GETVALNB was added which searches for a specified mnemonic +in a subset definition, then searches forward or backward from that point for +a different mnemonic and returns the associated value. This can be useful in +certain application codes, especially when Section 3 decoding is being used. + +8) Functionality was added to improve the portability of reading and writing +BUFR messages across different platforms. All calls to existing FORTRAN +subroutines which read or write BUFR messages from disk (e.g. READMG, UFBMEM, +UFBTAB, WRITSB, WRCMPS, COPYMG, etc.) now use embedded C-language I/O to +perform these tasks. Among other things, this means that any BUFR file can +now be read regardless of whether it has been pre-blocked with FORTRAN +control words using the cwordsh utility. For writing BUFR files, a new +subroutine SETBLOCK was added which allows users to specify whether output +BUFR messages are to be unblocked (which is the new default), big-endian +blocked, or little-endian blocked. + +9) A new subroutine SETBMISS was added which allows users to specify a custom +"missing" value for writing to and reading from BUFR files, rather than using +the BUFRLIB default "missing" value of 10E10. A corresponding function +GETBMISS was also added which returns the current "missing" value in use. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.2.1 + +1) A bug was fixed in the embedded C-language I/O to account for the +difference in index numbering between Fortran and C arrays. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.2.2 + +1) Subroutine OPENBF was modified to fix a bug which caused a segfault in +certain cases when appending to a BUFR file using the embedded C-language I/O. + +2) Subroutines READLC and WRITLC were modified to allow the input mnemonic +string to be up to 14 characters when it contains a '#' condition code. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.2.3 + +1) Subroutine RDUSDX was modified to prevent a segfault when trying to read +DX dictionary information from an empty file. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.2.4 + +1) Configuration files bufrlib.PRM and makebufrlib.sh were updated to +generate a 4_32 build (4-byte REAL, 4-byte INT, 32-bit compilation) on +the IBM CCS for version 10.2.3 of the BUFRLIB. + +############################################################################## +############################################################################## +############################################################################## + + Changes to BUFR Archive Library, Version 10.2.5 + +1) Subroutine MESGBF was modified to ensure that the input BUFR file is +always closed before exiting the subroutine. + +2) Function COBFL was modified to allow up to 500 characters in the path of +the filename being opened. + +3) A declaration typo was fixed in subroutine BLOCKS. + +4) Global parameter MAXNC (the maximum number of FXY descriptors that can be +written into Section 3 of a BUFR message) was increased from 300 to 600. diff --git a/src/bufr/adn30.f b/src/bufr/adn30.f new file mode 100644 index 0000000000..c7306f7b8d --- /dev/null +++ b/src/bufr/adn30.f @@ -0,0 +1,85 @@ + FUNCTION ADN30(IDN,L30) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ADN30 +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CONVERTS A DESCRIPTOR FROM ITS BIT-WISE +C (INTEGER) REPRESENTATION TO ITS FIVE OR SIX CHARACTER ASCII +C REPRESENTATION. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: ADN30 (IDN, L30) +C INPUT ARGUMENT LIST: +C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) +C VALUE +C L30 - INTEGER: LENGTH OF ADN30 (NUMBER OF CHARACTERS, 5 OR +C 6) +C +C OUTPUT ARGUMENT LIST: +C ADN30 - CHARACTER*(*): CHARACTER FORM OF DESCRIPTOR (FXY +C VALUE) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: CADN30 DXINIT ISTDESC NEMTBD +C NUMTAB RDMTBB RDMTBD READS3 +C SEQSDX SNTBDE UFBQCD UPDS3 +C WRDXTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*(*) ADN30 + CHARACTER*128 BORT_STR + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(LEN(ADN30).LT.L30 ) GOTO 900 + IF(IDN.LT.0 .OR. IDN.GT.65535) GOTO 901 + IF(L30.EQ.5) THEN + WRITE(ADN30,'(I5)') IDN + ELSEIF(L30.EQ.6) THEN + IDF = ISHFT(IDN,-14) + IDX = ISHFT(ISHFT(IDN,NBITW-14),-(NBITW-6)) + IDY = ISHFT(ISHFT(IDN,NBITW- 8),-(NBITW-8)) + WRITE(ADN30,'(I1,I2,I3)') IDF,IDX,IDY + ELSE + GOTO 902 + ENDIF + + DO I=1,L30 + IF(ADN30(I:I).EQ.' ') ADN30(I:I) = '0' + ENDDO + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: ADN30 - FUNCTION RETURN STRING TOO SHORT') +901 CALL BORT('BUFRLIB: ADN30 - INTEGER REPRESENTATION OF '// + . 'DESCRIPTOR OUT OF 16-BIT RANGE') +902 WRITE(BORT_STR,'("BUFRLIB: ADN30 - CHARACTER LENGTH (",I4,") '// + . 'MUST BE EITHER 5 OR 6")') L30 + CALL BORT(BORT_STR) + END diff --git a/src/bufr/atrcpt.f b/src/bufr/atrcpt.f new file mode 100644 index 0000000000..d59809c691 --- /dev/null +++ b/src/bufr/atrcpt.f @@ -0,0 +1,104 @@ + SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ATRCPT +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE, APPENDS THE +C TANK RECEIPT TIME TO SECTION 1, AND WRITES THE RESULT TO A NEW BUFR +C MESSAGE FOR OUTPUT. THE TANK RECEIPT TIME MUST HAVE BEEN SPECIFIED +C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE STRCPT. THE +C OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE INPUT MESSAGE, SO +C THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE OUTPUT ARRAY. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL ATRCPT (MSGIN, LMSGOT, MSGOT) +C INPUT ARGUMENT LIST: +C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE +C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; +C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT +C OVERFLOW THE MSGOT ARRAY +C +C OUTPUT ARGUMENT LIST: +C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE +C WITH TANK RECEIPT TIME APPENDED TO SECTION 1 +C +C REMARKS: +C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. +C +C THIS ROUTINE CALLS: BORT GETLENS IUPBS01 MVB +C PKB +C THIS ROUTINE IS CALLED BY: MSGWRT +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MSGIN(*), MSGOT(*) + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT + + CHARACTER*1 CTRT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Get some section lengths and addresses from the input message. + + CALL GETLENS(MSGIN,1,LEN0,LEN1,L2,L3,L4,L5) + + IAD1 = LEN0 + IAD2 = IAD1 + LEN1 + + LENM = IUPBS01(MSGIN,'LENM') + +C Check for overflow of the output array. Note that the new +C message will be 6 bytes longer than the input message. + + LENMOT = LENM + 6 + IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 + + LEN1OT = LEN1 + 6 + +C Write Section 0 of the new message into the output array. + + CALL MVB ( MSGIN, 1, MSGOT, 1, 4 ) + IBIT = 32 + CALL PKB ( LENMOT, 24, MSGOT, IBIT ) + CALL MVB ( MSGIN, 8, MSGOT, 8, 1 ) + +C Store the length of the new Section 1. + + IBIT = IAD1*8 + CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) + +C Copy the remainder of Section 1 from the input array to the +C output array. + + CALL MVB ( MSGIN, IAD1+4, MSGOT, (IBIT/8)+1, LEN1-3 ) + +C Append the tank receipt time data to the new Section 1. + + IBIT = IAD2*8 + CALL PKB ( ITRYR, 16, MSGOT, IBIT ) + CALL PKB ( ITRMO, 8, MSGOT, IBIT ) + CALL PKB ( ITRDY, 8, MSGOT, IBIT ) + CALL PKB ( ITRHR, 8, MSGOT, IBIT ) + CALL PKB ( ITRMI, 8, MSGOT, IBIT ) + +C Copy Sections 2, 3, 4 and 5 from the input array to the +C output array. + + CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LENM-IAD2 ) + + RETURN +900 CALL BORT('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE '// + . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + END diff --git a/src/bufr/bfrini.f b/src/bufr/bfrini.f new file mode 100644 index 0000000000..f9b4b0804e --- /dev/null +++ b/src/bufr/bfrini.f @@ -0,0 +1,299 @@ + SUBROUTINE BFRINI + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BFRINI +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE IS CALLED ONLY ONE TIME (DURING THE FIRST +C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF) IN ORDER TO +C INITIALIZE SOME GLOBAL VARIABLES AND ARRAYS WITHIN SEVERAL COMMON +C BLOCKS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- MODIFIED TO MAKE Y2K COMPLIANT +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); INITIALIZES +C VARIABLE JSR AS ZERO IN NEW COMMON BLOCK +C /BUFRSR/ (WAS IN VERIFICATION VERSION); +C UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2004-08-18 J. ATOR -- ADDED INITIALIZATION OF COMMON /MSGSTD/; +C MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- ADDED INITIALIZATION OF COMMON /MSGCMP/ +C AND CALLS TO PKVS1 AND PKVS01 +C 2009-03-23 J. ATOR -- ADDED INITIALIZATION OF COMMON /DSCACH/, +C COMMON /MSTINF/ AND COMMON /TNKRCP/ +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE +C -- ADDED INITIALIZATION OF COMMON BLOCKS +C -- /ENDORD/ AND /BUFRBMISS/ +C +C USAGE: CALL BFRINI +C +C REMARKS: +C THIS ROUTINE CALLS: IFXY IPKM PKVS01 +C THIS ROUTINE IS CALLED BY: OPENBF +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS + COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 + COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) + COMMON /STBFR / IOLUN(NFILES),IOMSG(NFILES) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM), + . IDCACH(MXCNEM,MAXNC) + COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) + COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT + COMMON /DATELN/ LENDAT + COMMON /ACMODE/ IAC + COMMON /BUFRSR/ JUNN,JILL,JIMM,JBIT,JBYT,JMSG,JSUB,KSUB,JNOD,JDAT, + . JSR(NFILES),JBAY(MXMSGLD4) + COMMON /MSGSTD/ CSMF + COMMON /MSGCMP/ CCMF + COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT + COMMON /MSTINF/ LUN1,LUN2,LMTD,MTDIR + COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) + + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*100 MTDIR + CHARACTER*56 DXSTR + CHARACTER*10 TAG + CHARACTER*8 CNEM + CHARACTER*6 ADSN(5,2),DNDX(25,10) + CHARACTER*3 TYPX(5,2),TYPS,TYP + CHARACTER*1 REPX(5,2),REPS + CHARACTER*1 CSMF + CHARACTER*1 CCMF + CHARACTER*1 CTRT + DIMENSION NDNDX(10),NLDXA(10),NLDXB(10),NLDXD(10),NLD30(10) + DIMENSION LENX(5) + + DATA ADSN / '101000','360001','360002','360003','360004' , + . '101255','031002','031001','031001','031000' / + DATA TYPX / 'REP', 'DRP', 'DRP', 'DRS' , 'DRB' , + . 'SEQ', 'RPC', 'RPC', 'RPS' , 'SEQ' / + DATA REPX / '"', '(', '{', '[' , '<' , + . '"', ')', '}', ']' , '>' / + DATA LENX / 0 , 16 , 8 , 8 , 1 / + + DATA (DNDX(I,1),I=1,25)/ + .'102000','031001','000001','000002', + .'110000','031001','000010','000011','000012','000013','000015', + . '000016','000017','000018','000019','000020', + .'107000','031001','000010','000011','000012','000013','101000', + . '031001','000030'/ + + DATA (DNDX(I,2),I=1,15)/ + .'103000','031001','000001','000002','000003', + .'101000','031001','300004', + .'105000','031001','300003','205064','101000','031001','000030'/ + + DATA NDNDX / 25 , 15 , 8*0 / + DATA NLDXA / 35 , 67 , 8*0 / + DATA NLDXB / 80 , 112 , 8*0 / + DATA NLDXD / 38 , 70 , 8*0 / + DATA NLD30 / 5 , 6 , 8*0 / + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C INITIALIZE /ENDORD/ TO CONTROL OUTPUT BLOCKING -1=LE 0=NONE +1=BE +C ----------------------------------------------------------------- + + IBLOCK = 0 + +C INITIALIZE /BUFRBMISS/ +C ---------------------- + + BMISS = 10E10 + +C INITIALIZE /BITBUF/ +C ------------------- + + MAXBYT = 10000 + +C INITIALIZE /MAXCMP/ +C ------------------- + + MAXCMB = MAXBYT + MAXROW = 0 + MAXCOL = 0 + NCMSGS = 0 + NCSUBS = 0 + NCBYTS = 0 + +C INITIALIZE /PADESC/ +C ------------------- + + IBCT = IFXY('063000') + IPD1 = IFXY('102000') + IPD2 = IFXY('031001') + IPD3 = IFXY('206001') + IPD4 = IFXY('063255') + +C INITIALIZE /STBFR/ +C ------------------ + + DO I=1,NFILES + IOLUN(I) = 0 + IOMSG(I) = 0 + ENDDO + +C INITIALIZE /REPTAB/ +C ------------------- + + DO I=1,5 + LENS(I) = LENX(I) + DO J=1,2 + IDNR(I,J) = IFXY(ADSN(I,J)) + TYPS(I,J) = TYPX(I,J) + REPS(I,J) = REPX(I,J) + ENDDO + ENDDO + +C INITIALIZE /TABABD/ (INTERNAL ARRAYS HOLDING DICTIONARY TABLE) +C -------------------------------------------------------------- + +C NTBA(0) is the maximum number of entries w/i internal BUFR table A + + NTBA(0) = MAXTBA + +C NTBB(0) is the maximum number of entries w/i internal BUFR Table B + + NTBB(0) = MAXTBB + +C NTBD(0) is the maximum number of entries w/i internal BUFR Table D + + NTBD(0) = MAXTBD + +C INITIALIZE /DXTAB/ +C ------------------ + + MAXDX = MAXBYT +c .... IDXV is the version number of the local tables + IDXV = 1 + + DO J=1,10 + LDXA(J) = NLDXA(J) + LDXB(J) = NLDXB(J) + LDXD(J) = NLDXD(J) + LD30(J) = NLD30(J) + DXSTR(J) = ' ' + NXSTR(J) = NDNDX(J)*2 + DO I=1,NDNDX(J) + I1 = I*2-1 + CALL IPKM(DXSTR(J)(I1:I1),2,IFXY(DNDX(I,J))) + ENDDO + ENDDO + +C INITIALIZE /TABLES/ +C ------------------- + + MAXTAB = MAXJL + +C INITIALIZE /BUFRMG/ +C ------------------- + + MSGLEN = 0 + +C INITIALIZE /MRGCOM/ +C ------------------- + + NRPL = 0 + NMRG = 0 + NAMB = 0 + NTOT = 0 + +C INITIALIZE /DATELN/ +C ------------------- + + IF(LENDAT.NE.10) LENDAT = 8 + +C INITIALIZE /ACMODE/ +C ------------------_ + +c .... DK: What does this control?? + IAC = 0 + +C INITIALIZE /BUFRSR/ +C ------------------- + + DO I=1,NFILES + JSR(I) = 0 + ENDDO + +C INITIALIZE /DSCACH/ +C ------------------- + + NCNEM = 0 + +C INITIALIZE /MSGSTD/ +C ------------------- + + CSMF = 'N' + +C INITIALIZE /MSGCMP/ +C ------------------- + + CCMF = 'N' + +C INITIALIZE /TNKRCP/ +C ------------------- + + CTRT = 'N' + +C INITIALIZE /MSTINF/ +C ------------------- + + MTDIR = '/nwprod/fix' + LMTD = 11 + + LUN1 = 98 + LUN2 = 99 + +C INITIALIZE /S01CM/ +C ------------------- + + CALL PKVS01('INIT',-99) + + RETURN + END diff --git a/src/bufr/blocks.f b/src/bufr/blocks.f new file mode 100644 index 0000000000..c602d14d3f --- /dev/null +++ b/src/bufr/blocks.f @@ -0,0 +1,117 @@ + SUBROUTINE BLOCKS(MBAY,MWRD) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BLOCKS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 +C +C ABSTRACT: BLOCKS WILL ADD IEEE FORTRAN TYPE RECORD CONTROL +C WORDS TO A PURE BUFR RECORD PASSED FROM MSGWRT, IN +C PREPARATION FOR OUTPUTING THE RECORD TO DISK. THE +C DEFAULT OUTPUT TYPE IS PURE (NO CONTROL WORDS), IN +C WHICH CASE THIS ROUTINE DOES NOTHING. AN APPLICATION +C CAN SPECIFY THAT EITHER BIG OR LITTLE ENDIAN RECORD +C CONTROL WORDS ARE TO BE APPENDED TO PURE BUFR RECORDS +C VIA A PREVIOUS CALL TO SUBROUTINE SETBLOCK. +C +C THE FOLLOWING DIAGRAM ILLUSTRATES IEEE CONTROL WORDS FOUND +C IN AN UNFORMATTED FORTRAN RECORD CONRTAINING FOUR 4-BYTE WORDS +C +C ctw1-wrd1-wrd2-wrd3-wrd4-ctw2 +C | | | | | | +C 0016-aaaa-bbbb-cccc-dddd-0016 +C +C CTW1 AND CTW2 CONTAIN A BYTE COUNT FOR THE DATA RECORD THAT +C THEY ENCLOSE. THEY CAN BE STORED IN EITHER BIG OR LITTLE +C ENDIAN BYTE ORDERING (NOTE: CTWS ARE ALWAYS 4-BYTE WORDS) +C +C PROGRAM HISTORY LOG: +C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR +C +C USAGE: CALL BLOCKS(MBAY,MWRD) +C INPUT ARGUMENTS: +c MBAY - INTEGER ARRAY CONTAINING PURE BUFR MESSAGE +c MWRD - INTEGER WORD COUNT FOR MBAY +C +C OUTPUT ARGUMENTS: +c MBAY - INTEGER ARRAY CONTAINING INPUT BUFR MESSAGE, POSSIBLY +c WITH CONTROL WORDS ADDED DEPENDING ON WHETHER SUBROUTINE +c SETBLOCK WAS PREVIOUSLY CALLED +c MWRD - INTEGER WORD COUNT FOR MBAY +C +C REMARKS: +C THIS ROUTINE CALLS: None +C +C THIS ROUTINE IS CALLED BY: MSGWRT +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) + + INTEGER*4 MBAY(MWRD),IINT,JINT + + CHARACTER*1 CINT(4),DINT(4) + EQUIVALENCE(CINT,IINT) + EQUIVALENCE(DINT,JINT) + + DATA IFIRST/0/ + SAVE IFIRST + +c---------------------------------------------------------------------- +c---------------------------------------------------------------------- + + if(iblock.eq.0) return + + if(ifirst.eq.0) then + +c Initialize some arrays for later use. Note that Fortran +c record control words are always 4 bytes. + + iint=0; cint(1)=char(1) + do i=1,4 + if(cint(1).eq.char(01)) then + iordbe(i)=4-i+1 + iordle(i)=i + else + iordle(i)=4-i+1 + iordbe(i)=i + endif + enddo + ifirst=1 + endif + +c make room in mbay for control words - one at each end of the record +c ------------------------------------------------------------------- + + if(nbytw.eq.8) mwrd=mwrd*2 + + do m=mwrd,1,-1 + mbay(m+1) = mbay(m) + enddo + +c store the endianized control word in bytes in dint/jint +c ------------------------------------------------------- + + iint=mwrd*4 + + do i=1,4 + if(iblock.eq.+1) dint(i)=cint(iordbe(i)) + if(iblock.eq.-1) dint(i)=cint(iordle(i)) + enddo + +c increment mrwd and install the control words in their proper places +c ------------------------------------------------------------------- + + mwrd = mwrd+2 + mbay(1) = jint + mbay(mwrd) = jint + + if(nbytw.eq.8) mwrd=mwrd/2 + + return + end diff --git a/src/bufr/bort.f b/src/bufr/bort.f new file mode 100644 index 0000000000..e1a0554002 --- /dev/null +++ b/src/bufr/bort.f @@ -0,0 +1,88 @@ + SUBROUTINE BORT(STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BORT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 +C +C ABSTRACT: THIS SUBROUTINE WRITES (VIA BUFR ARCHIVE LIBRARY SUBROUTINE +C ERRWRT) A GIVEN ERROR STRING AND THEN CALLS BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT_EXIT TO ABORT THE APPLICATION PROGRAM CALLING THE +C BUFR ARCHIVE LIBRARY SOFTWARE. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT2, EXCEPT BORT2 WRITES TWO ERROR STRINGS. +C +C PROGRAM HISTORY LOG: +C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR (REPLACED CRAY LIBRARY +C ROUTINE ABORT) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION; REPLACED CALL TO +C INTRINSIC C ROUTINE "EXIT" WITH CALL TO +C BUFRLIB C ROUTINE "BORT_EXIT" WHICH ALWAYS +C RETURNS A NON-ZERO STATUS BACK TO EXECUTING +C SHELL SCRIPT +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL BORT (STR) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): ERROR MESSAGE TO BE WRITTEN VIA +C SUBROUTINE ERRWRT +C +C REMARKS: +C THIS ROUTINE CALLS: BORT_EXIT ERRWRT +C THIS ROUTINE IS CALLED BY: ADN30 ATRCPT BVERS CHEKSTAB +C CKTABA CLOSMG CMPMSG CMSGINI +C CNVED4 COBFL COPYBF COPYMG +C COPYSB CPDXMM CPYMEM CPYUPD +C CRBMG CWBMG DATEBF DATELEN +C DRFINI DRSTPL DUMPBF DXDUMP +C DXMINI GETWIN GETTBH IDN30 +C IFBGET IGETNTBI IGETSC IGETTDI +C INCTAB INVMRG IPKM ISIZE +C IUPVS01 IUPM JSTNUM LCMGDF +C LSTJPB MAKESTAB MINIMG MSGINI +C MSGWRT MVB NEMTBA NEMTBAX +C NEMTBB NEMTBD NENUBD NEVN +C NEWWIN NMSUB NUMMTB NVNWIN +C NXTWIN OPENBF OPENMB OPENMG +C PAD PADMSG PARUTG PKBS1 +C PKVS01 POSAPX RCSTPL RDBFDX +C RDCMPS RDMEMM RDMEMS RDMGSB +C RDMSGB RDMSGW RDMTBB RDMTBD +C READDX READERME READLC READMG +C READNS READSB READS3 REWNBF +C RTRCPT SNTBBE SNTBDE STATUS +C STBFDX STDMSG STNDRD STNTBIA +C STRCPT STSEQ TABENT TABSUB +C TRYBUMP UFBCNT UFBCPY UFBCUP +C UFBDMP UFBEVN UFBGET UFBIN3 +C UFBINT UFBINX UFBMEM UFBMEX +C UFBMMS UFBMNS UFBOVR UFBPOS +C UFBQCD UFBQCP UFBREP UFBRMS +C UFBSEQ UFBSTP UFBTAB UFBTAM +C UFDUMP UPDS3 UPFTBV UPTDD +C USRTPL WRCMPS WRDESC WRDLEN +C WRDXTB WRITDX WRITLC WRITSA +C WRITSB WTSTAT +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + + CALL ERRWRT(' ') + CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') + CALL ERRWRT(STR) + CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') + CALL ERRWRT(' ') + + CALL BORT_EXIT + + END diff --git a/src/bufr/bort2.f b/src/bufr/bort2.f new file mode 100644 index 0000000000..5b9d90750e --- /dev/null +++ b/src/bufr/bort2.f @@ -0,0 +1,52 @@ + SUBROUTINE BORT2(STR1,STR2) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BORT2 +C PRGMMR: KEYSER ORG: NP22 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE WRITES (VIA BUFR ARCHIVE LIBRARY SUBROUTINE +C ERRWRT) TWO GIVEN ERROR STRINGS AND THEN CALLS BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT_EXIT TO ABORT THE APPLICATION PROGRAM CALLING THE +C BUFR ARCHIVE LIBRARY SOFTWARE. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT, EXCEPT BORT PRINTS ONLY ONE ERROR STRING. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 D. KEYSER -- ORIGINAL AUTHOR +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL BORT2 (STR1, STR2) +C INPUT ARGUMENT LIST: +C STR1 - CHARACTER*(*): FIRST ERROR MESSAGE TO BE WRITTEN VIA +C SUBROUTINE ERRWRT +C STR2 - CHARACTER*(*): SECOND ERROR MESSAGE TO BE WRITTEN VIA +C SUBROUTINE ERRWRT +C +C REMARKS: +C THIS ROUTINE CALLS: BORT_EXIT ERRWRT +C THIS ROUTINE IS CALLED BY: ELEMDX GETNTBE MTINFO PARSTR +C PARUSR PARUTG RDUSDX READMT +C SEQSDX SNTBBE SNTBDE STRING +C UFBINT UFBOVR UFBREP UFBSTP +C VALX +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR1, STR2 + + CALL ERRWRT(' ') + CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') + CALL ERRWRT(STR1) + CALL ERRWRT(STR2) + CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') + CALL ERRWRT(' ') + + CALL BORT_EXIT + + END diff --git a/src/bufr/bort_exit.c b/src/bufr/bort_exit.c new file mode 100644 index 0000000000..e0e1679eaa --- /dev/null +++ b/src/bufr/bort_exit.c @@ -0,0 +1,35 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BORT_EXIT +C PRGMMR: ATOR ORG: NP12 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE WILL TERMINATE THE APPLICATION PROGRAM AND +C RETURN AN IMPLEMENTATION-DEFINED NON-ZERO STATUS CODE TO THE +C EXECUTING SHELL SCRIPT. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. ATOR -- ORIGINAL AUTHOR +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF +C 2004-08-18 J. ATOR -- USE bufrlib.h INCLUDE FILE +C 2007-01-19 J. ATOR -- FIX DECLARATION FOR ANSI-C +C +C USAGE: CALL BORT_EXIT +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: BORT BORT2 +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +void bort_exit( void ) +{ + exit( EXIT_FAILURE ); +} diff --git a/src/bufr/bufrlib.h b/src/bufr/bufrlib.h new file mode 100644 index 0000000000..c787444c94 --- /dev/null +++ b/src/bufr/bufrlib.h @@ -0,0 +1,143 @@ +#include +#include +#include +#include + +/* +** Define a global variable for sharing of file pointers across different +** subprograms within the BUFRLIB software. +*/ +#ifdef BUFRLIB_GLOBAL + FILE *pbf[2]; /* each element will automatically initialize to NULL */ +#else + extern FILE *pbf[2]; +#endif + +/* +** On certain operating systems, the FORTRAN compiler appends an underscore +** to subprogram names in its object namespace. Therefore, on such systems, +** a matching underscore must be appended to any C language references to the +** same subprogram names so that the linker can correctly resolve such +** references across the C <-> FORTRAN interface at link time. +*/ +#ifdef UNDERSCORE +#define bort bort_ +#define bort_exit bort_exit_ +#define cadn30 cadn30_ +#define ccbfl ccbfl_ +#define cmpia cmpia_ +#define cobfl cobfl_ +#define crbmg crbmg_ +#define cwbmg cwbmg_ +#define elemdx elemdx_ +#define gets1loc gets1loc_ +#define ichkstr ichkstr_ +#define icvidx icvidx_ +#define ifxy ifxy_ +#define igetntbi igetntbi_ +#define igettdi igettdi_ +#define ipkm ipkm_ +#define istdesc istdesc_ +#define iupbs01 iupbs01_ +#define iupm iupm_ +#define mstabs mstabs_ +#define nemtab nemtab_ +#define nemtbb nemtbb_ +#define nummtb nummtb_ +#define numtbd numtbd_ +#define pktdd pktdd_ +#define rbytes rbytes_ +#define restd restd_ +#define stntbi stntbi_ +#define strnum strnum_ +#define stseq stseq_ +#define uptdd uptdd_ +#define wrdesc wrdesc_ +#define wrdlen wrdlen_ +#define openrb openrb_ +#define openwb openwb_ +#define openab openab_ +#define backbufr backbufr_ +#define cewind cewind_ +#define closfb closfb_ +#define crdbufr crdbufr_ +#define cwrbufr cwrbufr_ +#endif + +/* +** In order to ensure that the C <-> FORTRAN interface works properly (and +** portably!), the default size of an "INTEGER" declared in FORTRAN must be +** identical to that of an "int" declared in C. If this is not the case (e.g. +** some FORTRAN compilers, most notably AIX via the -qintsize= option, allow the +** sizes of INTEGERs to be definitively prescribed outside of the source code +** itself!), then the following conditional directive (or a variant of it) can +** be used to ensure that the size of an "int" in C remains identical to that +** of an "INTEGER" in FORTRAN. +*/ +#ifdef F77_INTSIZE_8 + typedef long f77int; +#else + typedef int f77int; +#endif + +/* +** Declare prototypes for ANSI C compatibility. +*/ +void bort( char *, f77int ); +void bort_exit( void ); +void cadn30( f77int *, char *, f77int ); +void ccbfl( void ); +int cmpia( const f77int *, const f77int * ); +void cobfl( char *, char * ); +void crbmg( char *, f77int *, f77int *, f77int * ); +void cwbmg( char *, f77int *, f77int * ); +void elemdx( char *, f77int *, f77int ); +void gets1loc( char *, f77int *, f77int *, f77int *, f77int *, f77int ); +f77int ichkstr ( char *, char *, f77int *, f77int, f77int ); +f77int ifxy( char *, f77int ); +f77int igetntbi( f77int *, char *, f77int ); +f77int igettdi( f77int * ); +void ipkm( char *, f77int *, f77int *, f77int ); +f77int istdesc( f77int * ); +f77int iupbs01 ( f77int *, char *, f77int ); +f77int iupm ( char *, f77int *, f77int ); +void nemtab( f77int *, char *, f77int *, char *, f77int *, f77int, f77int ); +void nemtbb( f77int *, f77int *, char *, f77int *, f77int *, f77int *, f77int ); +void nummtb( f77int *, char *, f77int * ); +void numtbd( f77int *, f77int *, char *, char *, f77int *, f77int, f77int ); +void pktdd( f77int *, f77int *, f77int *, f77int * ); +f77int rbytes( char *, f77int *, f77int, f77int ); +void restd( f77int *, f77int *, f77int *, f77int * ); +void strnum( char *, f77int *, f77int ); +void stseq( f77int *, f77int *, f77int *, char *, char *, f77int *, f77int * ); +void uptdd( f77int *, f77int *, f77int *, f77int * ); +void wrdesc( f77int, f77int *, f77int * ); +void wrdlen( void ); + +/* +** The following parameters must also be identically defined within +** "bufrlib.PRM" for use by several FORTRAN routines. See "bufrlib.PRM" +** for a description of these parameters. +*/ +#define MAXNC 600 +#define MXMTBB 4000 +#define MXMTBD 1000 +#define MAXCD 250 +#define MXNAF 3 +#define NFILES 32 + +/* +** Enable access to FORTRAN COMMON block /MSTABS/ from within C. +*/ +#ifdef COMMON_MSTABS + extern struct { + f77int nmtb; f77int ibfxyn[MXMTBB]; char cbscl[MXMTBB][4]; + char cbsref[MXMTBB][12]; char cbbw[MXMTBB][4]; + char cbunit[MXMTBB][14]; char cbmnem[MXMTBB][8]; + char cbelem[MXMTBB][120]; + f77int nmtd; f77int idfxyn[MXMTBD]; char cdseq[MXMTBD][120]; + char cdmnem[MXMTBD][8]; f77int ndelem[MXMTBD]; + f77int idefxy[MXMTBD*MAXCD]; + char cdelem[MXMTBD*MAXCD][120]; + } mstabs; +#endif diff --git a/src/bufr/bufrlib0.PRM b/src/bufr/bufrlib0.PRM new file mode 100755 index 0000000000..370656a3d4 --- /dev/null +++ b/src/bufr/bufrlib0.PRM @@ -0,0 +1,202 @@ +C----------------------------------------------------------------------- +C Define the BUFRLIB build types. + +#define NORMAL 1 +#define SUPERSIZE 2 +#define C32BITS 3 +C----------------------------------------------------------------------- +C Maximum number of BUFR files that can be connected to the +C BUFRLIB software (for reading or writing) at any one time. +C (NOTE: This parameter must also be identically defined +C within "bufrlib.h" for use by several C routines!) + +#if BUILD == C32BITS + PARAMETER ( NFILES = 10 ) +#else + PARAMETER ( NFILES = 32 ) +#endif +C----------------------------------------------------------------------- +C Maximum length (in bytes) of a BUFR message that can be +C read or written by the BUFRLIB software. + +#if BUILD == SUPERSIZE + PARAMETER ( MXMSGL = 2500000 ) +#else + PARAMETER ( MXMSGL = 600000 ) +#endif + PARAMETER ( MXMSGLD4 = MXMSGL/4 ) +C----------------------------------------------------------------------- +C Maximum number of Section 3 FXY descriptors that can be +C written into a BUFR message by the BUFRLIB software. +C (NOTE: This parameter must also be identically defined +C within "bufrlib.h" for use by several C routines!) + + PARAMETER ( MAXNC = 600 ) +C----------------------------------------------------------------------- +C Maximum number of default Section 0 or Section 1 values +C that can be overwritten within a BUFR message by the +C BUFRLIB software. + + PARAMETER ( MXS01V = 10 ) +C----------------------------------------------------------------------- +C Maximum number of data values that can be read from or written +C into a subset by the BUFRLIB software. + +#if BUILD == SUPERSIZE + PARAMETER ( MAXSS = 120000 ) +#else + PARAMETER ( MAXSS = 80000 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of data values that can be written into a subset +C of a compressed BUFR message by the BUFRLIB software. + +#if BUILD == SUPERSIZE + PARAMETER ( MXCDV = 50000 ) +#elif BUILD == C32BITS + PARAMETER ( MXCDV = 1000 ) +#else + PARAMETER ( MXCDV = 3000 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of subsets that can be written into a compressed +C BUFR message by the BUFRLIB software. + +#if BUILD == C32BITS + PARAMETER ( MXCSB = 2000 ) +#else + PARAMETER ( MXCSB = 4000 ) +#endif +C----------------------------------------------------------------------- +C Maximum length of a character string that can be written into a +C compressed BUFR message by the BUFRLIB software. + +#if BUILD == SUPERSIZE + PARAMETER ( MXLCC = 12 ) +#elif BUILD == C32BITS + PARAMETER ( MXLCC = 24 ) +#else + PARAMETER ( MXLCC = 32 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of entries in the internal BUFR Table A for each +C BUFR file that is connected to the BUFRLIB software. + + PARAMETER ( MAXTBA = 150 ) +C----------------------------------------------------------------------- +C Maximum number of entries in the internal BUFR Table B for each +C BUFR file that is connected to the BUFRLIB software. + + PARAMETER ( MAXTBB = 500 ) +C----------------------------------------------------------------------- +C Maximum number of entries in the internal BUFR Table D for each +C BUFR file that is connected to the BUFRLIB software. + + PARAMETER ( MAXTBD = 500 ) +C----------------------------------------------------------------------- +C Maximum number of entries in the master BUFR Table B. +C (NOTE: This parameter must also be identically defined +C within "bufrlib.h" for use by several C routines!) + + PARAMETER ( MXMTBB = 4000 ) +C----------------------------------------------------------------------- +C Maximum number of entries in the master BUFR Table D. +C (NOTE: This parameter must also be identically defined +C within "bufrlib.h" for use by several C routines!) + + PARAMETER ( MXMTBD = 1000 ) +C----------------------------------------------------------------------- +C Maximum number of child descriptors that can be included +C within the sequence definition of a Table D descriptor. +C (NOTE: This value does *not* need to take into account +C the recursive resolution of any child descriptors +C which may themselves be Table D descriptors!) +C (NOTE: This parameter must also be identically defined +C within "bufrlib.h" for use by several C routines!) + + PARAMETER ( MAXCD = 250 ) +C----------------------------------------------------------------------- +C Maximum number of entries in the internal jump/link table. + +#if BUILD == SUPERSIZE + PARAMETER ( MAXJL = NFILES*4000 ) +#else + PARAMETER ( MAXJL = NFILES*3000 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of entries in the internal string cache. + + PARAMETER ( MXS = 1000 ) +C----------------------------------------------------------------------- +C Maximum number of entries in the internal descriptor list cache. + + PARAMETER ( MXCNEM = MAXTBA*3 ) +C----------------------------------------------------------------------- +C Maximum number of "long" character strings (i.e. greater than +C 8 bytes) which can be read from a subset of a compressed BUFR +C message. + +#if BUILD == SUPERSIZE + PARAMETER ( MXRST = 500 ) +#else + PARAMETER ( MXRST = 50 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of BUFR messages that can be stored within +C internal memory. + +#if BUILD == C32BITS + PARAMETER ( MAXMSG = 20000 ) +#else + PARAMETER ( MAXMSG = 200000 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of bytes that can be used to store BUFR +C messages within internal memory. + +#if BUILD == SUPERSIZE + PARAMETER ( MAXMEM = 75000000 ) +#elif BUILD == C32BITS + PARAMETER ( MAXMEM = 400000 ) +#else + PARAMETER ( MAXMEM = 50000000 ) +#endif +C----------------------------------------------------------------------- +C Maximum number of jump/link table entries which can be used to +C store new reference values (as defined using the 2-03 operator). + + PARAMETER ( MXNRV = 12 ) +C----------------------------------------------------------------------- +C Maximum number of 2-04 associated fields that can be in effect +C at the same time for any given Table B descriptor. + + PARAMETER ( MXNAF = 3 ) +C----------------------------------------------------------------------- +C Maximum number of dictionary tables that can be stored for use +C with BUFR messages in internal memory. + + PARAMETER ( MXDXTS = 200 ) +C----------------------------------------------------------------------- +C Maximum number of dictionary messages that can be stored for use +C with BUFR messages in internal memory. + + PARAMETER ( MXDXM = MXDXTS*3 ) + + PARAMETER ( MXDXW = MXDXM*MXMSGLD4) +C----------------------------------------------------------------------- +C Maximum number of bytes that can be copied between BUFR +C messages within internal memory. + +#if BUILD == SUPERSIZE + PARAMETER ( MXIMB = 750000 ) +#else + PARAMETER ( MXIMB = 400000 ) +#endif +C----------------------------------------------------------------------- +C BUFRLIB "missing" value. The default value for BMISS is set +C within subroutine BFRINI, but it can be modified by the user via +C a subsequent call to subroutine SETBMISS. + + COMMON /BUFRBMISS/ BMISS + REAL*8 BMISS +C----------------------------------------------------------------------- diff --git a/src/bufr/bvers.f b/src/bufr/bvers.f new file mode 100644 index 0000000000..16d9dcf7c0 --- /dev/null +++ b/src/bufr/bvers.f @@ -0,0 +1,50 @@ + SUBROUTINE BVERS (CVERSTR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BVERS +C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER STRING CONTAINING THE +C VERSION NUMBER OF THE BUFR ARCHIVE LIBRARY SOFTWARE. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C 2011-09-26 J. ATOR -- UPDATED TO VERSION 10.0.1 +C 2012-02-24 J. ATOR -- UPDATED TO VERSION 10.1.0 +C 2012-10-12 J. ATOR -- UPDATED TO VERSION 10.2.0 +C 2012-11-29 J. ATOR -- UPDATED TO VERSION 10.2.1 +C 2012-12-04 J. ATOR -- UPDATED TO VERSION 10.2.2 +C 2013-01-08 J. ATOR -- UPDATED TO VERSION 10.2.3 +C 2013-01-09 J. ATOR -- UPDATED TO VERSION 10.2.4 +C 2013-01-25 J. ATOR -- UPDATED TO VERSION 10.2.5 +C +C USAGE: CALL BVERS (CVERSTR) +C +C OUTPUT ARGUMENT LIST: +C CVERSTR - CHARACTER*(*): VERSION STRING +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: WRDLEN +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) CVERSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF (LEN(CVERSTR).LT.8) GOTO 900 + + CVERSTR = '10.2.5' + + RETURN +900 CALL BORT('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE '// + . 'FOR AT LEAST 8 CHARACTERS') + END diff --git a/src/bufr/cadn30.f b/src/bufr/cadn30.f new file mode 100644 index 0000000000..4ea344f8ca --- /dev/null +++ b/src/bufr/cadn30.f @@ -0,0 +1,45 @@ + SUBROUTINE CADN30( IDN, ADN ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CADN30 +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF THE FXY VALUE +C FOR A DESCRIPTOR, THIS ROUTINE CALLS FUNCTION ADN30 AND STORES +C ITS RETURN VALUE (I.E. THE ASCII-EQUIVALENT FXY VALUE) AS THE +C ROUTINE OUTPUT VALUE. THIS MECHANISM (I.E. A FORTRAN SUBROUTINE +C WRAPPER RETURNING ADN AS A CALL PARAMETER, RATHER THAN DIRECTLY +C CALLING THE FORTRAN FUNCTION ADN30 FROM WITHIN A C ROUTINE) +C ALLOWS SAFE AND PORTABLE (ALBEIT INDIRECT) ACCESS TO THE ADN30 +C FUNCTION LOGIC FROM WITHIN A C ROUTINE. +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CADN30( IDN, ADN ) +C INPUT ARGUMENT LIST: +C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE +C +C OUTPUT ARGUMENT LIST: +C ADN - CHARACTER*(*): ASCII-CHARACTER FORM OF IDN +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 +C THIS ROUTINE IS CALLED BY: NUMMTB RESTD STSEQ +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) ADN + CHARACTER*6 ADN30 + + ADN = ADN30( IDN, 6 ) + + RETURN + END diff --git a/src/bufr/capit.f b/src/bufr/capit.f new file mode 100644 index 0000000000..373743f7ee --- /dev/null +++ b/src/bufr/capit.f @@ -0,0 +1,64 @@ + SUBROUTINE CAPIT(STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CAPIT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE CAPITALIZES A STRING OF CHARACTERS. THIS +C ENABLES THE USE OF MIXED CASE IN THE UNIT SECTION OF THE ASCII +C BUFR TABLES. AN EXAMPLE: A PROGRAM WHICH GENERATES AN ASCII BUFR +C TABLE FROM THE "MASTER TABLE B" MIGHT END UP COPYING SOME UNITS +C FIELDS IN MIXED OR LOWER CASE. IF THE UNITS ARE 'CODE TABLE' OR +C 'FLAG TABLE' OR CERTAIN OTHER UNIT DESIGNATIONS, THE TABLE WILL BE +C PARSED INCORRECTLY, AND THE DATA READ OR INCORRECTLY AS A RESULT. +C THIS MAKES SURE ALL UNIT DESIGNATIONS ARE SEEN BY THE PARSER IN +C UPPER CASE TO AVOID THESE TYPES OF PROBLEMS. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2012-03-02 J. ATOR -- CHANGED NAME OF UPS ARRAY TO UPCS TO AVOID +C NAMESPACE CONTENTION WITH NEW FUNCTION UPS +C +C USAGE: CALL CAPIT (STR) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING POSSIBLY CONTAINING MIXED UPPER- +C AND LOWER-CASE CHARACTERS +C +C OUTPUT ARGUMENT LIST: +C STR - CHARACTER*(*): SAME STRING AS INPUT BUT NOW CONTAINING +C ALL UPPER-CASE CHARACTERS +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: CMPMSG ELEMDX STBFDX STDMSG +C STRCPT +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + CHARACTER*26 UPCS,LWCS + DATA UPCS/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + DATA LWCS/'abcdefghijklmnopqrstuvwxyz'/ + + DO 20 I=1,LEN(STR) + DO 10 J=1,26 + IF(STR(I:I).EQ.LWCS(J:J)) THEN + STR(I:I) = UPCS(J:J) + GOTO 20 + ENDIF +10 CONTINUE +20 CONTINUE + + RETURN + END diff --git a/src/bufr/ccbfl.c b/src/bufr/ccbfl.c new file mode 100644 index 0000000000..279280e759 --- /dev/null +++ b/src/bufr/ccbfl.c @@ -0,0 +1,36 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CCBFL +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS ROUTINE CLOSES (AND FLUSHES ANY REMAINING OUTPUT TO!) +C ANY SYSTEM FILES THAT ARE STILL OPEN FROM ANY PREVIOUS CALLS TO BUFR +C ARCHIVE LIBRARY SUBROUTINE COBFL. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL CCBFL +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +void ccbfl( void ) +{ + unsigned short i; + + for ( i = 0; i < 2; i++ ) { + if ( pbf[i] != NULL ) fclose( pbf[i] ); + } +} diff --git a/src/bufr/chekstab.f b/src/bufr/chekstab.f new file mode 100644 index 0000000000..bb0032be15 --- /dev/null +++ b/src/bufr/chekstab.f @@ -0,0 +1,111 @@ + SUBROUTINE CHEKSTAB(LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CHEKSTAB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CHECKS THAT AN INTERNAL BUFR TABLE +C REPRESENTATION IS SELF-CONSISTENT AND FULLY DEFINED. IF ANY ERRORS +C ARE FOUND, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL CHEKSTAB (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: BORT NEMTAB NEMTBB NEMTBD +C THIS ROUTINE IS CALLED BY: MAKESTAB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*128 BORT_STR + CHARACTER*24 UNIT + CHARACTER*8 NEMO,NEMS(MAXCD) + CHARACTER*1 TAB + DIMENSION IRPS(MAXCD),KNTS(MAXCD) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C THERE MUST BE ENTRIES IN TABLES A, B, AND D +C ------------------------------------------- + + IF(NTBA(LUN).EQ.0) GOTO 900 + IF(NTBB(LUN).EQ.0) GOTO 901 + IF(NTBD(LUN).EQ.0) GOTO 902 + +C MAKE SURE EACH TABLE A ENTRY DEFINED AS A SEQUENCE +C -------------------------------------------------- + + DO I=1,NTBA(LUN) + NEMO = TABA(I,LUN)(4:11) + CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) + IF(TAB.NE.'D') GOTO 903 + ENDDO + +C CHECK TABLE B CONTENTS +C ---------------------- + + DO ITAB=1,NTBB(LUN) + CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) + ENDDO + +C CHECK TABLE D CONTNETS +C ---------------------- + + DO ITAB=1,NTBD(LUN) + CALL NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) + ENDDO + +C EXITS +C ----- + + RETURN +900 CALL BORT + . ('BUFRLIB: CHEKSTAB - EMPTY TABLE A IN INTERNAL BUFR TABLES') +901 CALL BORT + . ('BUFRLIB: CHEKSTAB - EMPTY TABLE B IN INTERNAL BUFR TABLES') +902 CALL BORT + . ('BUFRLIB: CHEKSTAB - EMPTY TABLE D IN INTERNAL BUFR TABLES') +903 WRITE(BORT_STR,'("BUFRLIB: CHEKSTAB - TABLE A ENTRY: ",A," NOT '// + . 'DEFINED AS A SEQUENCE")') NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/chrtrn.f b/src/bufr/chrtrn.f new file mode 100644 index 0000000000..5f61fc1fd4 --- /dev/null +++ b/src/bufr/chrtrn.f @@ -0,0 +1,48 @@ + SUBROUTINE CHRTRN(STR,CHR,N) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CHRTRN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF CHARACTERS +C FROM A CHARACTER ARRAY INTO A CHARACTER STRING. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C +C USAGE: CALL CHRTRN (STR, CHR, N) +C INPUT ARGUMENT LIST: +C CHR - CHARACTER*1: N-WORD CHARACTER ARRAY +C N - INTEGER: NUMBER OF CHARACTERS TO COPY +C +C OUTPUT ARGUMENT LIST: +C STR - CHARACTER*(*): CHARACTER STRING +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: STBFDX +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + CHARACTER*1 CHR(N) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + DO I=1,N + STR(I:I) = CHR(I) + ENDDO + RETURN + END diff --git a/src/bufr/chrtrna.f b/src/bufr/chrtrna.f new file mode 100644 index 0000000000..582ce70f70 --- /dev/null +++ b/src/bufr/chrtrna.f @@ -0,0 +1,64 @@ + SUBROUTINE CHRTRNA(STR,CHR,N) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CHRTRNA +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF CHARACTERS +C FROM A CHARACTER ARRAY INTO A CHARACTER STRING. THE DIFFERENCE +C BETWEEN THIS SUBROUTINE AND BUFR ARCHIVE LIBRARY SUBROUTINE CHRTRN +C IS THAT, IN THIS SUBROUTINE, THE INPUT CHARACTER ARRAY IS ASSUMED +C TO BE IN ASCII; THUS, FOR CASES WHERE THE NATIVE MACHINE IS EBCDIC, +C AN ASCII TO EBCDIC TRANSLATION IS DONE ON THE FINAL STRING BEFORE +C IT IS OUTPUT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C +C USAGE: CALL CHRTRNA (STR, CHR, N) +C INPUT ARGUMENT LIST: +C CHR - CHARACTER*1: N-WORD CHARACTER ARRAY IN ASCII +C N - INTEGER: NUMBER OF CHARACTERS TO COPY +C +C OUTPUT ARGUMENT LIST: +C STR - CHARACTER*(*): CHARACTER STRING IN ASCII OR EBCDIC, +C DEPENDING ON NATIVE MACHINE +C +C REMARKS: +C THIS ROUTINE CALLS: IPKM IUPM +C THIS ROUTINE IS CALLED BY: ICHKSTR STBFDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) + + CHARACTER*(*) STR + CHARACTER*1 CHR(N) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C Loop on N characters of CHR + + DO I=1,N + STR(I:I) = CHR(I) + +C If this is an EBCDIC machine, then translate the character +C from ASCII -> EBCDIC. + + IF(IASCII.EQ.0) CALL IPKM(STR(I:I),1,IATOE(IUPM(STR(I:I),8))) + ENDDO + RETURN + END diff --git a/src/bufr/cktaba.f b/src/bufr/cktaba.f new file mode 100644 index 0000000000..af8988a868 --- /dev/null +++ b/src/bufr/cktaba.f @@ -0,0 +1,292 @@ + SUBROUTINE CKTABA(LUN,SUBSET,JDATE,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CKTABA +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 +C +C ABSTRACT: THIS SUBROUTINE PARSES THE TABLE A MNEMONIC AND THE DATE +C OUT OF SECTION 1 OF A BUFR MESSAGE PREVIOUSLY READ FROM UNIT LUNIT +C USING BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR EQUIVALENT (AND NOW +C STORED IN THE INTERNAL MESSAGE BUFFER, ARRAY MBAY IN COMMON BLOCK +C /BITBUF/). THE TABLE A MNEMONIC IS ASSOCIATED WITH THE BUFR +C MESSAGE TYPE/SUBTYPE IN SECTION 1. IT ALSO FILLS IN THE MESSAGE +C CONTROL WORD PARTITION ARRAYS IN COMMON BLOCK /MSGCWD/. +C +C PROGRAM HISTORY LOG: +C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR - CONSOLIDATED MESSAGE +C DECODING LOGIC THAT HAD BEEN REPLICATED IN +C READMG, READFT, READERME, RDMEMM AND READIBM +C (CKTABA IS NOW CALLED BY THESE CODES); +C LOGIC ENHANCED HERE TO ALLOW COMPRESSED AND +C STANDARD BUFR MESSAGES TO BE READ +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THE SECTION 1 +C MESSAGE SUBTYPE DOES NOT AGREE WITH THE +C SECTION 1 MESSAGE SUBTYPE IN THE DICTIONARY +C IF THE MESSAGE TYPE MNEMONIC IS NOT OF THE +C FORM "NCtttsss", WHERE ttt IS THE BUFR TYPE +C AND sss IS THE BUFR SUBTYPE (E.G., IN +C "PREPBUFR" FILES); MODIFIED DATE +C CALCULATIONS TO NO LONGER USE FLOATING +C POINT ARITHMETIC SINCE THIS CAN LEAD TO +C ROUND OFF ERROR AND AN IMPROPER RESULTING +C DATE ON SOME MACHINES (E.G., NCEP IBM +C FROST/SNOW), INCREASES PORTABILITY; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN; SUBSET DEFINED AS " " IF +C IRET RETURNED AS 11 (BEFORE WAS UNDEFINED) +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE IUPBS01, IGETDATE AND GETLENS +C 2006-04-14 J. ATOR -- ALLOW "FRtttsss" AND "FNtttsss" AS POSSIBLE +C TABLE A MNEMONICS, WHERE ttt IS THE BUFR +C TYPE AND sss IS THE BUFR SUBTYPE +C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; +C USE IUPBS3 AND ERRWRT +C +C USAGE: CALL CKTABA (LUN, SUBSET, JDATE, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING CHECKED: +C " " = IRET equal to 11 (see IRET below) +C and not using Section 3 decoding +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING CHECKED, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = unrecognized Table A (message type) value +C 11 = this is a BUFR table (dictionary) message +C +C REMARKS: +C THIS ROUTINE CALLS: BORT DIGIT ERRWRT GETLENS +C I4DY IGETDATE IUPB IUPBS01 +C IUPBS3 NEMTBAX NUMTAB OPENBT +C RDUSDX +C THIS ROUTINE IS CALLED BY: RDMEMM READERME READMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 + COMMON /UNPTYP/ MSGUNP(NFILES) + COMMON /QUIET / IPRT + + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*8 SUBSET,TAMNEM + CHARACTER*2 CPFX(3) + CHARACTER*1 TAB + LOGICAL TRYBT, DIGIT + + DATA CPFX / 'NC', 'FR', 'FN' / + DATA NCPFX / 3 / + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + + TRYBT = .TRUE. + + JDATE = IGETDATE(MBAY(1,LUN),IYR,IMO,IDY,IHR) + +c .... Message type + MTYP = IUPBS01(MBAY(1,LUN),'MTYP') +c .... Message subtype + MSBT = IUPBS01(MBAY(1,LUN),'MSBT') + + IF(MTYP.EQ.11) THEN +c .... This is a BUFR table (dictionary) message. + IRET = 11 +c .... There's no need to proceed any further unless Section 3 is being +c .... used for decoding. + IF(ISC3(LUN).EQ.0) THEN + SUBSET = " " + GOTO 100 + ENDIF + ENDIF + +C PARSE SECTION 3 +C --------------- + + CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5) + + IAD3 = LEN0+LEN1+LEN2 + +c .... First descriptor (integer) + KSUB = IUPB(MBAY(1,LUN),IAD3+8 ,16) +c .... Second descriptor (integer) + ISUB = IUPB(MBAY(1,LUN),IAD3+10,16) + +C LOCATE SECTION 4 +C ---------------- + + IAD4 = IAD3+LEN3 + +C NOW, TRY TO GET "SUBSET" (MNEMONIC ASSOCIATED WITH TABLE A) FROM MSG +C -------------------------------------------------------------------- + +C FIRST CHECK WHETHER SECTION 3 IS BEING USED FOR DECODING +C -------------------------------------------------------- + + IF(ISC3(LUN).NE.0) THEN + SUBSET = TAMNEM(LUN) +c .... is SUBSET from Table A? + CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) + IF(INOD.GT.0) THEN +c .... yes it is + MBYT(LUN) = 8*(IAD4+4) + MSGUNP(LUN) = 1 + GOTO 10 + ENDIF + ENDIF + +C IF ISUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=0 +C ---------------------------------------------------- + +c .... get SUBSET from ISUB +5 CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) +c .... is SUBSET from Table A? + CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) + IF(INOD.GT.0) THEN +c .... yes it is + MBYT(LUN) = (IAD4+4) + MSGUNP(LUN) = 0 + GOTO 10 + ENDIF + +C IF KSUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=1 (standard) +C --------------------------------------------------------------- + +c .... get SUBSET from KSUB + CALL NUMTAB(LUN,KSUB,SUBSET,TAB,ITAB) +c .... is SUBSET from Table A? + CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) + IF(INOD.GT.0) THEN +c .... yes it is + MBYT(LUN) = 8*(IAD4+4) + MSGUNP(LUN) = 1 + GOTO 10 + ENDIF + +C OKAY, STILL NO "SUBSET", LETS MAKE IT "NCtttsss" (where ttt=MTYP +C and sss=MSBT) AND SEE IF IT DEFINES TABLE A. IF NOT, THEN ALSO +C TRY "FRtttsss" AND "FNtttsss". +C ---------------------------------------------------------------- + + II=1 + DO WHILE(II.LE.NCPFX) + WRITE(SUBSET,'(A2,2I3.3)') CPFX(II),MTYP,MSBT +c .... is SUBSET from Table A? + CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) + IF(INOD.GT.0) THEN +c .... yes it is + IF(KSUB.EQ.IBCT) THEN + MBYT(LUN) = (IAD4+4) + MSGUNP(LUN) = 0 + ELSE + MBYT(LUN) = 8*(IAD4+4) + MSGUNP(LUN) = 1 + ENDIF + GOTO 10 + ENDIF + II=II+1 + ENDDO + +C NOW WE HAVE A GENERATED "SUBSET", BUT IT STILL DOES NOT DEFINE +C TABLE A - MAKE ONE LAST DESPERATE ATTEMPT - SEE IF AN EXTERNAL +C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT IS DEFINED +C IN OPENBT (ONLY POSSIBLE IF APPLICATION PROGRAM HAS AN IN-LINE +C OPENBT OVERRIDING THE ONE IN THE BUFR ARCHIVE LIBRARY) +C ------------------------------------------------------------------ + + IF(TRYBT) THEN + TRYBT = .FALSE. + IF(IPRT.GE.1) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + ERRSTR = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL'// + . ' BUFR TABLE VIA CALL TO IN-LINE OPENBT' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + CALL OPENBT(LUNDX,MTYP) + IF(LUNDX.GT.0) THEN +c .... Good news, there is a unit (LUNDX) connected to a table file, +c .... so store the table internally + CALL RDUSDX(LUNDX,LUN) + GOTO 5 + ENDIF + ENDIF + +C IF ALL ATTEMPTS TO DEFINE TABLE A FAIL SKIP GIVE UP +C --------------------------------------------------- + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE ('// + . SUBSET // ') - RETURN WITH IRET = -1' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IRET = -1 + GOTO 100 + +C CHECK THE VALIDITY OF THE MTYP/MSBT AND FOR COMPRESSION (MSGUNP=2) +C ------------------------------------------------------------------ + +10 IF(ISC3(LUN).EQ.0) THEN + IF(MTYP.NE.MTY1) GOTO 900 + IF(MSBT.NE.MSB1.AND.DIGIT(SUBSET(3:8))) GOTO 901 + ENDIF + IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) MSGUNP(LUN) = 2 + +C SET THE OTHER REQUIRED PARAMETERS IN MESSAGE CONTROL WORD PARTITION +C ------------------------------------------------------------------- + +c .... Date for this message + IDATE(LUN) = I4DY(JDATE) +c .... Positional index of Table A mnem. + INODE(LUN) = INOD +c .... Number of subsets in this message + MSUB(LUN) = IUPBS3(MBAY(1,LUN),'NSUB') +c .... Number of subsets read so far from this message + NSUB(LUN) = 0 + + IF(IRET.NE.11) THEN +c .... Number of non-dictionary messages read so far from this file + NMSG(LUN) = NMSG(LUN)+1 + ENDIF + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH '// + . '(SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') SUBSET,MTYP,MTY1 + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH '// + . '(SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') SUBSET,MSBT,MSB1 + CALL BORT(BORT_STR) + END diff --git a/src/bufr/closbf.f b/src/bufr/closbf.f new file mode 100644 index 0000000000..3f9d2d311e --- /dev/null +++ b/src/bufr/closbf.f @@ -0,0 +1,68 @@ + SUBROUTINE CLOSBF(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CLOSBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE IS CALLED IN ORDER TO TERMINATE BUFR +C ARCHIVE LIBRARY SOFTWARE ACCESS TO A LOGICAL UNIT LUNIT FOR INPUT +C OR OUTPUT OPERATIONS (PREVIOUSLY OPENED BY A FORTRAN "OPEN" ON THE +C LOGICAL UNIT AND BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF). +C CLOSBF MUST BE CALLED WHEN LUNIT IS CONNECTED TO A BUFR FILE OPEN +C FOR OUTPUT IN ORDER TO PROPERLY CLOSE AND WRITE ANY CURRENT BUFR +C MESSAGE WHICH MAY STILL EXIST IN INTERNAL MEMORY (AND MOST LIKELY +C NOT BE FULL). IT IS NOT MANDATORY THAT CLOSBF BE CALLED WHEN LUNIT +C IS CONNECTED TO A BUFR FILE OPEN FOR INPUT, BUT IT IS STILL A GOOD +C IDEA TO DO SO. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- DON'T CLOSE LUNIT IF OPENED AS A NULL FILE +C BY OPENBF {NULL(LUN) = 1 IN NEW COMMON +C BLOCK /NULBFR/} (WAS IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C -- ADDED CALL TO CLOSFB TO CLOSE C FILES +C +C USAGE: CALL CLOSBF (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C OUTPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: CLOSFB CLOSMG STATUS WTSTAT +C THIS ROUTINE IS CALLED BY: COPYBF MESGBF UFBINX UFBMEM +C UFBMEX UFBTAB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /NULBFR/ NULL(NFILES) + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.GT.0 .AND. IM.NE.0) CALL CLOSMG(LUNIT) + if(IL.NE.0 .AND. NULL(LUN).EQ.0) call closfb(lun) + CALL WTSTAT(LUNIT,LUN,0,0) + +C CLOSE fortran UNIT IF NULL(LUN) = 0 +C ----------------------------------- + + IF(NULL(LUN).EQ.0) CLOSE(LUNIT) + + RETURN + END diff --git a/src/bufr/closmg.f b/src/bufr/closmg.f new file mode 100644 index 0000000000..cbde84915a --- /dev/null +++ b/src/bufr/closmg.f @@ -0,0 +1,136 @@ + SUBROUTINE CLOSMG(LUNIN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CLOSMG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C ABS(LUNIN) HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT CLOSES A BUFR +C MESSAGE PREVIOUSLY OPENED BY EITHER BUFR ARCHIVE LIBRARY +C SUBROUTINES OPENMG OR OPENMB AND WRITES IT TO THE UNIT ABS(LUNIN). +C SINCE OPENMG AND OPENMB NORMALLY CALL THIS INTERNALLY, IT IS NOT +C CALLED TOO OFTEN FROM AN APPLICATION PROGRAM. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-05-19 J. WOOLLEN -- CORRECTED A PROBLEM INTRODUCED IN A +C PREVIOUS (MAY 2002) IMPLEMENTATION WHICH +C PREVENTED THE DUMP CENTER TIME AND +C INTITIATION TIME MESSAGES FROM BEING +C WRITTEN OUT (THIS AFFECTED APPLICATION +C PROGRAM BUFR_DUMPMD, IF IT WERE RECOMPILED, +C IN THE DATA DUMPING PROCESS) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-05-26 D. KEYSER -- ALLOWS OVERRIDE OF PREVIOUS LOGIC THAT HAD +C ALWAYS WRITTEN OUT MESSAGE NUMBERS 1 AND 2 +C EVEN WHEN THEY CONTAINED ZERO SUBSETS +C (ASSUMED THESE ARE DUMMIES, CONTAINING ONLY +C CENTER AND DUMP TIME) (NO OTHER EMPTY +C MESSAGES WERE WRITTEN OUT), DONE BY PASSING +C IN A NEGATIVE UNIT NUMBER ARGUMENT THE +C FIRST TIME THIS ROUTINE IS CALLED BY AN +C APPLICATION PROGRAM (ALL EMPTY MESSAGES ARE +C SKIPPED) (ASSUMES DUMMY MESSAGES ARE NOT IN +C INPUT FILE), NOTE: THIS REMAINS SET FOR THE +C PARTICULAR FILE BEING WRITTEN TO EACH TIME +C CLOSMG IS CALLED, REGARDLESS OF THE SIGN OF +C THE UNIT NUMBER - THIS IS NECESSARY BECAUSE +C THIS ROUTINE IS CALLED BY OTHER BUFRLIB +C ROUTINES WHICH ALWAYS PASS IN A POSITIVE +C UNIT NUMBER (THE APPLICATION PROGRAM SHOULD +C ALWAYS CALL CLOSMG WITH A NEGATIVE UNIT +C NUMBER IMMEDIATELY AFTER CALLING OPENBF FOR +C THIS OUTPUT FILE IF THE INTENTION IS TO +C NOT WRITE ANY EMPTY MESSAGES) +C +C USAGE: CALL CLOSMG (LUNIN) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE +C - IF LUNIN IS GREATER THAN ZERO, THEN MESSAGE NUMBER +C 1 OR 2 IS WRITTEN OUT EVEN IF THE NUMBER OF +C SUBSETS WRITTEN INTO THE MESSAGE IS ZERO (THIS +C ALLOWS "DUMMY" MESSAGES CONTAINING DUMP CENTER AND +C INITIATION TIME TO BE COPIED), MESSAGE NUMBERS 3 +C AND HIGHER ARE NOT WRITTEN OUT IF THEY CONTAIN +C ZERO SUBSETS +C - IF LUNIN IS LESS THAN ZERO, THEN NO MESSAGES WITH +C ZERO SUBSETS WRITTEN INTO THEM ARE WRITTEN OUT +C FOR A PARTICULAR FILE BOTH IN THIS CALL AND IN ALL +C SUBSEQUENT CALLS TO THIS ROUTINE BY AN APPLICATION +C PROGRAM +C +C REMARKS: +C THIS ROUTINE CALLS: BORT MSGWRT STATUS WRCMPS +C WTSTAT +C THIS ROUTINE IS CALLED BY: CLOSBF MAKESTAB OPENMB OPENMG +C WRITSA +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + + DIMENSION MSGLIM(NFILES) + + DATA MSGLIM/NFILES*3/ + + SAVE MSGLIM + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS +C --------------------- + + LUNIT = ABS(LUNIN) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(LUNIT.NE.LUNIN) MSGLIM(LUN) = 0 + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.NE.0) THEN + IF(NSUB(LUN).GT.0) THEN + CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) + ELSE IF(NSUB(LUN).EQ.0.AND.NMSG(LUN).LT.MSGLIM(LUN)) THEN + CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) + ELSE IF(NSUB(LUN).LT.0) THEN + CALL WRCMPS(-LUNIT) + ENDIF + ENDIF + CALL WTSTAT(LUNIT,LUN,IL,0) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') + END diff --git a/src/bufr/cmpia.c b/src/bufr/cmpia.c new file mode 100644 index 0000000000..cec2a25ff9 --- /dev/null +++ b/src/bufr/cmpia.c @@ -0,0 +1,42 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CMPIA +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS ROUTINE DEFINES A COMPARISON BETWEEN TWO INTEGERS +C FOR USE BY THE BINARY SEARCH FUNCTION BSEARCH. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL CMPIA( PF1, PF2 ) +C INPUT ARGUMENT LIST: +C PF1 - INTEGER: FIRST INTEGER TO BE COMPARED +C PF2 - INTEGER: SECOND INTEGER TO BE COMPARED +C +C OUTPUT ARGUMENT LIST: +C CMPIA - INTEGER: RESULT OF COMPARISON: +C -1 = PF1 is less than PF2 +C 0 = PF1 is equal to PF2 +C 1 = PF1 is greater than PF2 +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: NUMMTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +int cmpia( const f77int *pf1, const f77int *pf2 ) +{ + if ( *pf1 == *pf2 ) return 0; + + return ( *pf1 < *pf2 ? -1 : 1 ); +} diff --git a/src/bufr/cmpmsg.f b/src/bufr/cmpmsg.f new file mode 100644 index 0000000000..fd1952fe55 --- /dev/null +++ b/src/bufr/cmpmsg.f @@ -0,0 +1,56 @@ + SUBROUTINE CMPMSG(CF) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CMPMSG +C PRGMMR: ATOR ORG: NP12 DATE: 2005-03-09 +C +C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT BUFR +C MESSAGES CREATED BY FUTURE CALLS TO EITHER OF THE BUFR ARCHIVE +C LIBRARY SUBROUTINES WRITSB OR WRITSA ARE TO BE COMPRESSED. +C THIS SUBROUTINE CAN BE CALLED AT ANY TIME AFTER THE FIRST CALL +C TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE POSSIBLE VALUES +C FOR CF ARE 'N' (= 'NO', WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). +C +C PROGRAM HISTORY LOG: +C 2005-03-09 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL CMPMSG (CF) +C INPUT ARGUMENT LIST: +C CF - CHARACTER*1: FLAG INDICATING WHETHER BUFR MESSAGES +C OUTPUT BY FUTURE CALLS TO WRITSB OR WRITSA ARE TO +C BE COMPRESSED: +C 'N' = 'NO' (THE DEFAULT) +C 'Y' = 'YES' +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CAPIT +C THIS ROUTINE IS CALLED BY: COPYSB WRITCP +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /MSGCMP/ CCMF + + CHARACTER*128 BORT_STR + CHARACTER*1 CCMF, CF + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL CAPIT(CF) + IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 + CCMF = CF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: CMPMSG - INPUT ARGUMENT IS ",A1,'// + . '", IT MUST BE EITHER Y OR N")') CF + CALL BORT(BORT_STR) + END diff --git a/src/bufr/cmsgini.f b/src/bufr/cmsgini.f new file mode 100644 index 0000000000..0adad76ff9 --- /dev/null +++ b/src/bufr/cmsgini.f @@ -0,0 +1,211 @@ + SUBROUTINE CMSGINI(LUN,MESG,SUBSET,IDATE,NSUB,NBYT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CMSGINI +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE INITIALIZES A NEW BUFR MESSAGE FOR OUTPUT +C IN COMPRESSED BUFR. THE ACTUAL LENGTH OF SECTION 4 (CONTAINING +C COMPRESSED DATA) IS ALREADY KNOWN. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY; LEN3 INITIALIZED AS +C ZERO (BEFORE WAS UNDEFINED WHEN FIRST +C REFERENCED) +C 2004-08-18 J. ATOR -- ADDED COMMON /MSGSTD/ AND OTHER LOGIC TO +C ALLOW OPTION OF CREATING A SECTION 3 THAT IS +C FULLY WMO-STANDARD; IMPROVED DOCUMENTATION; +C MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 +C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13; +C REMOVED STANDARDIZATION LOGIC FOR SECTION 3 +C +C USAGE: CALL CMSGINI (LUN, MESG, SUBSET, IDATE, NSUB, NBYT) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING WRITTEN +C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING WRITTEN, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C NSUB - INTEGER: NUMBER OF SUBSETS, STORED IN SECTION 3 OF +C BUFR MESSAGE BEING WRITTEN +C NBYT - INTEGER: ACTUAL LENGTH (IN BYTES) OF "COMPRESSED DATA +C PORTION" OF SECTION 4 (I.E. ALL OF SECTION 4 EXCEPT +C FOR THE FIRST FOUR BYTES) +C +C OUTPUT ARGUMENT LIST: +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE +C NBYT - INTEGER: ACTUAL LENGTH OF BUFR MESSAGE (IN BYTES) UP +C TO THE POINT IN SECTION 4 WHERE COMPRESSED DATA ARE +C TO BE WRITTEN +C +C REMARKS: +C THIS ROUTINE CALLS: BORT I4DY NEMTAB NEMTBA +C PKB PKC +C THIS ROUTINE IS CALLED BY: WRCMPS +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + CHARACTER*4 BUFR + CHARACTER*1 TAB + DIMENSION MESG(*) + + DATA BUFR/'BUFR'/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE +C --------------------------------------------------- + +c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD + CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD) + CALL NEMTAB(LUN,SUBSET,ISUB,TAB,IRET) + IF(IRET.EQ.0) GOTO 900 + +C DATE CAN BE YYMMDDHH OR YYYYMMDDHH +C ---------------------------------- + + JDATE = I4DY(IDATE) + MCEN = MOD(JDATE/10**8,100)+1 + MEAR = MOD(JDATE/10**6,100) + MMON = MOD(JDATE/10**4,100) + MDAY = MOD(JDATE/10**2,100) + MOUR = MOD(JDATE ,100) + MMIN = 0 + +c .... DK: Don't think this can happen, because IDATE=0 is returned +c as 2000000000 by I4DY meaning MCEN would be 21 + IF(MCEN.EQ.1) GOTO 901 + + IF(MEAR.EQ.0) MCEN = MCEN-1 + IF(MEAR.EQ.0) MEAR = 100 + +C INITIALIZE THE MESSAGE +C ---------------------- + + MBIT = 0 + +C SECTION 0 +C --------- + + CALL PKC(BUFR , 4 , MESG,MBIT) + +C NOTE THAT THE ACTUAL SECTION 0 LENGTH WILL BE COMPUTED AND +C STORED BELOW; FOR NOW, WE ARE REALLY ONLY INTERESTED IN +C ADVANCING MBIT BY THE CORRECT AMOUNT, SO WE'LL JUST STORE +C A DEFAULT VALUE OF 0. + + CALL PKB( 0 , 24 , MESG,MBIT) + CALL PKB( 3 , 8 , MESG,MBIT) + +C SECTION 1 +C --------- + + LEN1 = 18 + + CALL PKB(LEN1 , 24 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + CALL PKB( 3 , 8 , MESG,MBIT) + CALL PKB( 7 , 8 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + CALL PKB(MTYP , 8 , MESG,MBIT) + CALL PKB(MSBT , 8 , MESG,MBIT) + CALL PKB( 13 , 8 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + CALL PKB(MEAR , 8 , MESG,MBIT) + CALL PKB(MMON , 8 , MESG,MBIT) + CALL PKB(MDAY , 8 , MESG,MBIT) + CALL PKB(MOUR , 8 , MESG,MBIT) + CALL PKB(MMIN , 8 , MESG,MBIT) + CALL PKB(MCEN , 8 , MESG,MBIT) + +C SECTION 3 +C --------- + + LEN3 = 10 + + CALL PKB(LEN3 , 24 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + CALL PKB(NSUB , 16 , MESG,MBIT) + CALL PKB( 192 , 8 , MESG,MBIT) + CALL PKB(ISUB , 16 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + +C SECTION 4 +C --------- + +C STORE THE TOTAL LENGTH OF SECTION 4. + +C REMEMBER THAT THE INPUT VALUE OF NBYT ONLY CONTAINS THE +C LENGTH OF THE "COMPRESSED DATA PORTION" OF SECTION 4, SO +C WE NEED TO ADD FOUR BYTES TO THIS NUMBER IN ORDER TO +C ACCOUNT FOR THE TOTAL LENGTH OF SECTION 4. + + CALL PKB((NBYT+4) , 24 , MESG,MBIT) + CALL PKB( 0 , 8 , MESG,MBIT) + +C THE ACTUAL "COMPRESSED DATA PORTION" OF SECTION 4 WILL +C BE FILLED IN LATER BY SUBROUTINE WRCMPS. + +C SECTION 5 +C --------- + +C THIS SECTION WILL BE FILLED IN LATER BY SUBROUTINE WRCMPS. + +C RETURN WITH THE CORRECT NEW MESSAGE BYTE COUNT +C ---------------------------------------------- + +C NOW, NOTING THAT MBIT CURRENTLY POINTS TO THE LAST BIT OF +C THE FOURTH BYTE OF SECTION 4, THEN WE HAVE: +C (TOTAL LENGTH OF BUFR MESSAGE (IN SECTION 0)) = +C (LENGTH OF MESSAGE UP THROUGH FOURTH BYTE OF SECTION 4) +C + (LENGTH OF "COMPRESSED DATA PORTION" OF SECTION 4) +C + (LENGTH OF SECTION 5) + MBYT = + . MBIT/8 + . + NBYT + . + 4 + +C NOW, MAKE NBYT POINT TO THE CURRENT LOCATION OF MBIT +C (I.E. THE BYTE AFTER WHICH TO ACTUALLY BEGIN WRITING THE +C COMPRESSED DATA INTO SECTION 4). + + NBYT = MBIT/8 + +C NOW, STORE THE TOTAL LENGTH OF THE BUFR MESSAGE (IN SECTION 0). + + MBIT = 32 + CALL PKB(MBYT,24,MESG,MBIT) + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE '// + . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBSET + CALL BORT(BORT_STR) +901 CALL BORT + . ('BUFRLIB: CMSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') + END diff --git a/src/bufr/cnved4.f b/src/bufr/cnved4.f new file mode 100644 index 0000000000..6dbb1a0f16 --- /dev/null +++ b/src/bufr/cnved4.f @@ -0,0 +1,137 @@ + SUBROUTINE CNVED4(MSGIN,LMSGOT,MSGOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CNVED4 +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE ENCODED USING +C BUFR EDITION 3 AND OUTPUTS AN EQUIVALENT BUFR MESSAGE ENCODED USING +C BUFR EDITION 4. THE OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE +C INPUT MESSAGE, SO THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE +C MSGOT ARRAY. NOTE THAT MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2009-08-12 J. ATOR -- ALLOW SILENT RETURN (INSTEAD OF BORT RETURN) +C IF MSGIN IS ALREADY ENCODED USING EDITION 4 +C +C USAGE: CALL CNVED4 (MSGIN, LMSGOT, MSGOT) +C INPUT ARGUMENT LIST: +C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE ENCODED +C USING BUFR EDITION 3 +C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; +C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT +C OVERFLOW THE MSGOT ARRAY +C +C OUTPUT ARGUMENT LIST: +C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE +C NOW ENCODED USING BUFR EDITION 4 +C +C REMARKS: +C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. +C +C THIS ROUTINE CALLS: BORT GETLENS IUPBS01 MVB +C NMWRD PKB +C THIS ROUTINE IS CALLED BY: MSGWRT +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MSGIN(*), MSGOT(*) + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(IUPBS01(MSGIN,'BEN').EQ.4) THEN + +C The input message is already encoded using edition 4, so just +C copy it from MSGIN to MSGOT and then return. + + NMW = NMWRD(MSGIN) + IF(NMW.GT.LMSGOT) GOTO 900 + DO I = 1, NMW + MSGOT(I) = MSGIN(I) + ENDDO + RETURN + ENDIF + +C Get some section lengths and addresses from the input message. + + CALL GETLENS(MSGIN,3,LEN0,LEN1,LEN2,LEN3,L4,L5) + + IAD2 = LEN0 + LEN1 + IAD4 = IAD2 + LEN2 + LEN3 + + LENM = IUPBS01(MSGIN,'LENM') + +C Check for overflow of the output array. Note that the new +C edition 4 message will be a total of 3 bytes longer than the +C input message (i.e. 4 more bytes in Section 1, but 1 fewer +C byte in Section 3). + + LENMOT = LENM + 3 + IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 + + LEN1OT = LEN1 + 4 + LEN3OT = LEN3 - 1 + +C Write Section 0 of the new message into the output array. + + CALL MVB ( MSGIN, 1, MSGOT, 1, 4 ) + IBIT = 32 + CALL PKB ( LENMOT, 24, MSGOT, IBIT ) + CALL PKB ( 4, 8, MSGOT, IBIT ) + +C Write Section 1 of the new message into the output array. + + CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'BMT'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'OGCE'), 16, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'GSES'), 16, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'USN'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'ISC2')*128, 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'MTYP'), 8, MSGOT, IBIT ) + +C Set a default of 255 for the international subcategory. + + CALL PKB ( 255, 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'MSBT'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'MTV'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'MTVL'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'YEAR'), 16, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'MNTH'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'DAYS'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'HOUR'), 8, MSGOT, IBIT ) + CALL PKB ( IUPBS01(MSGIN,'MINU'), 8, MSGOT, IBIT ) + +C Set a default of 0 for the second. + + CALL PKB ( 0, 8, MSGOT, IBIT ) + +C Copy Section 2 (if it exists) through the next-to-last byte +C of Section 3 from the input array to the output array. + + CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LEN2+LEN3-1 ) + +C Store the length of the new Section 3. + + IBIT = ( LEN0 + LEN1OT + LEN2 ) * 8 + CALL PKB ( LEN3OT, 24, MSGOT, IBIT ) + +C Copy Section 4 and Section 5 from the input array to the +C output array. + + IBIT = IBIT + ( LEN3OT * 8 ) - 24 + CALL MVB ( MSGIN, IAD4+1, MSGOT, (IBIT/8)+1, LENM-IAD4 ) + + RETURN +900 CALL BORT('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) '// + . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + END diff --git a/src/bufr/cobfl.c b/src/bufr/cobfl.c new file mode 100644 index 0000000000..7a034d2822 --- /dev/null +++ b/src/bufr/cobfl.c @@ -0,0 +1,106 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: COBFL +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS ROUTINE OPENS A SPECIFIED SYSTEM FILE FOR READING +C OR WRITING VIA THE BUFR ARCHIVE LIBRARY C I/O INTERFACE. THERE +C CAN BE AT MOST TWO SYSTEM FILES OPEN AT ANY GIVEN TIME (ONE FOR +C READING/INPUT AND ONE FOR WRITING/OUTPUT). IF A CALL TO THIS +C ROUTINE IS MADE FOR EITHER READING/INPUT OR WRITING/OUTPUT AND +C SUCH A FILE IS ALREADY OPEN TO THE BUFR ARCHIVE LIBRARY C I/O +C INTERFACE, THEN THAT FILE WILL BE CLOSED BEFORE OPENING THE +C NEW ONE. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL COBFL( BFL, IO ) +C INPUT ARGUMENT LIST: +C BFL - CHARACTER*(*): SYSTEM FILE TO BE OPENED. INCLUSION +C OF DIRECTORY PREFIXES OR OTHER LOCAL FILESYSTEM +C NOTATION IS ALLOWED UP TO 120 TOTAL CHARACTERS. +C IO - CHARACTER: FLAG INDICATING HOW BFL IS TO BE OPENED +C FOR USE WITH THE C I/O INTERFACE: +C 'r' = READING (INPUT) +C 'w' = WRITING (OUTPUT) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#define BUFRLIB_GLOBAL +#include "bufrlib.h" + +#define MXFNLEN 500 + +void cobfl( char *bfl, char *io ) +{ + char lbf[MXFNLEN+1]; + char lio; + + char errstr[129]; + + char foparg[3] = " b"; /* 3rd character will automatically + initialize to NULL */ + unsigned short i, j; + +/* +** Copy the input arguments into local variables and check them for validity. +** This is especially important in case either of the arguments was passed in +** as a string literal by the calling program or else doesn't have a trailing +** NULL character. +*/ + for ( i = 0; ( ! isspace( bfl[i] ) && ! iscntrl( bfl[i] ) ); i++ ) { + if ( i == MXFNLEN ) { + sprintf( errstr, "BUFRLIB: COBFL - INPUT FILENAME CONTAINS" + " MORE THAN %d CHARACTERS", MXFNLEN ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + lbf[i] = bfl[i]; + } + lbf[i] = '\0'; + + lio = io[0]; + if ( ( foparg[0] = (char) tolower( lio ) ) == 'r' ) { + j = 0; + } + else if ( foparg[0] == 'w' ) { + j = 1; + } + else { + sprintf( errstr, "BUFRLIB: COBFL - SECOND ARGUMENT WAS (%c)," + " WHICH IS AN ILLEGAL VALUE", lio ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + +/* +** If a file of this type is already open, then close it before +** opening the new one. +*/ + if ( pbf[j] != NULL ) fclose( pbf[j] ); + +/* +** Open the requested file. +*/ + if ( ( pbf[j] = fopen( lbf, foparg ) ) == NULL ) { + sprintf( errstr, "BUFRLIB: COBFL - COULD NOT OPEN FILE %s", lbf ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + +/* +** Call wrdlen to initialize some important information about the +** local machine, just in case it hasn't already been called. +*/ + wrdlen( ); + + return; +} diff --git a/src/bufr/conwin.f b/src/bufr/conwin.f new file mode 100644 index 0000000000..791acff928 --- /dev/null +++ b/src/bufr/conwin.f @@ -0,0 +1,108 @@ + SUBROUTINE CONWIN(LUN,INC1,INC2) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CONWIN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SEARCHES CONSECUTIVE SUBSET BUFFER SEGMENTS +C FOR AN ELEMENT IDENTIFIED IN THE USER STRING AS A CONDITIONAL NODE +C (I.E. AN ELEMENT WHICH MUST MEET A CONDITION IN ORDER TO BE READ +C FROM OR WRITTEN TO A DATA SUBSET). IF A CONDITIONAL ELEMENT IS +C FOUND AND IT CONFORMS TO THE CONDITION, THEN THE INTERNAL SUBSET +C BUFFER INDICES OF THE "WINDOW" (SEE BELOW REMARKS) ARE RETURNED TO +C THE CALLER FOR PROCESSING. +C +C THE FOUR CONDITIONS WHICH CAN BE EXERCISED ARE: +C '<' - LESS THAN +C '>' - GREATER THAN +C '=' - EQUAL +C '!' - NOT EQUAL +C +C EACH CONDITION IN A STRING IS APPLIED TO ONE ELEMENT, AND ALL +C CONDITIONS ARE 'AND'ED TO EVALUATE AN OUTCOME. FOR EXAMPLE, IF THE +C CONDITION STRING IS: "POB<500 TOB>30 TQM<4" THEN THE ONLY LEVELS OF +C DATA READ OR WRITTEN ARE THOSE WITH PRESSURE LT 500 MB, TEMPERATURE +C GT 30 DEG, AND TEMPERATURE QUALITY MARK < 4. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2010-04-27 J. WOOLLEN -- CORRECT LOGICAL FLAW AND ADD DOCUMENTATION +C +C USAGE: CALL CONWIN (LUN, INC1, INC2) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INC1 - INTEGER: SUBSET BUFFER START INDEX +C INC2 - INTEGER: SUBSET BUFFER ENDING INDEX +C +C OUTPUT ARGUMENT LIST: +C INC1 - INTEGER: SUBSET BUFFER START INDEX +C INC2 - INTEGER: SUBSET BUFFER ENDING INDEX +C +C REMARKS: +C +C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN +C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. +C +C FUNCTION CONWIN WORKS WITH FUNCTION INVCON TO IDENTIFY SUBSET +C BUFFER SEGMENTS WHICH CONFORM TO THE SET OF CONDITIONS. +C +C THIS ROUTINE CALLS: GETWIN INVCON +C THIS ROUTINE IS CALLED BY: UFBEVN UFBIN3 UFBRW +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C SPECIAL CASE +C ------------ + + IF(NCON.EQ.0) THEN +c .... There are no condition nodes in the string + INC1 = 1 + INC2 = NVAL(LUN) + GOTO 100 + ENDIF + +C EVALUATE CONDITIONS TO SEE IF ANY MORE CASES +C -------------------------------------------- + +15 CALL GETWIN(NODC(1),LUN,INC1,INC2) + IF(INC1.GT.0) THEN + DO NC=1,NCON + ICON = INVCON(NC,LUN,INC1,INC2) + IF(ICON.EQ.0) GOTO 15 + ENDDO + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/copybf.f b/src/bufr/copybf.f new file mode 100644 index 0000000000..6a10802c71 --- /dev/null +++ b/src/bufr/copybf.f @@ -0,0 +1,106 @@ + SUBROUTINE COPYBF(LUNIN,LUNOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: COPYBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES AN ENTIRE BUFR FILE FROM LOGICAL +C UNIT LUNIN TO LOGICAL UNIT LUNOT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE RDMSGW AND NMWRD +C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE +C USE READMG AND COPYMG TO COPY FILE +C +C USAGE: CALL COPYBF (LUNIN, LUNOT) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C INPUT FILES: +C UNIT "LUNIN" - BUFR FILE +C +C OUTPUT FILES: +C UNIT "LUNOT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CLOSBF IUPBS01 MSGWRT +C OPENBF RDMSGW STATUS WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + DIMENSION MBAY(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION +C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) +C --------------------------------------------------------------- + + CALL WRDLEN + +C CHECK BUFR FILE STATUSES +C ------------------------ + + CALL STATUS(LUNIN,LUN,IL,IM) + IF(IL.NE.0) GOTO 900 + CALL STATUS(LUNOT,LUN,IL,IM) + IF(IL.NE.0) GOTO 901 + +C CONNECT THE FILES FOR READING/WRITING TO THE C-I-O INTERFACE +C ------------------------------------------------------------ + + CALL OPENBF(LUNIN,'INX',LUNIN) + CALL OPENBF(LUNOT,'OUX',LUNIN) + +C READ AND COPY A BUFR FILE ON UNIT LUNIN TO UNIT LUNOT +C ----------------------------------------------------- + +1 CALL RDMSGW(LUNIN,MBAY,IER) + IF(IER.EQ.0) THEN + CALL MSGWRT(LUNOT,MBAY,IUPBS01(MBAY,'LENM')) + GOTO 1 + ENDIF + +C FREE UP THE FILE CONNECTIONS FOR THE TWO FILES +C ---------------------------------------------- + + CALL CLOSBF(LUNIN) + CALL CLOSBF(LUNOT) + +C EXITS +C ----- + + RETURN +900 CALL BORT + . ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') +901 CALL BORT + . ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + END diff --git a/src/bufr/copymg.f b/src/bufr/copymg.f new file mode 100644 index 0000000000..06916ad9c4 --- /dev/null +++ b/src/bufr/copymg.f @@ -0,0 +1,136 @@ + SUBROUTINE COPYMG(LUNIN,LUNOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: COPYMG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM LOGICAL +C UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT +C VIA A PREVIOUS CALL TO OPENBF. THE MESSAGE COPIED FROM LOGICAL +C UNIT LUNIN WILL BE THE ONE MOST RECENTLY READ USING BUFR ARCHIVE +C LIBRARY SUBROUTINE READMG. THE OUTPUT FILE MUST HAVE NO CURRENTLY +C OPEN MESSAGES. ALSO, BOTH FILES MUST HAVE BEEN OPENED TO THE BUFR +C INTERFACE WITH IDENTICAL BUFR TABLES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE IUPBS01 +C 2009-06-26 J. ATOR -- USE IOK2CPY +C +C USAGE: CALL COPYMG (LUNIN, LUNOT) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IOK2CPY IUPBS01 MSGWRT +C NEMTBA STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*8 SUBSET + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUSES +C ----------------------- + + CALL STATUS(LUNIN,LIN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + + CALL STATUS(LUNOT,LOT,IL,IM) + IF(IL.EQ.0) GOTO 903 + IF(IL.LT.0) GOTO 904 + IF(IM.NE.0) GOTO 905 + +C MAKE SURE BOTH FILES HAVE THE SAME TABLES +C ----------------------------------------- + + SUBSET = TAG(INODE(LIN)) +c .... Given SUBSET, returns MTYP,MSBT,INOD + CALL NEMTBA(LOT,SUBSET,MTYP,MSBT,INOD) + IF(INODE(LIN).NE.INOD) THEN + IF(IOK2CPY(LIN,LOT).NE.1) GOTO 906 + ENDIF + +C EVERYTHING OKAY, COPY A MESSAGE +C ------------------------------- + + MBYM = IUPBS01(MBAY(1,LIN),'LENM') + CALL MSGWRT(LUNOT,MBAY(1,LIN),MBYM) + +C SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT +C ----------------------------------------------------------------- + + NMSG (LOT) = NMSG(LOT) + 1 + NSUB (LOT) = MSUB(LIN) + MSUB (LOT) = MSUB(LIN) + IDATE(LOT) = IDATE(LIN) + INODE(LOT) = INOD + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +904 CALL BORT('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +905 CALL BORT('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN '// + . 'OUTPUT BUFR FILE, A MESSAGE IS OPEN') +906 CALL BORT('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST '// + . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') + END diff --git a/src/bufr/copysb.f b/src/bufr/copysb.f new file mode 100644 index 0000000000..e073626edb --- /dev/null +++ b/src/bufr/copysb.f @@ -0,0 +1,187 @@ + SUBROUTINE COPYSB(LUNIN,LUNOT,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: COPYSB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A PACKED DATA SUBSET, INTACT, FROM +C LOGICAL UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR +C ARCHIVE LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED +C FOR OUTPUT VIA A PREVIOUS CALL TO OPENBF. THE BUFR MESSAGE MUST +C HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE +C LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED +C OR UNCOMPRESSED. ALSO, BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR +C OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A +C BUFR MESSAGE WITHIN MEMORY FOR UNIT LUNOT. EACH CALL TO COPYSB +C ADVANCES THE POINTER TO THE BEGINNING OF THE NEXT SUBSET IN BOTH +C THE INPUT AND OUTPUT FILES, UNLESS INPUT PARAMETER LUNOT IS .LE. +C ZERO, IN WHICH CASE THE OUTPUT POINTER IS NOT ADVANCED. THE +C COMPRESSION STATUS OF THE OUTPUT SUBSET/BUFR MESSAGE WILL ALWAYS +C MATCH THAT OF THE INPUT SUBSET/BUFR MESSAGE {I.E., IF INPUT MESSAGE +C IS UNCOMPRESSED(COMPRESSED) OUTPUT MESSAGE WILL BE UNCOMPRESSED +C (COMPRESSED)}. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-09-16 J. WOOLLEN -- NOW WRITES OUT COMPRESSED SUBSET/MESSAGE IF +C INPUT SUBSET/MESSAGE IS COMPRESSED (BEFORE +C COULD ONLY WRITE OUT UNCOMPRESSED SUBSET/ +C MESSAGE REGARDLESS OF COMPRESSION STATUS OF +C INPUT SUBSET/MESSAGE) +C 2009-06-26 J. ATOR -- USE IOK2CPY +C +C USAGE: CALL COPYSB ( LUNIN, LUNOT, IRET ) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the input +C BUFR message +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CMPMSG CPYUPD IOK2CPY +C MESGBC READSB STATUS UFBCPY +C UPB WRITSB +C THIS ROUTINE IS CALLED BY: ICOPYSB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*3 TYP + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUSES +C ----------------------- + + CALL STATUS(LUNIN,LIN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + + IF(LUNOT.GT.0) THEN + CALL STATUS(LUNOT,LOT,IL,IM) + IF(IL.EQ.0) GOTO 903 + IF(IL.LT.0) GOTO 904 + IF(IM.EQ.0) GOTO 905 + IF(INODE(LIN).NE.INODE(LOT)) THEN + IF( (TAG(INODE(LIN)).NE.TAG(INODE(LOT))) .OR. + . (IOK2CPY(LIN,LOT).NE.1) ) GOTO 906 + ENDIF + ENDIF + +C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE +C --------------------------------------------- + + IF(NSUB(LIN).EQ.MSUB(LIN)) THEN + IRET = -1 + GOTO 100 + ENDIF + +C CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH +C -------------------------------------------------------------------- + + CALL MESGBC(-LUNIN,MEST,ICMP) + + IF(ICMP.EQ.1) THEN + +C ------------------------------------------------------- +C THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES +C ------------------------------------------------------- +C READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG +C -------------------------------------------------------------------- + + CALL READSB(LUNIN,IRET) + IF(LUNOT.GT.0) THEN + CALL UFBCPY(LUNIN,LUNOT) + CALL CMPMSG('Y') + CALL WRITSB(LUNOT) + CALL CMPMSG('N') + ENDIF + GOTO 100 + ELSE IF(ICMP.EQ.0) THEN + +C ------------------------------------------------------- +C THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES +C ------------------------------------------------------- +C COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS +C --------------------------------------------------------------- + + IBIT = (MBYT(LIN))*8 + CALL UPB(NBYT,16,MBAY(1,LIN),IBIT) + IF(LUNOT.GT.0) CALL CPYUPD(LUNOT,LIN,LOT,NBYT) + MBYT(LIN) = MBYT(LIN) + NBYT + NSUB(LIN) = NSUB(LIN) + 1 + ELSE + GOTO 907 + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +904 CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +905 CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') +906 CALL BORT('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '// + . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') +907 WRITE(BORT_STR,'("BUFRLIB: COPYSB - INVALID COMPRESSION '// + . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '// + . 'ROUTINE MESGBC")') ICMP + CALL BORT(BORT_STR) + END diff --git a/src/bufr/cpbfdx.f b/src/bufr/cpbfdx.f new file mode 100644 index 0000000000..031bde4473 --- /dev/null +++ b/src/bufr/cpbfdx.f @@ -0,0 +1,108 @@ + SUBROUTINE CPBFDX(LUD,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CPBFDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES BUFR TABLE (DICTIONARY) MESSAGES +C FROM ONE LOCATION TO ANOTHER WITHIN INTERNAL MEMORY (ARRAYS IN +C COMMON BLOCKS /MSGCWD/ AND /TABABD/). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: CALL CPBFDX (LUD, LUN) +C INPUT ARGUMENT LIST: +C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR INPUT TABLE LOCATION +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR OUTPUT TABLE LOCATION +C +C REMARKS: +C THIS ROUTINE CALLS: DXINIT +C THIS ROUTINE IS CALLED BY: MAKESTAB READDX WRDXTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C INITIALIZE THE DICTIONARY TABLE PARTITION +C ----------------------------------------- + + CALL DXINIT(LUN,0) + +C COPY ONE TABLE PARTITION TO ANOTHER +C ----------------------------------- + +c .... Positional index for Table A mnem. + INODE(LUN) = INODE(LUD) + +c .... Set the number of Table A entries + NTBA(LUN) = NTBA(LUD) +c .... Set the number of Table B entries + NTBB(LUN) = NTBB(LUD) +c .... Set the number of Table D entries + NTBD(LUN) = NTBD(LUD) + +c .... Copy Table A entries + DO I=1,NTBA(LUD) +c .... Message type + IDNA(I,LUN,1) = IDNA(I,LUD,1) +c .... Message subtype + IDNA(I,LUN,2) = IDNA(I,LUD,2) +c .... Table A entries + TABA(I,LUN) = TABA(I,LUD) +c .... Pointer indices into internal tbl + MTAB(I,LUN) = MTAB(I,LUD) + ENDDO + +c .... Copy Table B entries + DO I=1,NTBB(LUD) +c .... Integer repr. of FXY descr. + IDNB(I,LUN) = IDNB(I,LUD) +c .... Table B entries + TABB(I,LUN) = TABB(I,LUD) + ENDDO + +c .... Copy Table D entries + DO I=1,NTBD(LUD) +c .... Integer repr. of FXY descr. + IDND(I,LUN) = IDND(I,LUD) +c .... Table B entries + TABD(I,LUN) = TABD(I,LUD) + ENDDO + + RETURN + END diff --git a/src/bufr/cpdxmm.f b/src/bufr/cpdxmm.f new file mode 100644 index 0000000000..ff3ba28417 --- /dev/null +++ b/src/bufr/cpdxmm.f @@ -0,0 +1,162 @@ + SUBROUTINE CPDXMM( LUNIT ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CPDXMM +C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT, +C THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE +C ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO COMMON /MSGMEM/. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C REPLACED FORTRAN BACKSPACE WITH C BACKBUFR +C +C USAGE: CALL CPDXMM (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C REMARKS: +C +C THE FOLLOWING VALUES ARE STORED WITHIN COMMON /MSGMEM/ BY THIS +C SUBROUTINE: +C +C LDXM = number of array words filled within MDX +C +C MDX(I=1,LDXM) = DX dictionary messages for use in decoding +C data messages stored within MSGS array (in +C COMMON /MSGMEM/) +C +C NDXM = number of DX dictionary messages within MDX +C +C IPDXM(I=1,NDXM) = pointer to first word of (I)th message +C within MDX +C +C NDXTS = number of DX dictionary tables represented by +C messages within MDX +C +C IFDXTS(J=1,NDXTS) = sequential number of first message +C within MDX which is part of (J)th +C dictionary table +C +C ICDXTS(J=1,NDXTS) = count of consecutive messages within MDX +C (beginning with IFDXTS(J)) which +C constitute (J)th dictionary table +C +C IPMSGS(J=1,NDXTS) = sequential number of first data message +C within MSGS array (in COMMON /MSGMEM/) +C to which (J)th dictionary table applies +C +C LDXTS = current dictionary table that is in scope +C (i.e. a number between 1 and NDXTS) +C +C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IUPBS3 +C NMWRD RDMSGW +C THIS ROUTINE IS CALLED BY: UFBMEM +C Not normally called by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET/ IPRT + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + + DIMENSION MBAY(MXMSGLD4) + + CHARACTER*128 ERRSTR + + LOGICAL DONE + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF ( NDXTS .GE. MXDXTS ) GOTO 900 + + ICT = 0 + DONE = .FALSE. + call status(lunit,lun,il,im) + +C Read a complete dictionary table from LUNIT, as a set of one or +C more DX dictionary messages. + + DO WHILE ( .NOT. DONE ) + CALL RDMSGW ( LUNIT, MBAY, IER ) + IF ( IER .EQ. -1 ) THEN + +C Don't abort for an end-of-file condition, since it may be +C possible for a file to end with dictionary messages. +C Instead, backspace the file pointer and let the calling +C routine diagnose the end-of-file condition and deal with +C it as it sees fit. + + call backbufr(lun) + DONE = .TRUE. + ELSE IF ( IER .EQ. -2 ) THEN + GOTO 901 + ELSE IF ( IDXMSG(MBAY) .NE. 1 ) THEN + +C This is a non-DX dictionary message. Assume we've reached +C the end of the dictionary table, and backspace LUNIT so that +C the next read (e.g. in the calling routine) will get this +C same message. + + call backbufr(lun) + DONE = .TRUE. + ELSE IF ( IUPBS3(MBAY,'NSUB') .EQ. 0 ) THEN + +C This is a DX dictionary message, but it doesn't contain any +C actual dictionary information. Assume we've reached the end +C of the dictionary table. + + DONE = .TRUE. + ELSE + +C Store this message into COMMON /MSGMEM/. + + ICT = ICT + 1 + IF ( ( NDXM + ICT ) .GT. MXDXM ) GOTO 902 + IPDXM(NDXM+ICT) = LDXM + 1 + LMEM = NMWRD(MBAY) + IF ( ( LDXM + LMEM ) .GT. MXDXW ) GOTO 903 + DO J = 1, LMEM + MDX(LDXM+J) = MBAY(J) + ENDDO + LDXM = LDXM + LMEM + ENDIF + ENDDO + +C Update the table information within COMMON /MSGMEM/. + + IF ( ICT .GT. 0 ) THEN + IFDXTS(NDXTS+1) = NDXM + 1 + ICDXTS(NDXTS+1) = ICT + IPMSGS(NDXTS+1) = MSGP(0) + 1 + NDXM = NDXM + ICT + NDXTS = NDXTS + 1 + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A)') + . 'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', NDXTS, + . ' CONSISTING OF ', ICT, ' MESSAGES' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ENDIF + + RETURN + 900 CALL BORT('BUFRLIB: CPDXMM - MXDXTS OVERFLOW') + 901 CALL BORT('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR') + 902 CALL BORT('BUFRLIB: CPDXMM - MXDXM OVERFLOW') + 903 CALL BORT('BUFRLIB: CPDXMM - MXDXW OVERFLOW') + END diff --git a/src/bufr/cpymem.f b/src/bufr/cpymem.f new file mode 100644 index 0000000000..c5151515c4 --- /dev/null +++ b/src/bufr/cpymem.f @@ -0,0 +1,156 @@ + SUBROUTINE CPYMEM(LUNOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CPYMEM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM +C INTERNAL MEMORY, STORED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE UFBMEM, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT VIA A +C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. THE +C MESSAGE COPIED FROM INTERNAL MEMORY WILL BE THE ONE MOST RECENTLY +C READ INTO THE MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/) +C USING BUFR ARCHIVE LIBRARY SUBROUTINE RDMEMM OR READMM. THE OUTPUT +C FILE MUST HAVE NO CURENTLY OPEN MESSAGES. ALSO, THE INTERNAL BUFR +C TABLES ASSOCIATED WITH THE INPUT MESSAGE MUST BE IDENTICAL TO THE +C BUFR TABLES USED TO OPEN LUNOT TO THE BUFR INTERFACE. THIS +C SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE COPYMG +C EXCEPT THE INPUT MESSAGE IS FROM INTERNAL MEMORY NOT FROM A +C PHYSICAL BUFR FILE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2005-11-29 J. ATOR -- USE IUPBS01 +C 2009-06-26 J. ATOR -- USE IOK2CPY +C +C USAGE: CALL CPYMEM (LUNOT) +C INPUT ARGUMENT LIST: +C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IOK2CPY IUPBS01 MSGWRT +C NEMTBA STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*8 SUBSET + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUSES +C ----------------------- + + CALL STATUS(MUNIT,LIN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + + CALL STATUS(LUNOT,LOT,IL,IM) + IF(IL.EQ.0) GOTO 903 + IF(IL.LT.0) GOTO 904 + IF(IM.NE.0) GOTO 905 + +C MAKE SURE BOTH FILES HAVE THE SAME TABLES +C ----------------------------------------- + + SUBSET = TAG(INODE(LIN)) +c .... Given SUBSET, returns MTYP,MSBT,INOD + CALL NEMTBA(LOT,SUBSET,MTYP,MSBT,INOD) + IF(INODE(LIN).NE.INOD) THEN + IF(IOK2CPY(LIN,LOT).NE.1) GOTO 906 + ENDIF + +C EVERYTHING OKAY, COPY A MESSAGE +C ------------------------------- + + MBYM = IUPBS01(MBAY(1,LIN),'LENM') + CALL MSGWRT(LUNOT,MBAY(1,LIN),MBYM) + +C SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT +C ----------------------------------------------------------------- + + NMSG (LOT) = NMSG(LOT) + 1 + NSUB (LOT) = MSUB(LIN) + MSUB (LOT) = MSUB(LIN) + IDATE(LOT) = IDATE(LIN) + INODE(LOT) = INOD + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: CPYMEM - LOGICAL UNIT NO. ASSOC. WITH INPUT'// + . ' BUFR MESSAGES IN INTERNAL MEMORY IS CLOSED, IT MUST BE OPEN '// + . 'FOR INPUT') +901 CALL BORT('BUFRLIB: CPYMEM - LOGICAL UNIT NO. ASSOC. WITH INPUT'// + . ' BUFR MESSAGES IN INTERNAL MEMORY OPEN FOR OUTPUT, MUST BE '// + . ' OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE') +903 CALL BORT('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +904 CALL BORT('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +905 CALL BORT('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN '// + . 'OUTPUT BUFR FILE, A MESSAGE IS OPEN') +906 CALL BORT('BUFRLIB: CPYMEM - INPUT BUFR MESSAGES IN INTERNAL '// + . 'MEMORY AND OUTPUT BUFR FILE MUST HAVE SAME INTERNAL TABLES '// + . '(DIFFERENT HERE)') + + END diff --git a/src/bufr/cpyupd.f b/src/bufr/cpyupd.f new file mode 100644 index 0000000000..4faf788ed3 --- /dev/null +++ b/src/bufr/cpyupd.f @@ -0,0 +1,113 @@ + SUBROUTINE CPYUPD(LUNIT,LIN,LUN,IBYT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CPYUPD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A SUBSET FROM ONE MESSAGE BUFFER +C (ARRAY MBAY IN COMMON BLOCK /BITBUF/) TO ANOTHER AND/OR RESETS THE +C POINTERS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- USE MSGFULL +C +C USAGE: CALL CPYUPD (LUNIT, LIN, LUN, IBYT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LIN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR INPUT MESSAGE LOCATION +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR OUTPUT MESSAGE LOCATION +C IBYT - INTEGER: NUMBER OF BYTES OCCUPIED BY THIS SUBSET +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IUPB MSGFULL MSGINI +C MSGWRT MVB PKB +C THIS ROUTINE IS CALLED BY: COPYSB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + CHARACTER*128 BORT_STR + + LOGICAL MSGFULL + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C SEE IF THE NEW SUBSET FITS +C -------------------------- + + IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) THEN + CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) + CALL MSGINI(LUN) + ENDIF + + IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) GOTO 900 + +C TRANSFER SUBSET FROM ONE MESSAGE TO THE OTHER +C --------------------------------------------- + +C Note that we want to append the data for this subset to the end +C of Section 4, but the value in MBYT(LUN) already includes the +C length of Section 5 (i.e. 4 bytes). Therefore, we need to begin +C writing at the point 3 bytes prior to the byte currently pointed +C to by MBYT(LUN). + + CALL MVB(MBAY(1,LIN),MBYT(LIN)+1,MBAY(1,LUN),MBYT(LUN)-3,IBYT) + +C UPDATE THE SUBSET AND BYTE COUNTERS +C -------------------------------------- + + MBYT(LUN) = MBYT(LUN) + IBYT + NSUB(LUN) = NSUB(LUN) + 1 + + LBIT = (NBY0+NBY1+NBY2+4)*8 + CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT) + + LBYT = NBY0+NBY1+NBY2+NBY3 + NBYT = IUPB(MBAY(1,LUN),LBYT+1,24) + LBIT = LBYT*8 + CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT) + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: CPYUPD - THE LENGTH OF THIS SUBSET '// + . 'EXCEEDS THE MAXIMUM MESSAGE LENGTH (",I6,")")') MAXBYT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/crbmg.c b/src/bufr/crbmg.c new file mode 100644 index 0000000000..4633a501b2 --- /dev/null +++ b/src/bufr/crbmg.c @@ -0,0 +1,150 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CRBMG +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS ROUTINE READS THE NEXT BUFR MESSAGE FROM THE SYSTEM +C FILE MOST RECENTLY OPENED FOR READING/INPUT VIA BUFR ARCHIVE LIBRARY +C ROUTINE COBFL. ANY BUFR EDITION 0 OR EDITION 1 MESSAGES THAT ARE +C READ ARE AUTOMATICALLY CONVERTED TO BUFR EDITION 2. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL CRBMG( BMG, MXMB, NMB, IRET ) +C INPUT ARGUMENT LIST: +C MXMB - INTEGER: DIMENSIONED SIZE (IN BYTES) OF BMG; USED +C BY THE ROUTINE TO ENSURE THAT IT DOES NOT OVERFLOW +C THE BMG ARRAY +C +C OUTPUT ARGUMENT LIST: +C BMG - CHARACTER*1: ARRAY CONTAINING BUFR MESSAGE +C NMB - INTEGER: SIZE (IN BYTES) OF BUFR MESSAGE IN BMG +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C 1 = overflow of BMG array +C 2 = "7777" indicator not found in expected location +C -1 = end-of-file encountered while reading +C -2 = I/O error encountered while reading +C +C REMARKS: +C THIS ROUTINE CALLS: BORT GETS1LOC ICHKSTR IPKM +C IUPBS01 IUPM RBYTES +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) +{ + f77int i1 = 1, i2 = 2, i3 = 3, i4 = 4, i24 = 24; + f77int wkint[2]; + f77int iben, isbyt, iwid; + + char errstr[129]; + + unsigned short i, nsecs; + unsigned int lsec; +/* +** Make sure that a file is open for reading. +*/ + if ( pbf[0] == NULL ) { + sprintf( errstr, "BUFRLIB: CRBMG - NO FILE IS OPEN FOR READING" ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } +/* +** Initialize the first 4 characters of the output array to blanks. +*/ + if ( *mxmb < 4 ) { + *iret = 1; + return; + } + strncpy( bmg, " ", 4); +/* +** Look for the start of the next BUFR message. +*/ + while ( ichkstr( "BUFR", bmg, &i4, 4, 4 ) != 0 ) { + memmove( bmg, &bmg[1], 3 ); + if ( ( *iret = rbytes( bmg, mxmb, 3, 1 ) ) != 0 ) return; + } +/* +** Read the next 4 bytes and determine the BUFR edition number that was used +** to encode the message. +*/ + if ( ( *iret = rbytes( bmg, mxmb, 4, 4 ) ) != 0 ) return; + memcpy( wkint, bmg, 8 ); + iben = iupbs01( wkint, "BEN", 3 ); + + if ( iben >= 2 ) { +/* +** Get the length of the BUFR message. +*/ + *nmb = iupbs01( wkint, "LENM", 4 ); +/* +** Read the remainder of the BUFR message. +*/ + if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; + } + else { +/* +** Read the remainder of the BUFR message and then convert it to BUFR +** edition 2. The message length isn't encoded in Section 0, so we need +** to compute it by unpacking and summing the lengths of the individual +** sections. +*/ + lsec = 4; /* length of Section 0 */ +/* +** Get the length of Section 1 and add it to the total. +*/ + gets1loc( "LEN1", &iben, &isbyt, &iwid, &wkint[0], 4 ); + *nmb = lsec + iupm( &bmg[lsec+isbyt-1], &iwid, 3 ); +/* +** Read up through the end of Section 1. +*/ + if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; +/* +** Is there a Section 2? +*/ + gets1loc( "ISC2", &iben, &isbyt, &iwid, &wkint[0], 4 ); + nsecs = iupm( &bmg[lsec+isbyt-1], &iwid, 1 ) + 2; +/* +** Read up through the end of Section 4. +*/ + for ( i = 1; i <= nsecs; i++ ) { + if ( ( *iret = rbytes( bmg, mxmb, *nmb, 3 ) ) != 0 ) return; + lsec = iupm( &bmg[*nmb], &i24, 3 ); + if ( ( *iret = rbytes( bmg, mxmb, *nmb+3, lsec-3 ) ) != 0 ) return; + *nmb += lsec; + } +/* +** Read Section 5. +*/ + if ( ( *iret = rbytes( bmg, mxmb, *nmb, 4 ) ) != 0 ) return; + *nmb += 4; +/* +** Expand Section 0 from 4 bytes to 8 bytes, then encode the message length +** and new edition number (i.e. 2) into the new (expanded) Section 0. +*/ + if ( *nmb + 4 > *mxmb ) { + *iret = 1; + return; + } + memmove( &bmg[8], &bmg[4], *nmb-4 ); + *nmb += 4; + ipkm( &bmg[4], &i3, nmb, 3 ); + ipkm( &bmg[7], &i1, &i2, 1 ); + } +/* +** Check that the "7777" is in the expected location. +*/ + *iret = ( ( ichkstr( "7777", &bmg[*nmb-4], &i4, 4, 4 ) == 0 ) ? 0 : 2 ); + + return; +} diff --git a/src/bufr/cread.c b/src/bufr/cread.c new file mode 100644 index 0000000000..ed2f05088e --- /dev/null +++ b/src/bufr/cread.c @@ -0,0 +1,94 @@ +/*C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CREAD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 +C +C ABSTRACT: CREAD IS A PACKAGE OF C LANGUAGE I/O ROUTINES WHICH +C ARE DESIGNED TO OPERATE BUFRLIB INPUT AND OUTPUT +C FUNCTIONS IN A LESS RESTRICTIVE WAY COMPARED TO +C THOSE AVAILABLE IN STANDARD FORTRAN IMPLEMENTATIONS. +C THE PACKAGE CONSISTS OF THREE FILE OPEN ROUTINES, +C ONE FILE CLOSE ROUTINE, TWO FILE POSITIONING +C ROUTINES, ONE READ BUFR AND ONE WRITE BUFR ROUTINE. +C ARRAYS OF FILE CONNECTION DESCRIPTORS AND FILE +C POSITION POINTERS PROVIDE THE CONNECTION TO THE +C BUFRLIB INTERNAL FILE STATUS INDICATORS. THE +C BUFRLIB FILE CONNECTION INDEX LUN, OBTAINED BY +C CALLS TO STATUS, IS USED TO REFERENCE THE CREAD +C DESCRIPTOR AND POINTER ARRAYS. +C +C PROGRAM HISTORY LOG: +C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR +C +C USAGE: CALL openrb(nfile,ufile) - open ufile for binary reading +C CALL openwb(nfile,ufile) - open ufile for binary writing +C CALL openab(nfile,ufile) - open ufile for binary appending +C CALL backbufr(nfile) - backspace file nfile 1 message +C CALL cewind(nfile) - rewind file nfile to beginning +C CALL closfb(nfile) - disconnect file nfile from c +C CALL crdbufr(nfile,bufr,maxbyt) - read next bufr message from file nfile into bufr +C CALL cwrbufr(nfile,bufr,nwrd) - write bufr message from bufr into file nfile +C +C INPUT ARGUMENTS: +c nfile - integer bufrlib file connection index +C ufile - full file path/filename +c bufr - in crdbufr: char array to read a bufr message into +c maxbyt - in crdbufr: maximum number of bytes allowed to read +c bufr - in cwrbufr: integer array to write a bufr message from +c nwrd - in cwrbufr: number of words to write for bufr message +C +C OUTPUT ARGUMENTS: +c crdbufr - return code from reading +c -3 - sec0 message length > maxbyt +c -2 - error reading bufr message +c -1 - no more more messages in file +c 0 - read a bufr message +C +C REMARKS: +C THIS ROUTINE CALLS: IUPBS01 +C +C THIS ROUTINE IS CALLED BY: +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +/* The following arrays are dimensioned one larger than NFILES because of the difference in array + indexing between Fortran and C. In each of the following C functions, the value passed in for + nfile will a be Fortran index ranging from 1 to NFILES, so we need to allow for this same range + of values in C, which would otherwise expect the array indices to range from 0 to NFILES-1. */ +FILE *pb[NFILES+1]; fpos_t lstpos[NFILES+1]; + +void openrb (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "rb " ); } +void openwb (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "wb " ); } +void openab (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "a+b" ); } +void backbufr (nfile ) f77int *nfile; { fsetpos(pb[*nfile],&lstpos[*nfile]);} +void cewind (nfile ) f77int *nfile; { rewind(pb[*nfile]); } +void closfb (nfile ) f77int *nfile; { fclose(pb[*nfile]); } + +f77int crdbufr (nfile,bufr,mxbyt) +f77int *nfile; f77int *mxbyt; char *bufr; +{ f77int nbyt; f77int nb; f77int wkint[2]; fpos_t nxtpos; + fgetpos(pb[*nfile],&lstpos[*nfile]); + nb = sizeof(*bufr); bufr[0]=bufr[1]; + while ( strncmp(bufr,"BUFR",4)!=0) + { memmove(bufr,&bufr[1],3); + if(fread(bufr+3,nb,1,pb[*nfile])!=1) return -1; + } + fgetpos(pb[*nfile],&nxtpos); if(fread(bufr+4,nb,4,pb[*nfile])!=4) return -1; + memcpy(wkint,bufr,8); nbyt=iupbs01(wkint,"LENM",4)-8; + if(nbyt+8>*mxbyt) {fsetpos(pb[*nfile],&nxtpos);return -3;}; + if(fread(bufr+8,nb,nbyt,pb[*nfile])!=nbyt) {fsetpos(pb[*nfile],&nxtpos);return -2;}; + if(strncmp(bufr+nbyt+4,"7777",4)!=0) {fsetpos(pb[*nfile],&nxtpos);return -2;}; + return 0; +} + +void cwrbufr (nfile,bufr,nwrd) +f77int *nfile; f77int *nwrd; f77int *bufr; +{ f77int nb; nb = sizeof(*bufr); + fwrite(bufr,nb,*nwrd,pb[*nfile]); +} diff --git a/src/bufr/cwbmg.c b/src/bufr/cwbmg.c new file mode 100644 index 0000000000..a9c675b8ed --- /dev/null +++ b/src/bufr/cwbmg.c @@ -0,0 +1,54 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: CWBMG +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS ROUTINE WRITES A SPECIFIED NUMBER OF BYTES TO THE +C SYSTEM FILE MOST RECENTLY OPENED FOR WRITING/OUTPUT VIA BUFR +C ARCHIVE LIBRARY ROUTINE COBFL. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL CWBMG( BMG, NMB, IRET ) +C INPUT ARGUMENT LIST: +C BMG - CHARACTER*1: ARRAY CONTAINING BYTES TO BE WRITTEN +C NMB - INTEGER: NUMBER OF BYTES WITHIN BMG TO BE WRITTEN +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = I/O error occurred while writing +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +void cwbmg( char *bmg, f77int *nmb, f77int *iret ) +{ + char errstr[129]; + +/* +** Make sure that a file is open for writing. +*/ + if ( pbf[1] == NULL ) { + sprintf( errstr, "BUFRLIB: CWBMG - NO FILE IS OPEN FOR WRITING" ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } +/* +** Write the BUFR message to the file. +*/ + *iret = ( ( fwrite( bmg, 1, *nmb, pbf[1] ) == *nmb ) ? 0 : -1 ); + + return; +} diff --git a/src/bufr/datebf.f b/src/bufr/datebf.f new file mode 100644 index 0000000000..616528f607 --- /dev/null +++ b/src/bufr/datebf.f @@ -0,0 +1,142 @@ + SUBROUTINE DATEBF(LUNIT,MEAR,MMON,MDAY,MOUR,IDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DATEBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST +C NON-DICTIONARY BUFR MESSAGE IN LOGICAL UNIT LUNIT, REGARDLESS OF +C THE NUMBER OF SUBSETS IN THE MESSAGE. LUNIT SHOULD NOT BE +C PREVIOUSLY OPENED TO THE BUFR INTERFACE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 1998-08-31 J. WOOLLEN -- MODIFIED TO CORRECT AN ERROR WHICH LEAD TO +C THE YEAR BEING RETURNED IN "MEAR" AS 2- +C DIGIT YEAR WHEN A 4-DIGIT YEAR WAS +C REQUESTED VIA A PRIOR CALL TO DATELEN (THE +C CENTER DATE RETURNED IN "IDATE", IN THE +C FORM YYYYMMDDHH, WAS CORRECT IN THE +C PREVIOUS VERSION OF THIS ROUTINE +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRCT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC +C FUNCTION ICHAR WITH THE NCEP W3LIB C- +C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK +C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ +C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS +C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER +C USE FLOATING POINT ARITHMETIC SINCE THIS +C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER +C RESULTING DATE ON SOME MACHINES (E.G., NCEP +C IBM FROST/SNOW), INCREASES PORTABILITY; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN +C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY +C TO EBCDIC MACHINES +C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE +C INFORMATION (IN CASE IT HAS NOT YET BEEN +C CALLED), THIS ROUTINE DOES NOT REQUIRE IT +C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES +C THAT DO REQUIRE IT +C 2005-11-29 J. ATOR -- USE IGETDATE, IUPBS01 AND RDMSGW +C 2009-03-23 J. ATOR -- USE IDXMSG AND ERRWRT +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE +C THE C FILE WITHOUT CLOSING THE FORTRAN FILE +C +C +C USAGE: CALL DATEBF (LUNIT, MEAR, MMON, MDAY, MOUR, IDATE) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C MEAR - INTEGER: SECTION 1 YEAR (YYYY OR YY, DEPENDING ON +C DATELEN() VALUE +C MMON - INTEGER: SECTION 1 MONTH MM +C MDAY - INTEGER: SECTION 1 DAY DD +C MOUR - INTEGER: SECTION 1 HOUR HH +C IDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE IN +C FORMAT OF EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON +C DATELEN() VALUE; OR -1 IF SECTION 1 DATE COULD NOT BE +C LOCATED +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE +C RDMSGW STATUS WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET / IPRT + + DIMENSION MBAY(MXMSGLD4) + + CHARACTER*128 ERRSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION +C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) +C --------------------------------------------------------------- + + CALL WRDLEN + + IDATE = -1 + +C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) +C ----------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,JL,JM) + IF(JL.NE.0) GOTO 900 + CALL OPENBF(LUNIT,'INX',LUNIT) + +C READ TO A DATA MESSAGE AND PICK OUT THE DATE +C -------------------------------------------- + +1 CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.LT.0) GOTO 100 + IF(IDXMSG(MBAY).EQ.1) GOTO 1 + + IDATE = IGETDATE(MBAY,MEAR,MMON,MDAY,MOUR) + +100 IF(IPRT.GE.1 .AND. IDATE.EQ.-1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: DATEBF - SECTION 1 DATE COULD NOT BE '// + . 'LOCATED - RETURN WITH IDATE = -1' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXITS +C ----- + + CALL CLOSBF(LUNIT) + RETURN +900 CALL BORT + . ('BUFRLIB: DATEBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + END diff --git a/src/bufr/datelen.f b/src/bufr/datelen.f new file mode 100644 index 0000000000..0d0a6dcb24 --- /dev/null +++ b/src/bufr/datelen.f @@ -0,0 +1,73 @@ + SUBROUTINE DATELEN(LEN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DATELEN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 +C +C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY THE LENGTH OF DATE-TIME +C VALUES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR +C ARCHIVE LIBRARY SUBROUTINES WHICH READ BUFR MESSAGES (E.G. READMG, +C READERME, ETC.). POSSIBLE VALUES ARE "8" (WHICH IS THE DEFAULT) +C AND "10". +C +C PROGRAM HISTORY LOG: +C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN READMG) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE +C INFORMATION (IN CASE IT HAS NOT YET BEEN +C CALLED), THIS ROUTINE DOES NOT REQUIRE IT +C BUT IT MAY SOMEDAY CALL OTHER ROUTINES THAT +C DO REQUIRE IT +C +C USAGE: CALL DATELEN (LEN) +C INPUT ARGUMENT LIST: +C LEN - INTEGER: LENGTH OF DATE-TIME VALUES TO BE OUTPUT BY +C READ SUBROUTINES: * +C 8 = YYMMDDHH (2-digit year) +C 10 = YYYYMMDDHH (4-digit year) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /DATELN/ LENDAT + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION +C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) +C --------------------------------------------------------------- + + CALL WRDLEN + + IF(LEN.NE.8 .AND. LEN.NE.10) GOTO 900 + LENDAT = LEN + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: DATELEN - INPUT ARGUMENT IS",I4," - '// + . 'IT MUST BE EITHER 8 OR 10")') LEN + CALL BORT(BORT_STR) + END diff --git a/src/bufr/digit.f b/src/bufr/digit.f new file mode 100644 index 0000000000..4aa114a250 --- /dev/null +++ b/src/bufr/digit.f @@ -0,0 +1,52 @@ + LOGICAL FUNCTION DIGIT(STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DIGIT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS LOGICAL FUNCTION TESTS THE CHARACTERS IN A STRING TO +C DETERMINE IF THEY ARE ALL DIGITS ('0','1','2','3','4','5','6','7', +C '8' OR '9'). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2007-01-19 J. ATOR -- SIMPLIFIED LOGIC +C 2009-03-23 J. ATOR -- FIXED MINOR BUG CAUSED BY TYPO +C +C USAGE: DIGIT (STR) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING +C +C OUTPUT ARGUMENT LIST: +C DIGIT - LOGICAL: TRUE IF ALL CHARACTERS IN STR ARE DIGITS +C ('0' - '9'), OTHERWISE FALSE +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: CKTABA NUMBCK STNTBIA +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + DIGIT = .FALSE. + DO I=1,LEN(STR) + IF( LLT(STR(I:I),'0') .OR. LGT(STR(I:I),'9') ) GOTO 100 + ENDDO + DIGIT = .TRUE. + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/drfini.f b/src/bufr/drfini.f new file mode 100644 index 0000000000..fc5be3b35b --- /dev/null +++ b/src/bufr/drfini.f @@ -0,0 +1,105 @@ + SUBROUTINE DRFINI(LUNIT,MDRF,NDRF,DRFTAG) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DRFINI +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE INITIALIZES DELAYED REPLICATION FACTORS +C AND EXPLICITLY ALLOCATES A CORRESPONDING AMOUNT OF SPACE IN THE +C INTERNAL SUBSET ARRAYS, THEREBY ALLOWING THE SUBSEQUENT USE OF BUFR +C ARCHIVE LIBRARY SUBROUTINE UFBSEQ TO WRITE DATA DIRECTLY INTO +C DELAYED REPLICATION SEQUENCES. NOTE THAT THIS SAME TYPE OF +C INITIALIZATION IS DONE IMPLICTLY WITHIN BUFR ARCHIVE LIBRARY +C SUBROUTINE UFBINT FOR DELAYED REPLICATION SEQUENCES WHICH APPEAR +C ONLY ONE TIME WITHIN AN OVERALL SUBSET DEFINITION. HOWEVER, BY +C USING SUBROUTINE DRFINI ALONG WITH A SUBSEQUENT CALL TO SUBROUTINE +C UFBSEQ, IT IS ACTUALLY POSSIBLE TO HAVE MULTIPLE OCCURRENCES OF A +C PARTICULAR DELAYED REPLICATION SEQUENCE WITHIN A SINGLE OVERALL +C SUBSET DEFINITION. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2005-03-04 J. ATOR -- UPDATED DOCUMENTATION +C +C USAGE: CALL DRFINI (LUNIT, MDRF, NDRF, DRFTAG) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C MDRF - INTEGER: ARRAY OF DELAYED REPLICATION FACTORS, +C IN ONE-TO-ONE CORRESPONDENCE WITH THE NUMBER OF +C OCCURRENCES OF DRFTAG WITHIN THE OVERALL SUBSET +C DEFINITION, AND EXPLICITLY DEFINING HOW MUCH SPACE +C (I.E. HOW MANY REPLICATIONS) TO ALLOCATE WITHIN +C EACH SUCCESSIVE OCCURRENCE +C NDRF - INTEGER: NUMBER OF DELAYED REPLICATION FACTORS +C WITHIN MDRF +C DRFTAG - CHARACTER*(*): SEQUENCE MNEMONIC, BRACKETED BY +C APPROPRIATE DELAYED REPLICATION NOTATION +C (E.G. {}, () OR <>) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT STATUS USRTPL +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*(*) DRFTAG + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*3 TYP + REAL*8 VAL + DIMENSION MDRF(NDRF) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(NDRF.GT.100) GOTO 900 + + CALL STATUS(LUNIT,LUN,IL,IM) + +C COMFORM THE TEMPLATES TO THE DELAYED REPLICATION FACTORS +C -------------------------------------------------------- + + M = 0 + N = 0 + +10 DO N=N+1,NVAL(LUN) + NODE = INV(N,LUN) + IF(ITP(NODE).EQ.1 .AND. TAG(NODE).EQ.DRFTAG) THEN + M = M+1 + CALL USRTPL(LUN,N,MDRF(M)) + GOTO 10 + ENDIF + ENDDO + +C EXITS +C ----- + + RETURN + 900 WRITE(BORT_STR,'("BUFRLIB: DRFINI - THE NUMBER OF DELAYED '// + . 'REPLICATION FACTORS (",I5,") EXCEEDS THE LIMIT (100)")') NDRF + CALL BORT(BORT_STR) + END diff --git a/src/bufr/drstpl.f b/src/bufr/drstpl.f new file mode 100644 index 0000000000..0265a1a8e1 --- /dev/null +++ b/src/bufr/drstpl.f @@ -0,0 +1,99 @@ + SUBROUTINE DRSTPL(INOD,LUN,INV1,INV2,INVN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DRSTPL +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE IS CALLED BY BUFR ARCHIVE LIBRARY SUBROUTINE +C UFBRW WHENEVER IT CAN'T FIND A MNEMONIC IT WANTS TO WRITE WITHIN THE +C CURRENT SUBSET BUFFER. IT LOOKS FOR THE MNEMONIC WITHIN ANY +C UNEXPANDED "DRS" (STACK) OR "DRB" (1-BIT DELAYED REPLICATION) +C SEQUENCES INSIDE OF THE PORTION OF THE SUBSET BUFFER BOUNDED BY THE +C INDICES INV1 AND INV2. IF FOUND, IT EXPANDS THE APPLICABLE "DRS" OR +C "DRB" SEQUENCE TO THE POINT WHERE THE MNEMONIC IN QUESTION NOW +C APPEARS IN THE SUBSET BUFFER, AND IN DOING SO IT WILL ALSO RETURN +C A NEW VALUE FOR INV2. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" (LATER REMOVED, UNKNOWN +C WHEN) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION +C +C USAGE: CALL DRSTPL (INOD, LUN, INV1, INV2, INVN) +C +C INPUT ARGUMENT LIST: +C INOD - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET +C BUFFER CURRENTLY BEING PROCESSED BY UFBRW +C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET +C BUFFER CURRENTLY BEING PROCESSED BY UFBRW +C +C OUTPUT ARGUMENT LIST: +C INVN - INTEGER: LOCATION INDEX OF INOD WITHIN SUBSET BUFFER: +C 0 = NOT FOUND +C INV2 - INTEGER: IF INVN = 0, THEN INV2 IS UNCHANGED FROM ITS +C INPUT VALUE. OTHERWISE, IT CONTAINS THE REDEFINED +C ENDING INDEX OF THE PORTION OF THE SUBSET BUFFER +C CURRENTLY BEING PROCESSED BY UFBRW, SINCE EXPANDING A +C DELAYED REPLICATION SEQUENCE WILL HAVE NECESSARILY +C INCREASED THE SIZE OF THIS BUFFER. +C +C REMARKS: +C THIS ROUTINE CALLS: INVWIN NEWWIN USRTPL +C THIS ROUTINE IS CALLED BY: UFBRW +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +1 NODE = INOD +2 NODE = JMPB(NODE) + IF(NODE.EQ.0) GOTO 100 + IF(TYP(NODE).EQ.'DRS' .OR. TYP(NODE).EQ.'DRB') THEN + INVN = INVWIN(NODE,LUN,INV1,INV2) + IF(INVN.GT.0) THEN + CALL USRTPL(LUN,INVN,1) + CALL NEWWIN(LUN,INV1,INV2) + INVN = INVWIN(INOD,LUN,INVN,INV2) + IF(INVN.GT.0) GOTO 100 + GOTO 1 + ENDIF + ENDIF + GOTO 2 + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/dumpbf.f b/src/bufr/dumpbf.f new file mode 100644 index 0000000000..ba2a318de3 --- /dev/null +++ b/src/bufr/dumpbf.f @@ -0,0 +1,174 @@ + SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DUMPBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-12-11 +C +C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST +C TWO NON-DICTIONARY BUFR MESSAGES IN LOGICAL UNIT LUNIT WHICH +C CONTAIN ZERO SUBSETS. NORMALLY, THESE "DUMMY" MESSAGES APPEAR +C ONLY IN DATA DUMP FILES AND ARE IMMEDIATELY AFTER THE DICTIONARY +C MESSAGES. THEY CONTAIN A DUMP "CENTER TIME" AND A DUMP FILE +C "PROCESSING TIME", RESPECTIVELY. LUNIT SHOULD NOT BE PREVIOUSLY +C OPENED TO THE BUFR INTERFACE. +C +C PROGRAM HISTORY LOG: +C 1996-12-11 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-12-17 J. WOOLLEN -- CORRECTED ERROR IN DUMP DATE READER +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC +C FUNCTION ICHAR WITH THE NCEP W3LIB C- +C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK +C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ +C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS +C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER +C USE FLOATING POINT ARITHMETIC SINCE THIS +C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER +C RESULTING DATE ON SOME MACHINES (E.G., NCEP +C IBM FROST/SNOW), INCREASES PORTABILITY; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN +C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY +C TO EBCDIC MACHINES +C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE +C INFORMATION (IN CASE IT HAS NOT YET BEEN +C CALLED), THIS ROUTINE DOES NOT REQUIRE IT +C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES +C THAT DO REQUIRE IT +C 2005-11-29 J. ATOR -- USE IUPBS01, IGETDATE, GETLENS AND RDMSGW +C 2009-03-23 J. ATOR -- USE IDXMSG, IUPBS3 AND ERRWRT +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE +C THE C FILE WITHOUT CLOSING THE FORTRAN FILE +C +C USAGE: CALL DUMPBF (LUNIT, JDATE, JDUMP) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C JDATE - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR +C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), +C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE +C FIRST NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS +C (NORMALLY THE DATA DUMP CENTER TIME IN A DATA DUMP +C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED +C JDUMP - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR +C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), +C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE +C SECOND NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS +C (NORMALLY THE FILE PROCESSING TIME IN A DATA DUMP +C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE +C IUPBS01 IUPBS3 RDMSGW STATUS +C WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET / IPRT + + DIMENSION MBAY(MXMSGLD4) + DIMENSION JDATE(5),JDUMP(5) + + CHARACTER*128 ERRSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION +C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) +C --------------------------------------------------------------- + + CALL WRDLEN + + DO I=1,5 + JDATE(I) = -1 + JDUMP(I) = -1 + ENDDO + +C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) +C ----------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,JL,JM) + IF(JL.NE.0) GOTO 900 + call openbf(lunit,'INX',lunit) + +C READ PAST ANY DICTIONARY MESSAGES +C --------------------------------- + +1 CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.LT.0) GOTO 200 + IF(IDXMSG(MBAY).EQ.1) GOTO 1 + +C DUMP CENTER YY,MM,DD,HH,MM IS IN THE FIRST EMPTY MESSAGE +C -------------------------------------------------------- +C i.e. the first message containing zero subsets + + IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200 + + IGD = IGETDATE(MBAY,JDATE(1),JDATE(2),JDATE(3),JDATE(4)) + JDATE(5) = IUPBS01(MBAY,'MINU') + +C DUMP CLOCK YY,MM,DD,HH,MM IS IN THE SECOND EMPTY MESSAGE +C -------------------------------------------------------- +C i.e. the second message containing zero subsets + + CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.LT.0) GOTO 200 + + IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200 + + IGD = IGETDATE(MBAY,JDUMP(1),JDUMP(2),JDUMP(3),JDUMP(4)) + JDUMP(5) = IUPBS01(MBAY,'MINU') + + call closbf(lunit) + GOTO 100 + +200 IF(IPRT.GE.1 .AND. (JDATE(1).EQ.-1.OR.JDUMP(1).EQ.-1)) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + IF(JDATE(1).EQ.-1) THEN + ERRSTR = 'BUFRLIB: DUMPBF - FIRST EMPTY BUFR MESSAGE '// + . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// + . 'JDATE = 4*-1' + CALL ERRWRT(ERRSTR) + ENDIF + IF(JDUMP(1).EQ.-1) THEN + ERRSTR = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE '// + . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// + . 'JDUMP = 4*-1' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT + . ('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + END diff --git a/src/bufr/dxdump.f b/src/bufr/dxdump.f new file mode 100644 index 0000000000..675e2c0514 --- /dev/null +++ b/src/bufr/dxdump.f @@ -0,0 +1,334 @@ + SUBROUTINE DXDUMP(LUNIT,LDXOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DXDUMP +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: THIS SUBROUTINE WRITES, TO LOGICAL UNIT LDXOT, AN ASCII +C COPY OF THE BUFR DICTIONARY TABLE INFORMATION ASSOCIATED WITH +C THE BUFR FILE DEFINED BY LOGICAL UNIT LUNIT. IT IS ESPECIALLY +C USEFUL FOR DETERMINING THE CONTENTS OF ARCHIVE BUFR FILES WHICH +C MAY HAVE SUCH INFORMATION EMBEDDED AS DX MESSAGES AT THE FRONT +C OF THE FILE. THE OUTPUT FILE WILL BE IN A FORMAT SUITABLE FOR +C SUBSEQUENT INPUT AS A USER-DEFINED DICTIONARY TABLES FILE TO +C BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND IN THAT SENSE THIS +C SUBROUTINE CAN BE VIEWED AS THE LOGICAL INVERSE OF BUFR ARCHIVE +C LIBRARY SUBROUTINE RDUSDX. NOTE THAT THE BUFR FILE ASSOCIATED +C WITH LOGICAL UNIT LUNIT MUST HAVE ALREADY BEEN IDENTIFIED TO +C THE BUFR ARCHIVE LIBRARY SOFTWARE VIA A PRIOR CALL TO OPENBF. +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C 2007-01-19 J. ATOR -- CORRECTED OUTPUT FOR REFERENCE VALUES +C LONGER THAN 8 DIGITS +C +C USAGE: CALL DXDUMP (LUNIT, LDXOT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LDXOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT FILE +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE WITH EMBEDDED DX DICTIONARY MESSAGES +C +C OUTPUT FILES: +C UNIT "LDXOT" - ASCII VERSION OF DX DICTIONARY INFORMATION, IN +C FORMAT SUITABLE FOR SUBSEQUENT INPUT TO OPENBF +C +C REMARKS: +C THIS ROUTINE CALLS: BORT NEMTBD STATUS STRSUC +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*80 CARD,CARDI1,CARDI2,CARDI3,CARDI4 + CHARACTER*20 CMSTR + CHARACTER*10 WRK3 + CHARACTER*8 NEMS(MAXCD),WRK1,WRK2 + CHARACTER*6 ADN + CHARACTER*3 TYPS + CHARACTER*1 REPS + + DIMENSION IRPS(MAXCD),KNTS(MAXCD) + + LOGICAL TBSKIP, TDSKIP, XTRCI1 + + DATA CARDI1( 1:40) + . /'| | | '/ + DATA CARDI1(41:80) + . /' |'/ + DATA CARDI2( 1:40) + . /'| | '/ + DATA CARDI2(41:80) + . /' |'/ + DATA CARDI3( 1:40) + . /'| | | | | '/ + DATA CARDI3(41:80) + . /' |-------------|'/ + DATA CARDI4( 1:40) + . /'|---------------------------------------'/ + DATA CARDI4(41:80) + . /'---------------------------------------|'/ + +C----------------------------------------------------------------------- + TBSKIP(ADN) = ((ADN.EQ.'063000').OR.(ADN.EQ.'063255').OR. + . (ADN.EQ.'031000').OR.(ADN.EQ.'031001').OR. + . (ADN.EQ.'031002')) + TDSKIP(ADN) = ((ADN.EQ.'360001').OR.(ADN.EQ.'360002').OR. + . (ADN.EQ.'360003').OR.(ADN.EQ.'360004')) +C----------------------------------------------------------------------- + +C DETERMINE LUN FROM LUNIT. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + +C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE +C DESCRIPTOR DEFINITION SECTION. + + CARD=CARDI4 + CARD( 1: 1)='.' + CARD(80:80)='.' + WRITE (LDXOT,'(A)') CARD + + CARD=CARDI4 + CARD( 2: 2)=' ' + CARD(79:79)=' ' + CARD(15:64)=' USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D ' + WRITE (LDXOT,'(A)') CARD + + WRITE (LDXOT,'(A)') CARDI4 + + CARD=CARDI1 + CARD( 3:10)='MNEMONIC' + CARD(14:19)='NUMBER' + CARD(23:33)='DESCRIPTION' + WRITE (LDXOT,'(A)') CARD + + CARD=CARDI4 + CARD(12:12)='|' + CARD(21:21)='|' + WRITE (LDXOT,'(A)') CARD + +C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR +C DEFINITION CARDS. + + WRITE (LDXOT,'(A)') CARDI1 + + XTRCI1=.FALSE. + DO N=1,NTBD(LUN) + IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN + CARD=CARDI1 + CARD( 3:10)=TABD(N,LUN)( 7:14) + CARD(14:19)=TABD(N,LUN)( 1: 6) + CARD(23:77)=TABD(N,LUN)(16:70) + +C CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC. +C IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE +C LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA +C CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE +C THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS. + + DO NA=1,NTBA(LUN) + IF(TABA(NA,LUN)(4:11).EQ.TABD(N,LUN)(7:14)) THEN + CARD(14:14)='A' + IF(NA.EQ.NTBA(LUN)) XTRCI1=.TRUE. + GOTO 10 + END IF + END DO + 10 WRITE (LDXOT,'(A)') CARD + IF(XTRCI1) THEN + WRITE (LDXOT,'(A)') CARDI1 + XTRCI1=.FALSE. + END IF + END IF + END DO + +C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR +C DEFINITION CARDS. + + WRITE (LDXOT,'(A)') CARDI1 + + DO N=1,NTBB(LUN) + IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN + CARD=CARDI1 + CARD( 3:10)=TABB(N,LUN)( 7:14) + CARD(14:19)=TABB(N,LUN)( 1: 6) + CARD(23:77)=TABB(N,LUN)(16:70) + WRITE (LDXOT,'(A)') CARD + END IF + END DO + + WRITE (LDXOT,'(A)') CARDI1 + +C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE +C SEQUENCE DEFINITION SECTION. + + WRITE (LDXOT,'(A)') CARDI4 + + CARD=CARDI2 + CARD( 3:10)='MNEMONIC' + CARD(14:21)='SEQUENCE' + WRITE (LDXOT,'(A)') CARD + + CARD=CARDI4 + CARD(12:12)='|' + WRITE (LDXOT,'(A)') CARD + +C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE +C DEFINITION CARDS. + + WRITE (LDXOT,'(A)') CARDI2 + + DO N=1,NTBD(LUN) + IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN + CARD=CARDI2 + CARD( 3:10)=TABD(N,LUN)( 7:14) + IC = 14 + +C GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR, +C AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO +C THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR. + + CALL NEMTBD(LUN,N,NSEQ,NEMS,IRPS,KNTS) + IF(NSEQ.GT.0) THEN + DO NC=1,NSEQ + CMSTR=' ' + ICMS=0 + CALL STRSUC(NEMS(NC),WRK2,NCH) + IF(IRPS(NC).NE.0) THEN + +C ADD THE OPENING REPLICATION TAG. + + ICMS=ICMS+1 + CMSTR(ICMS:ICMS)=REPS(IRPS(NC),1) + END IF + CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH) + ICMS=ICMS+NCH + IF(IRPS(NC).NE.0) THEN + +C ADD THE CLOSING REPLICATION TAG. + + ICMS=ICMS+1 + CMSTR(ICMS:ICMS)=REPS(IRPS(NC),2) + END IF + IF(KNTS(NC).NE.0) THEN + +C ADD THE FIXED REPLICATION COUNT. + + WRK1=' ' + WRITE (WRK1,'(I3)') KNTS(NC) + CALL STRSUC(WRK1,WRK2,NCH) + CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH) + ICMS=ICMS+NCH + END IF + +C WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT +C INTO THE CURRENT SEQUENCE DEFINITION CARD? IF NOT, THEN +C WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A +C NEW ONE TO HOLD THIS CHILD. + + IF(IC.GT.(79-ICMS)) THEN + WRITE (LDXOT,'(A)') CARD + CARD=CARDI2 + CARD( 3:10)=TABD(N,LUN)( 7:14) + IC = 14 + END IF + CARD(IC:IC+ICMS-1)=CMSTR(1:ICMS) + +C NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH +C CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE +C READABILITY). + + IC=IC+ICMS+2 + END DO + WRITE (LDXOT,'(A)') CARD + WRITE (LDXOT,'(A)') CARDI2 + END IF + END IF + END DO + +C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE +C ELEMENT DEFINITION SECTION. + + WRITE (LDXOT,'(A)') CARDI4 + + CARD=CARDI3 + CARD( 3:10)='MNEMONIC' + CARD(14:17)='SCAL' + CARD(21:29)='REFERENCE' + CARD(35:37)='BIT' + CARD(41:45)='UNITS' + WRITE (LDXOT,'(A)') CARD + + CARD=CARDI4 + CARD(12:12)='|' + CARD(19:19)='|' + CARD(33:33)='|' + CARD(39:39)='|' + CARD(66:66)='|' + WRITE (LDXOT,'(A)') CARD + +C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT +C DEFINITION CARDS. + + WRITE (LDXOT,'(A)') CARDI3 + + DO N=1,NTBB(LUN) + IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN + CARD=CARDI3 + CARD( 3:10)=TABB(N,LUN)( 7:14) + CARD(41:64)=TABB(N,LUN)(71:94) + +C ADD THE SCALE FACTOR. + + CALL STRSUC(TABB(N,LUN)(96:98),WRK2,NCH) + CARD(17-NCH+1:17)=WRK2 + IF(TABB(N,LUN)(95:95).EQ.'-') CARD(17-NCH:17-NCH)='-' + +C ADD THE REFERENCE VALUE. + + CALL STRSUC(TABB(N,LUN)(100:109),WRK3,NCH) + CARD(31-NCH+1:31)=WRK3 + IF(TABB(N,LUN)(99:99).EQ.'-') CARD(31-NCH:31-NCH)='-' + +C ADD THE BIT WIDTH. + + CALL STRSUC(TABB(N,LUN)(110:112),WRK2,NCH) + CARD(37-NCH+1:37)=WRK2 + WRITE (LDXOT,'(A)') CARD + END IF + END DO + + WRITE (LDXOT,'(A)') CARDI3 + +C CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD. + + CARD=CARDI4 + CARD( 1: 1)='`' + CARD(80:80)='''' + WRITE (LDXOT,'(A)') CARD + + RETURN +900 CALL BORT('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') + + END diff --git a/src/bufr/dxinit.f b/src/bufr/dxinit.f new file mode 100644 index 0000000000..371dec6558 --- /dev/null +++ b/src/bufr/dxinit.f @@ -0,0 +1,141 @@ + SUBROUTINE DXINIT(LUN,IOI) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DXINIT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE INITIALIZES THE INTERNAL ARRAYS +C (COMMON BLOCK /TABABD/) HOLDING THE DICTIONARY TABLE. IT THEN +C INITIALIZES THE TABLE WITH APRIORI TABLE B AND D ENTRIES +C (OPTIONAL). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2009-03-23 J. ATOR -- REMOVE INITIALIZATION OF COMMON /MSGCWD/ +C +C USAGE: CALL DXINIT (LUN, IOI) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IOI - INTEGER: SWITCH: +C 0 = do not initialize the table with apriori +C Table B and D entries +C else = initialize the table with apriori Table B +C and D entries +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 IFXY PKTDD +C THIS ROUTINE IS CALLED BY: CPBFDX OPENBF RDBFDX RDUSDX +C READERME READS3 +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 + COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*8 INIB(6,5),INID(5) + CHARACTER*6 ADN30 + CHARACTER*3 TYPS + CHARACTER*1 REPS + + DATA INIB /'------','BYTCNT ','BYTES ','+0','+0','16', + . '------','BITPAD ','NONE ','+0','+0','1 ', + . '031000','DRF1BIT ','NUMERIC','+0','+0','1 ', + . '031001','DRF8BIT ','NUMERIC','+0','+0','8 ', + . '031002','DRF16BIT','NUMERIC','+0','+0','16'/ + DATA NINIB /5/ + + DATA INID /' ', + . 'DRP16BIT', + . 'DRP8BIT ', + . 'DRPSTAK ', + . 'DRP1BIT '/ + DATA NINID /5/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CLEAR OUT A TABLE PARTITION +C --------------------------- + + NTBA(LUN) = 0 + DO I=1,NTBA(0) + TABA(I,LUN) = ' ' + MTAB(I,LUN) = 0 + ENDDO + + NTBB(LUN) = 0 + DO I=1,NTBB(0) + TABB(I,LUN) = ' ' + ENDDO + + NTBD(LUN) = 0 + DO I=1,NTBD(0) + TABD(I,LUN) = ' ' +c .... This zeroes the counter in TABD array, IRET returns as 0 and +c is not tested + CALL PKTDD(I,LUN,0,IRET) + ENDDO + + IF(IOI.EQ.0) GOTO 100 + +C INITIALIZE TABLE WITH APRIORI TABLE B AND D ENTRIES +C --------------------------------------------------- + + INIB(1,1) = ADN30(IBCT,6) + INIB(1,2) = ADN30(IPD4,6) + + DO I=1,NINIB + NTBB(LUN) = NTBB(LUN)+1 + IDNB(I,LUN) = IFXY(INIB(1,I)) + TABB(I,LUN)( 1: 6) = INIB(1,I) + TABB(I,LUN)( 7: 70) = INIB(2,I) + TABB(I,LUN)( 71: 94) = INIB(3,I) + TABB(I,LUN)( 95: 98) = INIB(4,I) + TABB(I,LUN)( 99:109) = INIB(5,I) + TABB(I,LUN)(110:112) = INIB(6,I) + ENDDO + + DO I=2,NINID + N = NTBD(LUN)+1 + IDND(N,LUN) = IDNR(I,1) + TABD(N,LUN)(1: 6) = ADN30(IDNR(I,1),6) + TABD(N,LUN)(7:70) = INID(I) +c .... DK: what if IRET = -1 ??? + CALL PKTDD(N,LUN,IDNR(1,1),IRET) +c .... DK: what if IRET = -1 ??? + CALL PKTDD(N,LUN,IDNR(I,2),IRET) + NTBD(LUN) = N + ENDDO + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/dxmini.f b/src/bufr/dxmini.f new file mode 100644 index 0000000000..1425635aa6 --- /dev/null +++ b/src/bufr/dxmini.f @@ -0,0 +1,178 @@ + SUBROUTINE DXMINI(LUN,MBAY,MBYT,MB4,MBA,MBB,MBD) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: DXMINI +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE INITIALIZES A BUFR TABLE (DICTIONARY) +C MESSAGE, WRITING ALL THE PRELIMINARY INFORMATION INTO SECTIONS 0, +C 1, 3, 4. BUFR ARCHIVE LIBRARY SUBROUTINE WRDXTB WILL WRITE THE +C ACTUAL TABLE INFORMATION INTO THE MESSAGE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION +C WRITTEN IN SECTION 0 FROM 2 TO 3 +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 +C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13 +C +C USAGE: CALL DXMINI (LUN, MBAY, MBYT, MB4, MBA, MBB, MBD) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C OUTPUT ARGUMENT LIST: +C MBAY - INTEGER: (MXMSGLD4)-WORD PACKED BINARY ARRAY +C CONTAINING BUFR MESSAGE +C MBYT - INTEGER: LENGTH OF BUFR MESSAGE (BYTES) +C MB4 - INTEGER: BYTE NUMBER IN MESSAGE OF FIRST BYTE IN +C SECTION 4 +C MBA - INTEGER: BYTE NUMBER IN MESSAGE OF FOURTH BYTE IN +C SECTION 4 +C MBB - INTEGER: BYTE NUMBER IN MESSAGE OF FIFTH BYTE IN +C SECTION 4 +C MBD - INTEGER: BYTE NUMBER IN MESSAGE OF SIXTH BYTE IN +C SECTION 4 +C +C REMARKS: +C ARGUMENT LUN IS NOT REFERENCED IN THIS SUBROUTINE. IT IS LEFT +C HERE IN CASE AN APPLICATION PROGRAM CALLS THIS SUBROUTINE. +C +C THIS ROUTINE CALLS: BORT IUPM PKB PKC +C THIS ROUTINE IS CALLED BY: WRDXTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + + CHARACTER*128 BORT_STR + CHARACTER*56 DXSTR + DIMENSION MBAY(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +c .... The local message subtype is set to the version number of the +c local tables (here = 1) + MSBT = IDXV + +C INITIALIZE THE MESSAGE +C ---------------------- + + MBIT = 0 + DO I=1,MXMSGLD4 + MBAY(I) = 0 + ENDDO + +C For dictionary messages, the Section 1 date is simply zeroed out. +C (Note that there is logic in function IDXMSG which relies on this!) + + IH = 0 + ID = 0 + IM = 0 + IY = 0 + +c Dictionary messages get type 11 (see WMO Table A) + MTYP = 11 + NSUB = 1 + + IDXS = IDXV+1 + LDXS = NXSTR(IDXS) + + NBY0 = 8 + NBY1 = 18 + NBY2 = 0 + NBY3 = 7 + NXSTR(IDXS) + 1 + NBY4 = 7 + NBY5 = 4 + MBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5 + + IF(MOD(NBY3,2).NE.0) GOTO 900 + +C SECTION 0 +C --------- + + CALL PKC('BUFR' , 4 , MBAY,MBIT) + CALL PKB( MBYT , 24 , MBAY,MBIT) + CALL PKB( 3 , 8 , MBAY,MBIT) + +C SECTION 1 +C --------- + + CALL PKB( NBY1 , 24 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + CALL PKB( 3 , 8 , MBAY,MBIT) + CALL PKB( 7 , 8 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + CALL PKB( MTYP , 8 , MBAY,MBIT) + CALL PKB( MSBT , 8 , MBAY,MBIT) + CALL PKB( 13 , 8 , MBAY,MBIT) + CALL PKB( IDXV , 8 , MBAY,MBIT) + CALL PKB( IY , 8 , MBAY,MBIT) + CALL PKB( IM , 8 , MBAY,MBIT) + CALL PKB( ID , 8 , MBAY,MBIT) + CALL PKB( IH , 8 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + +C SECTION 3 +C --------- + + CALL PKB( NBY3 , 24 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + CALL PKB( 1 , 16 , MBAY,MBIT) + CALL PKB( 2**7 , 8 , MBAY,MBIT) + DO I=1,LDXS + CALL PKB(IUPM(DXSTR(IDXS)(I:I),8),8,MBAY,MBIT) + ENDDO + CALL PKB( 0 , 8 , MBAY,MBIT) + +C SECTION 4 +C --------- + + MB4 = MBIT/8+1 + CALL PKB(NBY4 , 24 , MBAY,MBIT) + CALL PKB( 0 , 8 , MBAY,MBIT) + MBA = MBIT/8+1 + CALL PKB( 0 , 8 , MBAY,MBIT) + MBB = MBIT/8+1 + CALL PKB( 0 , 8 , MBAY,MBIT) + MBD = MBIT/8+1 + CALL PKB( 0 , 8 , MBAY,MBIT) + + IF(MBIT/8+NBY5.NE.MBYT) GOTO 901 + +C EXITS +C ----- + + RETURN +900 CALL BORT + . ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') +901 WRITE(BORT_STR,'("BUFRLIB: DXMINI - NUMBER OF BYTES STORED FOR '// + . 'A MESSAGE (",I6,") IS NOT THE SAME AS FIRST CALCULATED, MBYT '// + . '(",I6)') MBIT/8+NBY5,MBYT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/elemdx.f b/src/bufr/elemdx.f new file mode 100644 index 0000000000..dac17c052d --- /dev/null +++ b/src/bufr/elemdx.f @@ -0,0 +1,149 @@ + SUBROUTINE ELEMDX(CARD,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ELEMDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE DECODES THE SCALE FACTOR, REFERENCE VALUE, +C BIT WIDTH AND UNITS (I.E., THE "ELEMENTS") FROM A TABLE B MNEMONIC +C DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A USER-SUPPLIED BUFR +C DICTIONARY TABLE FILE IN CHARACTER FORMAT BY BUFR ARCHIVE LIBRARY +C SUBROUTINE RDUSDX. THESE DECODED VALUES ARE THEN ADDED TO THE +C ALREADY-EXISTING ENTRY FOR THAT MNEMONIC WITHIN THE INTERNAL BUFR +C TABLE B ARRAY TABB(*,LUN) IN COMMON BLOCK /TABABD/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 +C 2007-01-19 J. ATOR -- ADDED EXTRA ARGUMENT FOR CALL TO JSTCHR +C +C USAGE: CALL ELEMDX (CARD, LUN) +C INPUT ARGUMENT LIST: +C CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ +C FROM A USER-SUPPLIED BUFR DICTIONARY TABLE +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 CAPIT JSTCHR JSTNUM +C NEMTAB +C THIS ROUTINE IS CALLED BY: RDUSDX STSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*80 CARD + CHARACTER*24 UNIT + CHARACTER*11 REFR,REFR_ORIG + CHARACTER*8 NEMO + CHARACTER*4 SCAL,SCAL_ORIG + CHARACTER*3 BITW,BITW_ORIG + CHARACTER*1 SIGN,TAB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CAPTURE THE VARIOUS ELEMENTS CHARACTERISTICS +C -------------------------------------------- + + NEMO = CARD( 3:10) + SCAL = CARD(14:17) + REFR = CARD(21:31) + BITW = CARD(35:37) + UNIT = CARD(41:64) +c .... Make sure the units are all capitalized + CALL CAPIT(UNIT) + +C FIND THE ELEMENT TAG IN TABLE B +C ------------------------------- + +C Note that an entry for this mnemonic should already exist within +C the internal BUFR Table B array TABB(*,LUN). We now need to +C retrieve the positional index for that entry within TABB(*,LUN) +C so that we can access the entry and then add the scale factor, +C reference value, bit width, and units to it. + + CALL NEMTAB(LUN,NEMO,IDSN,TAB,IELE) + IF(TAB.NE.'B') GOTO 900 + +C LEFT JUSTIFY AND STORE CHARACTERISTICS +C -------------------------------------- + + CALL JSTCHR(UNIT,IRET) + IF(IRET.NE.0) GOTO 904 + TABB(IELE,LUN)(71:94) = UNIT + + SCAL_ORIG=SCAL + CALL JSTNUM(SCAL,SIGN,IRET) + IF(IRET.NE.0) GOTO 901 + TABB(IELE,LUN)(95:95) = SIGN + TABB(IELE,LUN)(96:98) = SCAL + + REFR_ORIG=REFR + CALL JSTNUM(REFR,SIGN,IRET) + IF(IRET.NE.0) GOTO 902 + TABB(IELE,LUN)( 99: 99) = SIGN + TABB(IELE,LUN)(100:109) = REFR + + BITW_ORIG=BITW + CALL JSTNUM(BITW,SIGN,IRET) + IF(IRET.NE.0 ) GOTO 903 + IF(SIGN.EQ.'-') GOTO 903 + TABB(IELE,LUN)(110:112) = BITW + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE B ENTRY '// + . '(UNDEFINED, TAB=",A,")")') NEMO,TAB + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"PARSED SCALE VALUE (=",A,") IS NOT '// + . 'NUMERIC")') SCAL_ORIG + CALL BORT2(BORT_STR1,BORT_STR2) +902 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"PARSED REFERENCE VALUE (=",A,") IS NOT '// + . 'NUMERIC")') REFR_ORIG + CALL BORT2(BORT_STR1,BORT_STR2) +903 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"PARSED BIT WIDTH VALUE (=",A,") IS NOT '// + . 'NUMERIC")') BITW_ORIG + CALL BORT2(BORT_STR1,BORT_STR2) +904 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"UNITS FIELD IS EMPTY")') + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/errwrt.f b/src/bufr/errwrt.f new file mode 100644 index 0000000000..122a22181e --- /dev/null +++ b/src/bufr/errwrt.f @@ -0,0 +1,57 @@ + SUBROUTINE ERRWRT(STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ERRWRT +C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-04-21 +C +C ABSTRACT: THIS SUBROUTINE WRITES A GIVEN ERROR OR OTHER DIAGNOSTIC +C MESSAGE TO A USER-SPECIFIED LOGICAL UNIT. AS DISTRIBUTED WITHIN +C THE BUFR ARCHIVE LIBRARY, THIS SUBROUTINE WILL WRITE ANY SUCH +C MESSAGES TO STANDARD OUTPUT; HOWEVER, APPLICATION PROGRAMS MAY +C SUBSTITUTE AN IN-LINE VERSION OF ERRWRT (OVERRIDING THIS ONE) IN +C ORDER TO DEFINE AN ALTERNATE DESTINATION FOR SUCH MESSAGES. +C +C PROGRAM HISTORY LOG: +C 2009-04-21 J. ATOR -- ORIGINAL AUTHOR +C 2012-11-15 D. KEYSER -- USE FORMATTED PRINT +C +C USAGE: CALL ERRWRT (STR) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): ERROR MESSAGE TO BE PRINTED TO +C STANDARD OUTPUT (DEFAULT) OR TO ANOTHER DESTINATION +C (IF SPECIFIED BY THE USER APPLICATION VIA AN IN-LINE +C REPLACEMENT FOR THIS SUBROUTINE) +C +C OUTPUT FILES: +C UNIT 06 - STANDARD OUTPUT PRINT +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: BORT BORT2 CKTABA CPDXMM +C DATEBF DUMPBF INVCON INVTAG +C INVWIN JSTNUM MAKESTAB MAXOUT +C MRGINV MSGUPD MSGWRT NVNWIN +C OPENBF OPENBT PKTDD RDBFDX +C RDMEMM RDMEMS READDX READERME +C READLC READMG READMT READS3 +C STRNUM STRSUC UFBEVN UFBIN3 +C UFBINT UFBMEM UFBMEX UFBOVR +C UFBREP UFBRMS UFBRW UFBSEQ +C UFBSTP UFBTAB UFBTAM USRTPL +C VALX WRDLEN +C Can also be called by application +C programs using an in-line version. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + + PRINT'(1X,A)',STR + + RETURN + END diff --git a/src/bufr/getabdb.f b/src/bufr/getabdb.f new file mode 100644 index 0000000000..a62fb5a563 --- /dev/null +++ b/src/bufr/getabdb.f @@ -0,0 +1,90 @@ + SUBROUTINE GETABDB(LUNIT,TABDB,ITAB,JTAB) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETABDB +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE RETURNS INTERNAL TABLE B AND TABLE D +C INFORMATION FOR LOGICAL UNIT LUNIT IN A PRE-DEFINED ASCII FORMAT. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ADDED TO BUFR ARCHIVE LIBRARY (WAS IN-LINED +C IN PROGRAM NAMSND) +C +C USAGE: CALL GETABDB( LUNIT, TABDB, ITAB, JTAB ) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C ITAB - INTEGER: DIMENSIONED SIZE OF TABDB ARRAY +C +C OUTPUT ARGUMENT LIST: +C TABDB - CHARACTER*128: (JTAB)-WORD ARRAY OF INTERNAL TABLE B +C AND TABLE D INFORMATION +C JTAB - INTEGER: NUMBER OF ENTRIES STORED WITHIN TABDB +C +C REMARKS: +C THIS ROUTINE CALLS: NEMTBD STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*128 TABDB(*) + CHARACTER*8 NEMO,NEMS(MAXCD) + DIMENSION IRPS(MAXCD),KNTS(MAXCD) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + JTAB = 0 + +C MAKE SURE THE FILE IS OPEN +C -------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) RETURN + +C WRITE OUT THE TABLE D ENTRIES FOR THIS FILE +C ------------------------------------------- + + DO I=1,NTBD(LUN) + NEMO = TABD(I,LUN)(7:14) + CALL NEMTBD(LUN,I,NSEQ,NEMS,IRPS,KNTS) + DO J=1,NSEQ,10 + JTAB = JTAB+1 + IF(JTAB.LE.ITAB) THEN + WRITE(TABDB(JTAB),1) NEMO,(NEMS(K),K=J,MIN(J+9,NSEQ)) +1 FORMAT('D ',A8,10(1X,A10)) + ENDIF + ENDDO + ENDDO + +C ADD THE TABLE B ENTRIES +C ----------------------- + + DO I=1,NTBB(LUN) + JTAB = JTAB+1 + IF(JTAB.LE.ITAB) THEN + WRITE(TABDB(JTAB),2) TABB(I,LUN)(7:14),TABB(I,LUN)(71:112) +2 FORMAT('B ',A8,1X,A42) + ENDIF + ENDDO + + RETURN + END diff --git a/src/bufr/getbmiss.f b/src/bufr/getbmiss.f new file mode 100644 index 0000000000..44c0c252da --- /dev/null +++ b/src/bufr/getbmiss.f @@ -0,0 +1,49 @@ + REAL*8 FUNCTION GETBMISS() + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETBMISS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 +C +C ABSTRACT: GETBMISS RETURNS THE CURRENT VALUE OF "BMISS" WHICH DENOTES +C MISSING VALUES BOTH FOR READING FROM BUFR FILES AND FOR +C WRITING TO BUFR FILES. THIS MISSING VALUE IS SET TO A +C DEFAULT VALUE OF 10E10 IN SUBROUTINE BFRINI, BUT APPLICATION +C PROGRAMS MAY SET IT TO A DIFFERENT VALUE VIA A CALL TO +C SUBROUTINE SETBMISS. +C +C PROGRAM HISTORY LOG: +C 2012-10-05 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: GETBMISS() +C +C INPUT ARGUMENTS: +C +C OUTPUT ARGUMENTS: +C GETBMISS - REAL*8: CURRENT VALUE OF BUFR ARCHIVE LIBRARY MISSING +C VALUE "BMISS" +C +C REMARKS: +C THIS ROUTINE CALLS: OPENBF +C +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + + CALL OPENBF(0,'FIRST',0) + + GETBMISS = BMISS + + RETURN + END diff --git a/src/bufr/getlens.f b/src/bufr/getlens.f new file mode 100644 index 0000000000..76bf4d3d69 --- /dev/null +++ b/src/bufr/getlens.f @@ -0,0 +1,83 @@ + SUBROUTINE GETLENS(MBAY,LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETLENS +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS ALL OF THE INDIVIDUAL +C SECTION LENGTHS OF THE BUFR MESSAGE STORED IN ARRAY MBAY, UP TO A +C SPECIFIED POINT. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR +C EDITION 2, 3 OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING +C "BUFR") MUST BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL GETLENS (MBAY, LL, LEN0, LEN1, LEN2, LEN3, LEN4, LEN5) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR MESSAGE +C LL - INTEGER: NUMBER OF LAST SECTION FOR WHICH THE LENGTH +C IS TO BE UNPACKED. IN OTHER WORDS, SETTING LL = N +C MEANS TO UNPACK THE LENGTHS OF SECTIONS 0 THROUGH N +C (I.E. LEN0, LEN1,...,LEN(N)). ANY SECTION LENGTHS +C THAT ARE NOT UNPACKED ARE RETURNED WITH A DEFAULT +C VALUE OF -1. +C +C OUTPUT ARGUMENT LIST: +C LEN0 - LENGTH OF SECTION 0 (= -1 IF NOT UNPACKED) +C LEN1 - LENGTH OF SECTION 1 (= -1 IF NOT UNPACKED) +C LEN2 - LENGTH OF SECTION 2 (= -1 IF NOT UNPACKED) +C LEN3 - LENGTH OF SECTION 3 (= -1 IF NOT UNPACKED) +C LEN4 - LENGTH OF SECTION 4 (= -1 IF NOT UNPACKED) +C LEN5 - LENGTH OF SECTION 5 (= -1 IF NOT UNPACKED) +C +C REMARKS: +C THIS ROUTINE CALLS: IUPB IUPBS01 +C THIS ROUTINE IS CALLED BY: ATRCPT CKTABA CNVED4 IUPBS3 +C MSGWRT STBFDX STNDRD UPDS3 +C WRDXTB WRITLC +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MBAY(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LEN0 = -1 + LEN1 = -1 + LEN2 = -1 + LEN3 = -1 + LEN4 = -1 + LEN5 = -1 + + IF(LL.LT.0) RETURN + LEN0 = IUPBS01(MBAY,'LEN0') + + IF(LL.LT.1) RETURN + LEN1 = IUPBS01(MBAY,'LEN1') + + IF(LL.LT.2) RETURN + IAD2 = LEN0 + LEN1 + LEN2 = IUPB(MBAY,IAD2+1,24) * IUPBS01(MBAY,'ISC2') + + IF(LL.LT.3) RETURN + IAD3 = IAD2 + LEN2 + LEN3 = IUPB(MBAY,IAD3+1,24) + + IF(LL.LT.4) RETURN + IAD4 = IAD3 + LEN3 + LEN4 = IUPB(MBAY,IAD4+1,24) + + IF(LL.LT.5) RETURN + LEN5 = 4 + + RETURN + END diff --git a/src/bufr/getntbe.f b/src/bufr/getntbe.f new file mode 100644 index 0000000000..8e56f737a8 --- /dev/null +++ b/src/bufr/getntbe.f @@ -0,0 +1,77 @@ + SUBROUTINE GETNTBE ( LUNT, IFXYN, LINE, IRET ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETNTBE +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE GETS THE FIRST LINE OF THE NEXT ENTRY IN +C THE SPECIFIED ASCII MASTER TABLE B OR MASTER TABLE D FILE. THIS +C LINE CONTAINS, AMONG OTHER THINGS, THE FXY NUMBER CORRESPONDING TO +C THIS ENTRY. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL GETNTBE ( LUNT, IFXYN, LINE, IRET ) +C INPUT ARGUMENT LIST: +C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING MASTER TABLE B OR MASTER TABLE D INFORMATION +C +C OUTPUT ARGUMENT LIST: +C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR +C NEXT TABLE ENTRY +C LINE - CHARACTER*(*): FIRST LINE OF NEXT TABLE ENTRY +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = end-of-file encountered while reading +C from LUNT +C -2 = I/O error encountered while reading +C from LUNT +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 IGETNTBL IGETFXY IFXY +C PARSTR +C THIS ROUTINE IS CALLED BY: RDMTBB RDMTBD +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) LINE + CHARACTER*128 BORT_STR1, BORT_STR2 + CHARACTER*20 TAGS(4) + CHARACTER*6 ADSC + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Get the first line of the next entry in the file. + + IRET = IGETNTBL ( LUNT, LINE ) + IF ( IRET .EQ. 0 ) THEN + +C The first field within this line should contain the +C FXY number. + + CALL PARSTR ( LINE(1:20), TAGS, 4, NTAG, '|', .FALSE. ) + IF ( NTAG .LT. 1 ) GOTO 900 + IF ( IGETFXY ( TAGS(1), ADSC ) .NE. 0 ) GOTO 900 + +C Store the bit-wise representation of the FXY number. + + IFXYN = IFXY ( ADSC ) + ENDIF + + RETURN + + 900 BORT_STR1 = 'BUFRLIB: GETNTBE - CARD BEGINNING WITH: ' // + . LINE(1:20) + BORT_STR2 = ' HAS BAD OR MISSING FXY NUMBER' + CALL BORT2(BORT_STR1,BORT_STR2) + + END diff --git a/src/bufr/gets1loc.f b/src/bufr/gets1loc.f new file mode 100644 index 0000000000..3f71b27284 --- /dev/null +++ b/src/bufr/gets1loc.f @@ -0,0 +1,220 @@ + SUBROUTINE GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETS1LOC +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE RETURNS THE LOCATION (I.E. STARTING BYTE +C AND BIT WIDTH) OF A SPECIFIED VALUE WITHIN SECTION 1 OF A BUFR +C MESSAGE ENCODED ACCORDING TO A SPECIFIED BUFR EDITION. IT WILL +C WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE +C VALUE FOR WHICH THE LOCATION IS TO BE DETERMINED IS SPECIFIED VIA +C THE MNEMONIC S1MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2006-04-14 D. KEYSER -- ADDED OPTIONS FOR 'YCEN' AND 'CENT' +C +C USAGE: GETS1LOC ( S1MNEM, IBEN, ISBYT, IWID, IRET ) +C INPUT ARGUMENT LIST: +C S1MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE WHOSE +C LOCATION WITHIN SECTION 1 IS TO BE DETERMINED: +C 'LEN1' = LENGTH (IN BYTES) OF SECTION 1 +C 'BMT' = BUFR MASTER TABLE +C 'OGCE' = ORIGINATING CENTER +C 'GSES' = ORIGINATING SUBCENTER +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 3 OR 4 MESSAGES!) +C 'USN' = UPDATE SEQUENCE NUMBER +C 'ISC2' = FLAG INDICATING ABSENCE/PRESENCE OF +C (OPTIONAL) SECTION 2 IN BUFR MESSAGE: +C 0 = SECTION 2 ABSENT +C 1 = SECTION 2 PRESENT +C 'MTYP' = DATA CATEGORY +C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MSBT' = DATA SUBCATEGORY (LOCAL) +C 'MTV' = VERSION NUMBER OF MASTER TABLE +C 'MTVL' = VERSION NUMBER OF LOCAL TABLES +C 'YCEN' = YEAR OF CENTURY (1-100) +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 2 AND 3 MESSAGES!) +C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, +C 21 FOR YEARS 2001-2100) +C (NOTE: THIS VALUE *MAY* BE PRESENT IN +C BUFR EDITION 2 AND 3 MESSAGES, +C BUT IT IS NEVER PRESENT IN ANY +C BUFR EDITION 4 MESSAGES!) +C 'YEAR' = YEAR (4-DIGIT) +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MNTH' = MONTH +C 'DAYS' = DAY +C 'HOUR' = HOUR +C 'MINU' = MINUTE +C 'SECO' = SECOND +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 4 MESSAGES!) +C IBEN - INTEGER: BUFR EDITION NUMBER +C +C +C OUTPUT ARGUMENT LIST: +C ISBYT - INTEGER: NUMBER OF STARTING BYTE WITHIN SECTION 1 +C WHICH CONTAINS VALUE CORRESPONDING TO S1MNEM +C (NOTE: ISBYT IS ALWAYS RETURNED AS 18 WHENEVER +C S1MNEM = 'CENT' AND IBEN = 2 OR 3; IN SUCH +C CASES IT IS THEN UP TO THE CALLING ROUTINE +C TO DETERMINE WHETHER THIS LOCATION ACTUALLY +C CONTAINS A VALID CENTURY VALUE!) +C IWID - INTEGER: WIDTH (IN BITS) OF VALUE CORRESPONDING +C TO S1MNEM +C IRET - INTEGER: RETURN CODE +C 0 = NORMAL RETURN +C -1 = THE INPUT S1MNEM MNEMONIC IS INVALID FOR +C BUFR EDITION IBEN +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: CRBMG IUPBS01 PKBS1 +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) S1MNEM + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + IWID = 8 + + IF(S1MNEM.EQ.'LEN1') THEN + ISBYT = 1 + IWID = 24 + ELSE IF(S1MNEM.EQ.'BMT') THEN + ISBYT = 4 + ELSE IF(S1MNEM.EQ.'OGCE') THEN + IF(IBEN.EQ.3) THEN + ISBYT = 6 + ELSE + +C Note that this location is actually the same for both +C Edition 2 *and* Edition 4 of BUFR! + + ISBYT = 5 + IWID = 16 + ENDIF + ELSE IF(S1MNEM.EQ.'GSES') THEN + IF(IBEN.EQ.3) THEN + ISBYT = 5 + ELSE IF(IBEN.EQ.4) THEN + ISBYT = 7 + IWID = 16 + ELSE + IRET = -1 + ENDIF + ELSE IF(S1MNEM.EQ.'USN') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 9 + ELSE + ISBYT = 7 + ENDIF + ELSE IF(S1MNEM.EQ.'ISC2') THEN + IWID = 1 + IF(IBEN.EQ.4) THEN + ISBYT = 10 + ELSE + ISBYT = 8 + ENDIF + ELSE IF(S1MNEM.EQ.'MTYP') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 11 + ELSE + ISBYT = 9 + ENDIF + ELSE IF(S1MNEM.EQ.'MSBTI') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 12 + ELSE + IRET = -1 + ENDIF + ELSE IF(S1MNEM.EQ.'MSBT') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 13 + ELSE + ISBYT = 10 + ENDIF + ELSE IF(S1MNEM.EQ.'MTV') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 14 + ELSE + ISBYT = 11 + ENDIF + ELSE IF(S1MNEM.EQ.'MTVL') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 15 + ELSE + ISBYT = 12 + ENDIF + ELSE IF(S1MNEM.EQ.'YEAR') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 16 + IWID = 16 + ELSE + IRET = -1 + ENDIF + ELSE IF(S1MNEM.EQ.'YCEN') THEN + IF(IBEN.LT.4) THEN + ISBYT = 13 + ELSE + IRET = -1 + ENDIF + ELSE IF(S1MNEM.EQ.'CENT') THEN + IF(IBEN.LT.4) THEN + ISBYT = 18 + ELSE + IRET = -1 + ENDIF + ELSE IF(S1MNEM.EQ.'MNTH') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 18 + ELSE + ISBYT = 14 + ENDIF + ELSE IF(S1MNEM.EQ.'DAYS') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 19 + ELSE + ISBYT = 15 + ENDIF + ELSE IF(S1MNEM.EQ.'HOUR') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 20 + ELSE + ISBYT = 16 + ENDIF + ELSE IF(S1MNEM.EQ.'MINU') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 21 + ELSE + ISBYT = 17 + ENDIF + ELSE IF(S1MNEM.EQ.'SECO') THEN + IF(IBEN.EQ.4) THEN + ISBYT = 22 + ELSE + IRET = -1 + ENDIF + ELSE + IRET = -1 + ENDIF + + RETURN + END diff --git a/src/bufr/gettagpr.f b/src/bufr/gettagpr.f new file mode 100644 index 0000000000..d161f8e86a --- /dev/null +++ b/src/bufr/gettagpr.f @@ -0,0 +1,101 @@ + SUBROUTINE GETTAGPR ( LUNIT, TAGCH, NTAGCH, TAGPR, IRET ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETTAGPR +C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-09-12 +C +C ABSTRACT: GIVEN A MNEMONIC CORRESPONDING TO A CHILD DESCRIPTOR +C WITHIN A PARENT SEQUENCE, THIS SUBROUTINE RETURNS THE MNEMONIC +C CORRESPONDING TO THE PARENT SEQUENCE. A SUBSET DEFINITION MUST +C ALREADY BE IN SCOPE, EITHER VIA A PREVIOUS CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE READSB OR EQUIVALENT (FOR INPUT FILES) OR TO +C SUBROUTINE OPENMB OR EQUIVALENT (FOR OUTPUT FILES). IF THERE IS +C MORE THAN ONE OCCURRENCE OF THE CHILD DESCRIPTOR WITHIN THE +C OVERALL SUBSET DEFINITION, THIS SUBROUTINE WILL RETURN THE PARENT +C MNEMONIC CORRESPONDING TO THE (NTAGCH)th OCCURRENCE OF THE CHILD, +C COUNTING FROM THE BEGINNING OF THE OVERALL SUBSET DEFINITION. +C +C PROGRAM HISTORY LOG: +C 2012-09-12 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL GETTAGPR (LUNIT, TAGCH, NTAGCH, TAGPR, IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C TAGCH - CHARACTER*(*): MNEMONIC CORRESPONDING TO CHILD +C DESCRIPTOR +C NTAGCH - INTEGER: ORDINAL OCCURRENCE OF TAGCH FOR WHICH +C TAGPR IS TO BE RETURNED, COUNTING FROM THE +C BEGINNING OF THE OVERALL SUBSET DEFINITION +C +C OUTPUT ARGUMENT LIST: +C TAGPR - CHARACTER*(*): MNEMONIC CORRESPONDING TO PARENT +C SEQUENCE DESCRIPTOR +C IRET - INTEGER: RETURN CODE +C 0 = NORMAL RETURN +C -1 = PARENT MNEMONIC COULD NOT BE FOUND, OR SOME +C OTHER ERROR OCCURRED +C +C REMARKS: +C THIS ROUTINE CALLS: PARSTR STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*10 TAG,TGS(15) + CHARACTER*3 TYP + + CHARACTER*(*) TAGCH, TAGPR + + REAL*8 VAL + + DATA MAXTG /15/ + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = -1 + +C Get LUN from LUNIT. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF (IL.EQ.0) RETURN + IF (INODE(LUN).NE.INV(1,LUN)) RETURN + +C Get TAGPR from the (NTAGCH)th occurrence of TAGCH. + + CALL PARSTR(TAGCH,TGS,MAXTG,NTG,' ',.TRUE.) + IF (NTG.NE.1) RETURN + + ITAGCT = 0 + DO N=1,NVAL(LUN) + NOD = INV(N,LUN) + IF(TGS(1).EQ.TAG(NOD)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.NTAGCH) THEN + TAGPR = TAG(JMPB(NOD)) + IRET = 0 + RETURN + ENDIF + ENDIF + ENDDO + + RETURN + END diff --git a/src/bufr/gettbh.f b/src/bufr/gettbh.f new file mode 100644 index 0000000000..5c7339d978 --- /dev/null +++ b/src/bufr/gettbh.f @@ -0,0 +1,95 @@ + SUBROUTINE GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETTBH +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE READS AND PARSES THE HEADER LINES FROM TWO +C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES CONTAINING +C EITHER MASTER TABLE B OR MASTER TABLE D INFORMATION. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) +C +C INPUT ARGUMENT LIST: +C LUNS - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING STANDARD TABLE INFORMATION +C LUNL - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING LOCAL TABLE INFORMATION +C TAB - CHARACTER*1: TABLE TYPE ('B' OR 'D') +C +C OUTPUT ARGUMENT LIST: +C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE +C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) +C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM +C STANDARD ASCII FILE +C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE +C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM +C LOCAL ASCII FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IGETNTBL PARSTR VALX +C THIS ROUTINE IS CALLED BY: RDMTBB RDMTBD +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*128 BORT_STR + CHARACTER*40 HEADER + CHARACTER*30 TAGS(5), LABEL + CHARACTER*3 CFTYP + CHARACTER*2 CTTYP + CHARACTER*1 TAB + + LOGICAL BADLABEL + +C----------------------------------------------------------------------- +C Statement function to check for bad header line label: + + BADLABEL ( LABEL ) = ( ( INDEX ( LABEL, CTTYP ) .EQ. 0 ) .OR. + . ( INDEX ( LABEL, CFTYP ) .EQ. 0 ) ) +C----------------------------------------------------------------------- + + CTTYP = TAB // ' ' + +C Read and parse the header line of the standard file. + + CFTYP = 'STD' + IF ( IGETNTBL ( LUNS, HEADER ) .NE. 0 ) GOTO 900 + CALL PARSTR ( HEADER, TAGS, 5, NTAG, '|', .FALSE. ) + IF ( NTAG .LT. 3 ) GOTO 900 + IF ( BADLABEL ( TAGS(1) ) ) GOTO 900 + IMT = VALX ( TAGS(2) ) + IMTV = VALX ( TAGS(3) ) + +C Read and parse the header line of the local file. + + CFTYP = 'LOC' + IF ( IGETNTBL ( LUNL, HEADER ) .NE. 0 ) GOTO 900 + CALL PARSTR ( HEADER, TAGS, 5, NTAG, '|', .FALSE. ) + IF ( NTAG .LT. 4 ) GOTO 900 + IF ( BADLABEL ( TAGS(1) ) ) GOTO 900 + IMT2 = VALX ( TAGS(2) ) + IOGCE = VALX ( TAGS(3) ) + ILTV = VALX ( TAGS(4) ) + +C Verify that both files are for the same master table. + + IF ( IMT .NE. IMT2 ) GOTO 901 + + RETURN + + 900 WRITE(BORT_STR,'("BUFRLIB: GETTBH - BAD OR MISSING HEADER '// + . 'WITHIN ",A," TABLE ",A)') CFTYP, TAB + CALL BORT(BORT_STR) + 901 WRITE(BORT_STR,'("BUFRLIB: GETTBH - MASTER TABLE NUMBER '// + . 'MISMATCH BETWEEN STD AND LOC TABLE ",A)') TAB + CALL BORT(BORT_STR) + END diff --git a/src/bufr/getvalnb.f b/src/bufr/getvalnb.f new file mode 100644 index 0000000000..3adf462865 --- /dev/null +++ b/src/bufr/getvalnb.f @@ -0,0 +1,140 @@ + REAL*8 FUNCTION GETVALNB ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETVALNB +C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-09-12 +C +C ABSTRACT: THIS FUNCTION SHOULD ONLY BE CALLED WHEN A BUFR FILE IS +C OPENED FOR INPUT, AND A SUBSET DEFINITION MUST ALREADY BE IN SCOPE +C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR +C EQUIVALENT. THE FUNCTION WILL FIRST SEARCH FOR THE (NTAGPV)th +C OCCURRENCE OF MNEMONIC TAGPV WITHIN THE OVERALL SUBSET DEFINITION, +C COUNTING FROM THE BEGINNING OF THE SUBSET. IF FOUND, IT WILL THEN +C SEARCH FORWARD (IF NTAGNB IS POSITIVE) OR BACKWARD (IF NTAGNB IS +C NEGATIVE) FROM THAT POINT WITHIN THE SUBSET FOR THE (NTAGNB)th +C OCCURRENCE OF MNEMONIC TAGNB AND RETURN THE VALUE CORRESPONDING +C TO THAT MNEMONIC. +C +C PROGRAM HISTORY LOG: +C 2012-09-12 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL GETVALNB (LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C TAGPV - CHARACTER*(*): PIVOT MNEMONIC; THE FUNCTION WILL +C FIRST SEARCH FOR the (NTAGPV)th OCCURRENCE OF THIS +C MNEMONIC, COUNTING FROM THE BEGINNING OF THE OVERALL +C SUBSET DEFINITION +C NTAGPV - INTEGER: ORDINAL OCCURRENCE OF TAGPV TO SEARCH FOR +C TAGNB - CHARACTER*(*): NEARBY MNEMONIC; ASSUMING TAGPV IS +C SUCCESSFULLY FOUND, THE FUNCTION WILL THEN SEARCH +C NEARBY FOR THE (NTAGNB)th OCCURRENCE OF TAGNB AND +C RETURN THE CORRESPONDING VALUE +C NTAGNB - INTEGER: ORDINAL OCCURRENCE OF TAGNB TO SEARCH FOR, +C COUNTING FROM THE LOCATION OF TAGPV WITHIN THE OVERALL +C SUBSET DEFINITION. IF TAGNB IS POSITIVE, THE FUNCTION +C WILL SEARCH IN A FORWARD DIRECTION FROM THE LOCATION OF +C TAGPV, OR IF TAGNB IS NEGATIVE IT WILL INSTEAD SEARCH +C IN A BACKWARDS DIRECTION. +C +C OUTPUT ARGUMENT LIST: +C GETVALNB - REAL*8: VALUE CORRESPONDING TO (NTAGNB)th OCCURRENCE +C OF TAGNB. IF FOR ANY REASON THIS VALUE CANNOT BE +C LOCATED, THEN THE BUFR ARCHIVE LIBRARY MISSING VALUE +C BMISS WILL BE RETURNED. +C +C REMARKS: +C THIS ROUTINE CALLS: PARSTR STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*10 TAG,TGS(15) + CHARACTER*3 TYP + + CHARACTER*(*) TAGPV, TAGNB + + REAL*8 VAL + + LOGICAL GOTNODPV + + DATA MAXTG /15/ + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + GETVALNB = BMISS + +C Get LUN from LUNIT. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF (IL.EQ.0) RETURN + IF (INODE(LUN).NE.INV(1,LUN)) RETURN + +C Locate the (NTAGPV)th occurrence of TAGPV. + + CALL PARSTR(TAGPV,TGS,MAXTG,NTG,' ',.TRUE.) + IF (NTG.NE.1) RETURN + + GOTNODPV = .FALSE. + ITAGCT = 0 + N = 1 + DO WHILE ((.NOT.GOTNODPV).AND.(N.LE.NVAL(LUN))) + NOD = INV(N,LUN) + IF(TGS(1).EQ.TAG(NOD)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.NTAGPV) THEN + GOTNODPV = .TRUE. + ELSE + N = N+1 + ENDIF + ELSE + N = N+1 + ENDIF + ENDDO + IF (.NOT.GOTNODPV) RETURN + +C Starting from TAGPV, search nearby for the +C +/-(NTAGNB)th occurrence of TAGNB. + + CALL PARSTR(TAGNB,TGS,MAXTG,NTG,' ',.TRUE.) + IF (NTG.NE.1) RETURN + + ISTEP = ISIGN(1,NTAGNB) + ITAGCT = 0 + N = N+ISTEP + DO WHILE ((N.GE.1).AND.(N.LE.NVAL(LUN))) + NOD = INV(N,LUN) + IF(TGS(1).EQ.TAG(NOD)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.IABS(NTAGNB)) THEN + GETVALNB = VAL(N,LUN) + RETURN + ELSE + N = N+ISTEP + ENDIF + ELSE + N = N+ISTEP + ENDIF + ENDDO + + RETURN + END diff --git a/src/bufr/getwin.f b/src/bufr/getwin.f new file mode 100644 index 0000000000..338811627d --- /dev/null +++ b/src/bufr/getwin.f @@ -0,0 +1,128 @@ + SUBROUTINE GETWIN(NODE,LUN,IWIN,JWIN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETWIN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: GIVEN A NODE INDEX WITHIN THE INTERNAL JUMP/LINK TABLE, THIS +C SUBROUTINE LOOKS WITHIN THE CURRENT SUBSET BUFFER FOR A "WINDOW" +C (SEE BELOW REMARKS) WHICH CONTAINS THIS NODE. IF FOUND, IT RETURNS +C THE STARTING AND ENDING INDICES OF THIS WINDOW WITHIN THE CURRENT +C SUBSET BUFFER. FOR EXAMPLE, IF THE NODE IS FOUND WITHIN THE SUBSET +C BUT IS NOT PART OF A DELAYED REPLICATION SEQUENCE, THEN THE RETURNED +C INDICES DEFINE THE START AND END OF THE ENTIRE SUBSET BUFFER. +C OTHERWISE, THE RETURNED INDICES DEFINE THE START AND END OF THE NEXT +C AVAILABLE DELAYED REPLICATION SEQUENCE ITERATION WHICH CONTAINS THE +C NODE. IF NO FURTHER ITERATIONS OF THE SEQUENCE CAN BE FOUND, THEN +C THE STARTING INDEX IS RETURNED WITH A VALUE OF ZERO. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE); OUTPUTS MORE +C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION +C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC +C +C USAGE: CALL GETWIN (NODE, LUN, IWIN, JWIN) +C INPUT ARGUMENT LIST: +C NODE - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C JWIN - INTEGER: ENDING INDEX OF THE PREVIOUS WINDOW ITERATION +C WHICH CONTAINED NODE +C +C OUTPUT ARGUMENT LIST: +C IWIN - INTEGER: STARTING INDEX OF THE CURRENT WINDOW ITERATION +C WHICH CONTAINS NODE +C 0 = NOT FOUND OR NO MORE ITERATIONS AVAILABLE +C JWIN - INTEGER: ENDING INDEX OF THE CURRENT WINDOW ITERATION +C WHICH CONTAINS NODE +C +C REMARKS: +C +C THIS IS ONE OF A NUMBER OF SUBROUTINES WHICH OPERATE ON "WINDOWS" +C (I.E. CONTIGUOUS PORTIONS) OF THE INTERNAL SUBSET BUFFER. THE +C SUBSET BUFFER IS AN ARRAY OF VALUES ARRANGED ACCORDING TO THE +C OVERALL TEMPLATE DEFINITION FOR A SUBSET. A WINDOW CAN BE ANY +C CONTIGUOUS PORTION OF THE SUBSET BUFFER UP TO AND INCLUDING THE +C ENTIRE SUBSET BUFFER ITSELF. FOR THE PURPOSES OF THESE "WINDOW +C OPERATOR" SUBROUTINES, A WINDOW ESSENTIALLY CONSISTS OF ALL OF THE +C ELEMENTS WITHIN A PARTICULAR DELAYED REPLICATION GROUP, SINCE SUCH +C GROUPS EFFECTIVELY DEFINE THE DIMENSIONS WITHIN A BUFR SUBSET FOR +C THE BUFR ARCHIVE LIBRARY SUBROUTINES SUCH AS UFBINT, UFBIN3, ETC. +C WHICH READ/WRITE INDIVIDUAL DATA VALUES. A BUFR SUBSET WITH NO +C DELAYED REPLICATION GROUPS IS CONSIDERED TO HAVE ONLY ONE +C DIMENSION, AND THEREFORE ONLY ONE "WINDOW" WHICH SPANS THE ENTIRE +C SUBSET. ON THE OTHER HAND, EACH DELAYED REPLICATION SEQUENCE +C WITHIN A BUFR SUBSET CONSISTS OF SOME NUMBER OF "WINDOWS", WHICH +C ARE A DE-FACTO SECOND DIMENSION OF THE SUBSET AND WHERE THE NUMBER +C OF WINDOWS IS THE DELAYED DESCRIPTOR REPLICATION FACTOR (I.E. THE +C NUMBER OF ITERATIONS) OF THE SEQUENCE. IF NESTED DELAYED +C REPLICATION IS USED, THEN THERE MAY BE THREE OR MORE DIMENSIONS +C WITHIN THE SUBSET. +C +C THIS ROUTINE CALLS: BORT INVWIN LSTJPB +C THIS ROUTINE IS CALLED BY: CONWIN UFBEVN UFBIN3 UFBRW +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*128 BORT_STR + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRPC = LSTJPB(NODE,LUN,'RPC') + + IF(IRPC.EQ.0) THEN + IWIN = INVWIN(NODE,LUN,JWIN,NVAL(LUN)) + IF(IWIN.EQ.0 .and. JWIN.GT.1) GOTO 100 + IWIN = 1 + JWIN = NVAL(LUN) + GOTO 100 + ELSE + IWIN = INVWIN(IRPC,LUN,JWIN,NVAL(LUN)) + IF(IWIN.EQ.0) THEN + GOTO 100 + ELSEIF(VAL(IWIN,LUN).EQ.0.) THEN + IWIN = 0 + GOTO 100 + ENDIF + ENDIF + + JWIN = INVWIN(IRPC,LUN,IWIN+1,NVAL(LUN)) + IF(JWIN.EQ.0) GOTO 900 + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: GETWIN - SEARCHED BETWEEN",I5," AND"'// + . ',I5,", MISSING BRACKET")') IWIN+1,NVAL(LUN) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/i4dy.f b/src/bufr/i4dy.f new file mode 100644 index 0000000000..f86b60c591 --- /dev/null +++ b/src/bufr/i4dy.f @@ -0,0 +1,66 @@ + FUNCTION I4DY(IDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: I4DY +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 +C +C ABSTRACT: THIS FUNCTION CONVERTS AN EIGHT DIGIT INTEGER DATE +C (YYMMDDHH) TO TEN DIGITS (YYYYMMDDHH) USING THE Y2K "WINDOWING" +C TECHNIQUE. ALL TWO-DIGIT YEARS GREATER THAN "20" ARE ASSUMED TO +C HAVE A FOUR-DIGIT YEAR BEGINNING WITH "19" (1921-1999) AND ALL TWO- +C DIGIT YEARS LESS THAN OR EQUAL TO "20" ARE ASSUMED TO HAVE A FOUR- +C DIGIT YEAR BEGINNING WITH "20" (2000-2020). IF THE INPUT DATE IS +C ALREADY TEN DIGITS, THIS ROUTINE JUST RETURNS ITS VALUE. +C +C PROGRAM HISTORY LOG: +C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-11-24 J. WOOLLEN -- MODIFIED TO CONFORM TO THE NCEP 2-DIGIT +C YEAR TIME WINDOW OF 1921-2020 (BUT +C INADVERTENTLY SET TO 1911-2010) +C 1998-12-14 J. WOOLLEN -- MODIFIED TO USE 20 AS THE 2-DIGIT YEAR FOR +C WINDOWING TO A 4-DIGIT YEAR (00-20 ==> ADD +C 2000; 21-99 ==> ADD 1900), THIS WINDOWING +C TECHNIQUE WAS INADVERTENTLY CHANGED TO 10 +C IN THE PREVIOUS IMPLEMENTATION OF I4DY +C (1998-11-24) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER USE +C FLOATING POINT ARITHMETIC SINCE THIS CAN +C LEAD TO ROUND OFF ERROR AND AN IMPROPER +C RESULTING DATE ON SOME MACHINES (E.G., +C NCEP IBM FROST/SNOW), INCREASES +C PORTABILITY; UNIFIED/PORTABLE FOR WRF; +C ADDED DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: I4DY (IDATE) +C INPUT ARGUMENT LIST: +C IDATE - INTEGER: DATE (EITHER YYMMDDHH OR YYYYMMDDHH), +C DEPENDING ON DATELEN() VALUE +C +C OUTPUT ARGUMENT LIST: +C I4DY - INTEGER: DATE (YYYYMMDDHH) +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: CKTABA CMSGINI DATEBF DUMPBF +C IUPBS01 OPENMB OPENMG REWNBF +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + IF(IDATE.LT.10**8) THEN + IY = IDATE/10**6 + IF(IY.GT.20) I4DY = IDATE + 19*100000000 + IF(IY.LE.20) I4DY = IDATE + 20*100000000 + ELSE + I4DY = IDATE + ENDIF + + RETURN + END diff --git a/src/bufr/ibfms.f b/src/bufr/ibfms.f new file mode 100644 index 0000000000..ef988c1ad5 --- /dev/null +++ b/src/bufr/ibfms.f @@ -0,0 +1,57 @@ + INTEGER FUNCTION IBFMS ( R8VAL ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IBFMS +C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS FUNCTION TESTS WHETHER THE INPUT VALUE IS EQUIVALENT +C TO THE BUFR ARCHIVE LIBRARY "MISSING" VALUE. THE USE OF INTEGER +C RETURN CODES ALLOWS THIS FUNCTION TO BE CALLED IN A LOGICAL +C CONTEXT FROM A CALLING PROGRAM WRITTEN IN C. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C 2009-03-23 J. ATOR -- INCREASED VALUE OF BDIFD FOR BETTER +C TEST ACCURACY +C 2012-10-05 J. ATOR -- MODIFIED TO REFLECT THE FACT THAT THE +C "MISSING" VALUE IS NOW CONFIGURABLE BY +C USERS (MAY BE SOMETHING OTHER THAN 10E10) +C +C USAGE: IBFMS ( R8VAL ) +C INPUT ARGUMENT LIST: +C R8VAL - REAL*8: VALUE TO BE TESTED FOR EQUIVALENCE TO +C BUFR ARCHIVE LIBRARY "MISSING" VALUE +C +C OUTPUT ARGUMENT LIST: +C IBFMS - INTEGER: RETURN CODE: +C 0 - R8VAL IS NOT EQUIVALENT TO "MISSING" +C 1 - R8VAL IS EQUIVALENT TO "MISSING" +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: INVMRG UFBDMP UFBRW UFDUMP +C WRTREE +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + REAL*8 R8VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF ( R8VAL .EQ. BMISS ) THEN + IBFMS = 1 + ELSE + IBFMS = 0 + ENDIF + + RETURN + END diff --git a/src/bufr/icbfms.f b/src/bufr/icbfms.f new file mode 100644 index 0000000000..9fef9c658e --- /dev/null +++ b/src/bufr/icbfms.f @@ -0,0 +1,71 @@ + INTEGER FUNCTION ICBFMS ( STR, LSTR ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ICBFMS +C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-06-07 +C +C ABSTRACT: THIS FUNCTION TESTS WHETHER THE INPUT CHARACTER STRING +C IS "MISSING" BY CHECKING IF ALL OF THE EQUIVALENT BITS ARE SET TO 1. +C IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION IBFMS, EXCEPT THAT +C IBFMS TESTS REAL*8 VALUES FOR EQUIVALENCE TO THE PARAMETER BMISS, +C WHEREAS ICBFMS CHECKS THAT ALL EQUIVALENT BITS ARE SET TO 1 AND IS +C THEREFORE A MORE PORTABLE AND RELIABLE TEST FOR USE WITH CHARACTER +C STRINGS. +C +C PROGRAM HISTORY LOG: +C 2012-06-07 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: ICBFMS ( STR, LSTR ) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING TO BE TESTED +C LSTR - INTEGER: NUMBER OF CHARACTERS TO BE TESTED WITHIN STR +C +C OUTPUT ARGUMENT LIST: +C ICBFMS - INTEGER: RETURN CODE: +C 0 - STR IS NOT "MISSING" +C 1 - STR IS "MISSING" +C +C REMARKS: +C THIS ROUTINE CALLS: IUPM +C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE UFDUMP +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + CHARACTER*(*) STR + +C----------------------------------------------------------------------- + + ICBFMS = 0 + + NUMCHR = MIN(LSTR,LEN(STR)) + +C* Beginning with version 10.2.0 of the BUFRLIB, "missing" strings +C* are explicitly encoded with all bits set to 1. However, this +C* wasn't the case for strings encoded with earlier versions of +C* BUFRLIB, so the following block can help identify "missing" +C* strings encoded with these earlier versions. + + IF ( (NUMCHR.GE.4) .AND. ( STR(1:4).EQ.'B7Hv')) THEN + ICBFMS = 1 + RETURN + END IF + +C* Otherwise, the logic below will handle cases encoded using +C* BUFRLIB version 10.2.0 or later. + + DO I=1,NUMCHR + IF ( IUPM(STR(I:I),8).NE.255 ) RETURN + ENDDO + + ICBFMS = 1 + + RETURN + END diff --git a/src/bufr/ichkstr.f b/src/bufr/ichkstr.f new file mode 100644 index 0000000000..ea1c5cd04c --- /dev/null +++ b/src/bufr/ichkstr.f @@ -0,0 +1,65 @@ + FUNCTION ICHKSTR(STR,CHR,N) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ICHKSTR +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS FUNCTION COMPARES A SPECIFIED NUMBER OF CHARACTERS +C FROM AN INPUT CHARACTER ARRAY AGAINST THE SAME NUMBER OF CHARACTERS +C FROM AN INPUT CHARACTER STRING AND DETERMINES WHETHER THE TWO ARE +C EQUIVALENT. THE CHARACTER ARRAY IS ASSUMED TO BE IN ASCII, WHEREAS +C THE CHARACTER STRING IS ASSUMED TO BE IN THE NATIVE CHARACTER SET +C (I.E. ASCII OR EBCDIC) OF THE LOCAL MACHINE. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: ICHKSTR (STR, CHR, N) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): N-CHARACTER STRING IN ASCII OR EBCDIC, +C DEPENDING ON THE NATIVE MACHINE +C CHR - CHARACTER*1: ARRAY OF N CHARACTERS IN ASCII +C N - INTEGER: NUMBER OF CHARACTERS TO BE COMPARED +C +C OUTPUT ARGUMENT LIST: +C ICHKSTR - INTEGER: RETURN VALUE: +C 0 = STR(1:N) AND (CHR(I),I=1,N) ARE EQUIVALENT +C 1 = STR(1:N) AND (CHR(I),I=1,N) ARE NOT EQUIVALENT +C +C REMARKS: +C THIS ROUTINE CALLS: CHRTRNA +C THIS ROUTINE IS CALLED BY: CRBMG RDMSGB READERME +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + + CHARACTER*80 CSTR + CHARACTER*1 CHR(N) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Copy CHR into CSTR and, if necessary, convert the latter +C to EBCDIC (i.e. if the local machine uses EBCDIC) so that +C the subsequent comparison will always be valid. + + CALL CHRTRNA(CSTR,CHR,N) + +C Compare CSTR to STR. + + IF(CSTR(1:N).EQ.STR(1:N)) THEN + ICHKSTR = 0 + ELSE + ICHKSTR = 1 + ENDIF + + RETURN + END diff --git a/src/bufr/icmpdx.f b/src/bufr/icmpdx.f new file mode 100644 index 0000000000..351ea0c776 --- /dev/null +++ b/src/bufr/icmpdx.f @@ -0,0 +1,91 @@ + INTEGER FUNCTION ICMPDX(LUD,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ICMPDX +C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-06-18 +C +C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) +C HAS THE SAME INTERNAL TABLE INFORMATION AS LOGICAL UNIT IOLUN(LUD). +C NOTE THAT THIS DOES NOT NECESSARILY MEAN THAT IOLUN(LUN) AND +C IOLUN(LUD) ARE SHARING TABLE INFORMATION, SINCE TWO LOGICAL UNITS +C CAN HAVE THE SAME INTERNAL TABLE INFORMATION WITHOUT SHARING IT. +C +C PROGRAM HISTORY LOG: +C 2009-06-18 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: ICMPDX (LUD, LUN) +C INPUT ARGUMENT LIST: +C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR FIRST LOGICAL UNIT +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR SECOND LOGICAL UNIT +C +C OUTPUT ARGUMENT LIST: +C ICMPDX - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN) +C HAS THE SAME INTERNAL TABLE INFORMATION AS IOLUN(LUD): +C 0 - NO +C 1 - YES +C +C REMARKS: +C THIS ROUTINE CALLS: ISHRDX +C THIS ROUTINE IS CALLED BY: IOK2CPY MAKESTAB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C First, check whether the two units are actually sharing tables. +C If so, then they obviously have the same table information. + + ICMPDX = ISHRDX(LUD,LUN) + IF ( ICMPDX .EQ. 1 ) RETURN + +C Otherwise, check whether the internal Table A, B and D entries are +C all identical between the two units. + + IF ( ( NTBA(LUD) .EQ. 0 ) .OR. + . ( NTBA(LUN) .NE. NTBA(LUD) ) ) RETURN + DO I = 1, NTBA(LUD) + IF ( IDNA(I,LUN,1) .NE. IDNA(I,LUD,1) ) RETURN + IF ( IDNA(I,LUN,2) .NE. IDNA(I,LUD,2) ) RETURN + IF ( TABA(I,LUN) .NE. TABA(I,LUD) ) RETURN + ENDDO + + IF ( ( NTBB(LUD) .EQ. 0 ) .OR. + . ( NTBB(LUN) .NE. NTBB(LUD) ) ) RETURN + DO I = 1, NTBB(LUD) + IF ( IDNB(I,LUN) .NE. IDNB(I,LUD) ) RETURN + IF ( TABB(I,LUN) .NE. TABB(I,LUD) ) RETURN + ENDDO + + IF ( ( NTBD(LUD) .EQ. 0 ) .OR. + . ( NTBD(LUN) .NE. NTBD(LUD) ) ) RETURN + DO I = 1, NTBD(LUD) + IF ( IDND(I,LUN) .NE. IDND(I,LUD) ) RETURN + IF ( TABD(I,LUN) .NE. TABD(I,LUD) ) RETURN + ENDDO + + ICMPDX = 1 + + RETURN + END diff --git a/src/bufr/icopysb.f b/src/bufr/icopysb.f new file mode 100644 index 0000000000..51d421863c --- /dev/null +++ b/src/bufr/icopysb.f @@ -0,0 +1,48 @@ + FUNCTION ICOPYSB(LUNIN,LUNOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ICOPYSB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE COPYSB +C AND PASSES BACK ITS RETURN CODE. SEE COPYSB FOR MORE DETAILS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: ICOPYSB (LUNIN, LUNOT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C OUTPUT ARGUMENT LIST: +C ICOPYSB - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the input +C BUFR message +C +C REMARKS: +C THIS ROUTINE CALLS: COPYSB +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CALL COPYSB(LUNIN,LUNOT,IRET) + ICOPYSB = IRET + RETURN + END diff --git a/src/bufr/icvidx.c b/src/bufr/icvidx.c new file mode 100644 index 0000000000..7fe925a1c9 --- /dev/null +++ b/src/bufr/icvidx.c @@ -0,0 +1,40 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ICVIDX +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS ROUTINE COMPUTES A UNIQUE 1-DIMENSIONAL ARRAY +C INDEX FROM 2-DIMENSIONAL INDICES. THIS ALLOWS A 2-DIMENSIONAL +C (ROW-BY-COLUMN) ARRAY TO BE STORED AND ACCESSED AS A +C 1-DIMENSIONAL ARRAY. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL ICVIDX( II, JJ, NUMJJ ) +C INPUT ARGUMENT LIST: +C II - INTEGER: FIRST (ROW) INDEX +C JJ - INTEGER: SECOND (COLUMN) INDEX +C NUMJJ - INTEGER: MAXIMUM NUMBER OF COLUMN INDICES +C +C OUTPUT ARGUMENT LIST: +C ICVIDX - INTEGER: 1-DIMENSIONAL INDEX +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: READMT STSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +f77int icvidx( f77int *ii, f77int *jj, f77int *numjj ) +{ + return ( *numjj * (*ii) ) + *jj; +} diff --git a/src/bufr/idn30.f b/src/bufr/idn30.f new file mode 100644 index 0000000000..8f2579fa1c --- /dev/null +++ b/src/bufr/idn30.f @@ -0,0 +1,81 @@ + FUNCTION IDN30(ADN30,L30) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IDN30 +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CONVERTS A DESCRIPTOR FROM ITS FIVE OR SIX +C CHARACTER ASCII REPRESENTATION TO ITS BIT-WISE (INTEGER) +C REPRESENTATION. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: IDN30 (ADN30, L30) +C INPUT ARGUMENT LIST: +C ADN30 - CHARACTER*(*): CHARACTER FORM OF DESCRIPTOR (FXY +C VALUE) +C L30 - INTEGER: LENGTH OF ADN30 (NUMBER OF CHARACTERS, 5 OR +C 6) +C +C OUTPUT ARGUMENT LIST: +C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) +C VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT IFXY +C THIS ROUTINE IS CALLED BY: STBFDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*(*) ADN30 + CHARACTER*128 BORT_STR + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(LEN(ADN30).LT.L30) GOTO 900 + IF(L30.EQ.5) THEN + READ(ADN30,'(I5)') IDN30 + IF(IDN30.LT.0 .OR. IDN30.GT.65535) GOTO 901 + ELSEIF(L30.EQ.6) THEN + IDN30 = IFXY(ADN30) + ELSE + GOTO 902 + ENDIF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A,'// + . '" CHARACTER LENGTH (",I4,") IS TOO SHORT (< L30,",I5)') + . ADN30,LEN(ADN30),L30 + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: IDN30 - DESCRIPTOR INTEGER '// + . 'REPRESENTATION, IDN30 (",I8,"), IS OUTSIDE 16-BIT RANGE '// + . '(0-65535)")') IDN30 + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A,'// + . '" CHARACTER LENGTH (",I4,") MUST BE EITHER 5 OR 6")') + . ADN30,L30 + CALL BORT(BORT_STR) + END diff --git a/src/bufr/idxmsg.f b/src/bufr/idxmsg.f new file mode 100644 index 0000000000..b091c5c378 --- /dev/null +++ b/src/bufr/idxmsg.f @@ -0,0 +1,58 @@ + FUNCTION IDXMSG( MESG ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IDXMSG +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS FUNCTION DETERMINES WHETHER THE GIVEN BUFR MESSAGE +C IS A DX DICTIONARY MESSAGE THAT WAS CREATED BY THE BUFR ARCHIVE +C LIBRARY SOFTWARE. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IDXMSG( MESG ) +C INPUT ARGUMENT LIST: +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR MESSAGE +C +C OUTPUT ARGUMENT LIST: +C IDXMSG - INTEGER: RETURN VALUE: +C 0 - MESG IS NOT A DX DICTIONARY MESSAGE +C 1 - MESG IS A DX DICTIONARY MESSAGE +C +C REMARKS: +C THIS ROUTINE CALLS: IUPBS01 +C THIS ROUTINE IS CALLED BY: CPDXMM DATEBF DUMPBF MESGBC +C MESGBF MSGWRT RDBFDX READMG +C POSAPX READERME UFBMEM +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MESG(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Note that the following test relies upon logic within subroutine +C DXMINI which zeroes out the Section 1 date of all DX dictionary +C messages. + + IF ( (IUPBS01(MESG,'MTYP').EQ.11) .AND. + . (IUPBS01(MESG,'MNTH').EQ.0) .AND. + . (IUPBS01(MESG,'DAYS').EQ.0) .AND. + . (IUPBS01(MESG,'HOUR').EQ.0) ) THEN + IDXMSG = 1 + ELSE + IDXMSG = 0 + END IF + + RETURN + END diff --git a/src/bufr/ifbget.f b/src/bufr/ifbget.f new file mode 100644 index 0000000000..b75af39331 --- /dev/null +++ b/src/bufr/ifbget.f @@ -0,0 +1,85 @@ + FUNCTION IFBGET(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IFBGET +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CHECKS TO SEE IF ANY UNREAD SUBSETS ARE IN +C AN INPUT BUFR MESSAGE PREVIOUSLY OPENED BY BUFR ARCHIVE LIBRARY +C SUBROUTINE OPENMG OR OPENMB. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: IFBGET (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C IFBGET - INTEGER: RETURN CODE: +C 0 = there is at least one more subset in the +C message +C -1 = there are no more subsets in the message +C +C REMARKS: +C THIS ROUTINE CALLS: BORT STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT +C ------------------------------------------ + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE +C --------------------------------------------- + + IF(NSUB(LUN).LT.MSUB(LUN)) THEN + IFBGET = 0 + ELSE + IFBGET = -1 + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: IFBGET - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: IFBGET - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: IFBGET - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') + END diff --git a/src/bufr/ifxy.f b/src/bufr/ifxy.f new file mode 100644 index 0000000000..3bd7620bdf --- /dev/null +++ b/src/bufr/ifxy.f @@ -0,0 +1,66 @@ + FUNCTION IFXY(ADSC) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IFXY +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION RETURNS THE INTEGER CORRESPONDING TO THE +C BIT-WISE REPRESENTATION OF AN INPUT CHARACTER FXY VALUE OF LENGTH +C SIX. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C +C USAGE: IFXY (ADSC) +C INPUT ARGUMENT LIST: +C ADSC - CHARACTER*6: CHARACTER FORM OF DESCRIPTOR (FXY VALUE) +C +C OUTPUT ARGUMENT LIST: +C IFXY - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) +C VALUE +C +C REMARKS: +C +C EXAMPLE: +C +C If ADSC = '063022', then IFXY = 16150 since: +C +C 0 63 22 +C +C F | X | Y +C | | +C 0 0 1 1 1 1 1 1 0 0 0 1 0 1 1 0 = +C +C ( 2**13 + 2**12 + 2**11 + 2**10 + +C 2**9 + 2**8 + 2**4 + 2**2 + 2**1 ) = 16150 +C +C +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: BFRINI DXINIT GETNTBE IDN30 +C NEMTAB NEMTBB NEMTBD NUMTBD +C RESTD SNTBDE STBFDX STNTBI +C STSEQ UFBQCP +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*6 ADSC + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + READ(ADSC,'(I1,I2,I3)') IF,IX,IY + IFXY = IF*2**14 + IX*2**8 + IY + RETURN + END diff --git a/src/bufr/igetdate.f b/src/bufr/igetdate.f new file mode 100644 index 0000000000..2f01b6a5a5 --- /dev/null +++ b/src/bufr/igetdate.f @@ -0,0 +1,60 @@ + FUNCTION IGETDATE(MBAY,IYR,IMO,IDY,IHR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IGETDATE +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS THE SECTION 1 DATE-TIME +C FROM THE BUFR MESSAGE STORED IN ARRAY MBAY. IT WILL WORK ON ANY +C MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE START OF THE +C BUFR MESSAGE, (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE FIRST +C FOUR BYTES OF MBAY. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IGETDATE (MBAY, IYR, IMO, IDY, IHR) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR MESSAGE +C +C OUTPUT ARGUMENT LIST: +C IYR - INTEGER: SECTION 1 YEAR (YYYY OR YY, DEPENDING ON +C DATELEN() VALUE) +C IMO - INTEGER: SECTION 1 MONTH (MM) +C IDY - INTEGER: SECTION 1 DAY (DD) +C IHR - INTEGER: SECTION 1 HOUR (HH) +C IGETDATE - INTEGER: SECTION 1 DATE-TIME (YYYYMMDDHH OR YYMMDDHH, +C DEPENDING ON DATELEN() VALUE) +C +C REMARKS: +C THIS ROUTINE CALLS: IUPBS01 +C THIS ROUTINE IS CALLED BY: CKTABA DATEBF DUMPBF +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /DATELN/ LENDAT + + DIMENSION MBAY(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IYR = IUPBS01(MBAY,'YEAR') + IMO = IUPBS01(MBAY,'MNTH') + IDY = IUPBS01(MBAY,'DAYS') + IHR = IUPBS01(MBAY,'HOUR') + IF(LENDAT.NE.10) THEN + IYR = MOD(IYR,100) + ENDIF + IGETDATE = (IYR*1000000) + (IMO*10000) + (IDY*100) + IHR + + RETURN + END diff --git a/src/bufr/igetfxy.f b/src/bufr/igetfxy.f new file mode 100644 index 0000000000..1b810c20e5 --- /dev/null +++ b/src/bufr/igetfxy.f @@ -0,0 +1,79 @@ + FUNCTION IGETFXY ( STR, CFXY ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IGETFXY +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS FUNCTION LOOKS FOR AND RETURNS A VALID FXY NUMBER +C FROM WITHIN THE GIVEN INPUT STRING. THE FXY NUMBER MAY BE IN +C FORMAT OF EITHER FXXYYY OR F-XX-YYY WITHIN THE INPUT STRING, BUT +C IT IS ALWAYS RETURNED IN FORMAT FXXYYY UPON OUTPUT. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IGETFXY ( STR, CFXY ) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): INPUT STRING +C +C OUTPUT ARGUMENT LIST: +C CFXY - CHARACTER*6: FXY NUMBER IN FORMAT FXXYYY +C IGETFXY - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = could not find a valid FXY number in STR +C +C REMARKS: +C THIS ROUTINE CALLS: JSTCHR NUMBCK +C THIS ROUTINE IS CALLED BY: GETNTBE SNTBDE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + CHARACTER*6 CFXY + + PARAMETER ( LSTR2 = 120 ) + CHARACTER*(LSTR2) STR2 + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IGETFXY = -1 + + LSTR = LEN ( STR ) + IF ( LSTR .LT. 6 ) RETURN + +C Left-justify a copy of the input string. + + IF ( LSTR .GT. LSTR2 ) THEN + STR2(1:LSTR2) = STR(1:LSTR2) + ELSE + STR2 = STR + ENDIF + CALL JSTCHR ( STR2, IRET ) + IF ( IRET .NE. 0 ) RETURN + +C Look for an FXY number. + + IF ( INDEX ( STR2, '-' ) .NE. 0 ) THEN +C Format of field is F-XX-YYY. + CFXY(1:1) = STR2(1:1) + CFXY(2:3) = STR2(3:4) + CFXY(4:6) = STR2(6:8) + ELSE +C Format of field is FXXYYY. + CFXY = STR2(1:6) + ENDIF + +C Check that the FXY number is valid. + + IF ( NUMBCK ( CFXY ) .EQ. 0 ) IGETFXY = 0 + + RETURN + END diff --git a/src/bufr/igetntbi.f b/src/bufr/igetntbi.f new file mode 100644 index 0000000000..999f8f00ce --- /dev/null +++ b/src/bufr/igetntbi.f @@ -0,0 +1,66 @@ + FUNCTION IGETNTBI ( LUN, CTB ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IGETNTBI +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS FUNCTION RETURNS THE NEXT AVAILABLE INDEX FOR +C STORING AN ENTRY WITHIN INTERNAL BUFR TABLE CTB. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL IGETNTBI ( LUN, CTB ) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C CTB - CHARACTER*1: INTERNAL BUFR TABLE FROM WHICH TO RETURN +C THE NEXT AVAILABLE INDEX ('A','B', OR 'D') +C +C OUTPUT ARGUMENT LIST: +C IGETNTBI - INTEGER: NEXT AVAILABLE INDEX IN TABLE CTB +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: RDUSDX READS3 STBFDX STSEQ +C Not normally called by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABA, TABB, BORT_STR + CHARACTER*1 CTB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF ( CTB .EQ. 'A' ) THEN + IGETNTBI = NTBA(LUN) + 1 + IMAX = NTBA(0) + ELSE IF ( CTB .EQ. 'B' ) THEN + IGETNTBI = NTBB(LUN) + 1 + IMAX = NTBB(0) + ELSE IF ( CTB .EQ. 'D' ) THEN + IGETNTBI = NTBD(LUN) + 1 + IMAX = NTBD(0) + ENDIF + IF ( IGETNTBI .GT. IMAX ) GOTO 900 + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: IGETNTBI - NUMBER OF INTERNAL TABLE' + . //'",A1," ENTRIES EXCEEDS THE LIMIT (",I4,")")') CTB, IMAX + CALL BORT(BORT_STR) + END diff --git a/src/bufr/igetntbl.f b/src/bufr/igetntbl.f new file mode 100644 index 0000000000..1074a3a56e --- /dev/null +++ b/src/bufr/igetntbl.f @@ -0,0 +1,59 @@ + FUNCTION IGETNTBL ( LUNT, LINE ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IGETNTBL +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS FUNCTION GETS THE NEXT LINE FROM THE ASCII MASTER +C TABLE FILE SPECIFIED BY LUNT, IGNORING ANY BLANK LINES OR COMMENT +C LINES IN THE PROCESS. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IGETNTBL ( LUNT, LINE ) +C INPUT ARGUMENT LIST: +C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING MASTER TABLE INFORMATION +C +C OUTPUT ARGUMENT LIST: +C LINE - CHARACTER*(*): NEXT NON-BLANK, NON-COMMENT LINE READ +C FROM LUNT +C IGETNTBL - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = end-of-file encountered while reading +C from LUNT +C -2 = I/O error encountered while reading +C from LUNT +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: GETNTBE GETTBH SNTBDE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) LINE + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + 10 READ ( LUNT, '(A)', END=100, ERR=200 ) LINE + IF ( ( LINE .EQ. ' ' ) .OR. ( LINE(1:1) .EQ. '#' ) ) GOTO 10 + IF ( LINE(1:3) .EQ. 'END' ) GOTO 100 + + IGETNTBL = 0 + RETURN + + 100 IGETNTBL = -1 + RETURN + + 200 IGETNTBL = -2 + RETURN + + END diff --git a/src/bufr/igetsc.f b/src/bufr/igetsc.f new file mode 100644 index 0000000000..38e675b425 --- /dev/null +++ b/src/bufr/igetsc.f @@ -0,0 +1,55 @@ + FUNCTION IGETSC(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IGETSC +C PRGMMR: J. ATOR ORG: NP12 DATE: 2010-05-11 +C +C ABSTRACT: THIS FUNCTION RETURNS ANY STATUS CODE THAT WAS INTERNALLY +C SET WITHIN THE BUFR ARCHIVE LIBRARY SOFTWARE FOR A GIVEN LOGICAL +C UNIT NUMBER +C +C PROGRAM HISTORY LOG: +C 2010-05-11 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IGETSC (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C IGETSC - INTEGER: STATUS CODE FOR LUNIT: +C 0 = no problems noted with LUNIT +C -1 = unable to position LUNIT for appending, +C possibly due to an incomplete BUFR message +C at the end of the file +C +C REMARKS: +C THIS ROUTINE CALLS: BORT STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /STCODE/ ISCODES(NFILES) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Make sure the specified logical unit is connected to the library. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + + IGETSC = ISCODES(LUN) + + RETURN + 900 CALL BORT('BUFRLIB: IGETSC - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') + END diff --git a/src/bufr/igettdi.f b/src/bufr/igettdi.f new file mode 100644 index 0000000000..fed3282d02 --- /dev/null +++ b/src/bufr/igettdi.f @@ -0,0 +1,69 @@ + FUNCTION IGETTDI ( IFLAG ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IGETTDI +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: DEPENDING ON THE VALUE OF THE INPUT FLAG, THIS FUNCTION +C EITHER RETURNS THE NEXT USABLE SCRATCH TABLE D INDEX FOR THE +C CURRENT MASTER TABLE OR ELSE RESETS THE INDEX BACK TO ITS +C MINIMUM VALUE. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL IGETTDI ( IFLAG ) +C INPUT ARGUMENT LIST: +C IFLAG - INTEGER: FLAG: IF SET TO 0, THEN THE FUNCTION WILL +C RESET THE SCRATCH TABLE D INDEX BACK TO ITS MINIMUM +C VALUE; OTHERWISE, IT WILL RETURN THE NEXT USABLE +C SCRATCH TABLE D INDEX FOR THE CURRENT MASTER TABLE +C +C OUTPUT ARGUMENT LIST: +C IGETTDI - INTEGER: NEXT USABLE SCRATCH TABLE D INDEX FOR THE +C CURRENT MASTER TABLE +C -1 = FUNCTION WAS CALLED WITH IFLAG=0 +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: READMT READS3 STSEQ +C Not normally called by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + PARAMETER ( IDXMIN = 62976 ) +C* = IFXY('354000') + + PARAMETER ( IDXMAX = 63231 ) +C* = IFXY('354255') + + CHARACTER*128 BORT_STR + + SAVE IDX + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF ( IFLAG .EQ. 0 ) THEN + +C* Initialize the index to one less than the actual minimum +C* value. That way, the next normal call will return the +C* minimum value. + + IDX = IDXMIN - 1 + IGETTDI = -1 + ELSE + IDX = IDX + 1 + IF ( IDX .GT. IDXMAX ) GOTO 900 + IGETTDI = IDX + ENDIF + + RETURN + 900 CALL BORT('BUFRLIB: IGETTDI - IDXMAX OVERFLOW') + END diff --git a/src/bufr/inctab.f b/src/bufr/inctab.f new file mode 100644 index 0000000000..17c67176ad --- /dev/null +++ b/src/bufr/inctab.f @@ -0,0 +1,81 @@ + SUBROUTINE INCTAB(ATAG,ATYP,NODE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: INCTAB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE RETURNS THE NEXT AVAILABLE POSITIONAL INDEX +C FOR WRITING INTO THE INTERNAL JUMP/LINK TABLE IN COMMON BLOCK +C /TABLES/, AND IT ALSO USES THAT INDEX TO STORE ATAG AND ATYP +C WITHIN, RESPECTIVELY, THE INTERNAL JUMP/LINK TABLE ARRAYS TAG(*) +C AND TYP(*). IF THERE IS NO MORE ROOM FOR ADDITIONAL ENTRIES WITHIN +C THE INTERNAL JUMP/LINK TABLE, THEN AN APPROPRIATE CALL IS MADE TO +C BUFR ARCHIVE LIBRARY SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: CALL INCTAB (ATAG, ATYP, NODE) +C INPUT ARGUMENT LIST: +C ATAG - CHARACTER*(*): MNEMONIC NAME +C ATYP - CHARACTER*(*): MNEMONIC TYPE +C +C OUTPUT ARGUMENT LIST: +C NODE - INTEGER: NEXT AVAILABLE POSITIONAL INDEX FOR WRITING +C INTO THE INTERNAL JUMP/LINK TABLE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: TABENT TABSUB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*(*) ATAG,ATYP + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + NTAB = NTAB+1 + IF(NTAB.GT.MAXTAB) GOTO 900 + TAG(NTAB) = ATAG + TYP(NTAB) = ATYP + NODE = NTAB + +C EXITS +C ----- + + RETURN + 900 WRITE(BORT_STR,'("BUFRLIB: INCTAB - THE NUMBER OF JUMP/LINK '// + . 'TABLE ENTRIES EXCEEDS THE LIMIT, MAXTAB (",I7,")")') MAXTAB + CALL BORT(BORT_STR) + END diff --git a/src/bufr/invcon.f b/src/bufr/invcon.f new file mode 100644 index 0000000000..25a7a59c06 --- /dev/null +++ b/src/bufr/invcon.f @@ -0,0 +1,107 @@ + FUNCTION INVCON(NC,LUN,INV1,INV2) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: INVCON +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION SEARCHES A "WINDOW" (SEE BELOW REMARKS) FOR AN +C ELEMENT IDENTIFIED IN THE USER STRING AS A CONDITIONAL NODE (I.E. AN +C ELEMENT WHICH MUST MEET A CONDITION IN ORDER TO BE READ FROM OR WRITTEN TO +C A DATA SUBSET). IF A CONDITIONAL ELEMENT IS FOUND AND IT CONFORMS TO THE +C CONDITION, THEN THE INDEX OF THE ELEMENT WITHIN THE WINDOW IS RETURNED. +C OTHERWISE A VALUE OF ZERO IS RETURNED. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE); OUTPUTS MORE +C COMPLETE DIAGNOSTIC INFO WHEN UNUSUAL +C THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C 2010-04-27 J. WOOLLEN -- ADD DOCUMENTATION +C +C USAGE: INVCON (NC, LUN, INV1, INV2) +C INPUT ARGUMENT LIST: +C NC - INTEGER: CONDITION CODE: +C 1 = '=' (EQUAL) +C 2 = '!' (NOT EQUAL) +C 3 = '<' (LESS THAN) +C 4 = '>' (GREATER THAN) +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INV1 - INTEGER: FIRST INDEX OF WINDOW TO SEARCH +C INV2 - INTEGER: LAST INDEX OF WINDOW TO SEARCH +C +C OUTPUT ARGUMENT LIST: +C INVCON - INTEGER: INDEX WITHIN WINDOW OF CONDITIONAL NODE CONFORMING +C TO SPECIFIED CONDITION +C 0 = NONE FOUND +C +C REMARKS: +C +C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN +C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. +C +C THIS ROUTINE CALLS: ERRWRT +C THIS ROUTINE IS CALLED BY: CONWIN +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /QUIET / IPRT + + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C CHECK THE INVENTORY INTERVAL +C ---------------------------- + + IF(INV1.LE.0 .OR. INV1.GT.NVAL(LUN)) GOTO 99 + IF(INV2.LE.0 .OR. INV2.GT.NVAL(LUN)) GOTO 99 + +C FIND AN OCCURANCE OF NODE IN THE WINDOW MEETING THIS CONDITION +C -------------------------------------------------------------- + + DO INVCON=INV1,INV2 + IF(INV(INVCON,LUN).EQ.NODC(NC)) THEN + IF(KONS(NC).EQ.1 .AND. VAL(INVCON,LUN).EQ.IVLS(NC)) GOTO 100 + IF(KONS(NC).EQ.2 .AND. VAL(INVCON,LUN).NE.IVLS(NC)) GOTO 100 + IF(KONS(NC).EQ.3 .AND. VAL(INVCON,LUN).LT.IVLS(NC)) GOTO 100 + IF(KONS(NC).EQ.4 .AND. VAL(INVCON,LUN).GT.IVLS(NC)) GOTO 100 + ENDIF + ENDDO + +99 INVCON = 0 + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT('BUFRLIB: INVCON - RETURNING WITH A VALUE OF 0') + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/invmrg.f b/src/bufr/invmrg.f new file mode 100644 index 0000000000..ebf75a2c6a --- /dev/null +++ b/src/bufr/invmrg.f @@ -0,0 +1,156 @@ + SUBROUTINE INVMRG(LUBFI,LUBFJ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: INVMRG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 +C +C ABSTRACT: THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE +C DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERENT OR UNIQUE +C OBSERVATIONAL DATA. IT CANNOT MERGE REPLICATED DATA. +C +C PROGRAM HISTORY LOG: +C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-11-25 J. WOOLLEN -- MODIFIED FOR RADIOSONDE CALL SIGNS +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES; +C REMOVED ENTRY POINT MRGINV (IT BECAME A +C SEPARATE ROUTINE IN THE BUFRLIB TO +C INCREASE PORTABILITY TO OTHER PLATFORMS) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS AND SIMPLIFY LOGIC +C +C USAGE: CALL INVMRG (LUBFI, LUBFJ) +C INPUT ARGUMENT LIST: +C LUBFI - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUBFJ - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IBFMS NWORDS STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*3 TYP + LOGICAL HEREI,HEREJ,MISSI,MISSJ,SAMEI + REAL*8 VAL + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IS = 1 + JS = 1 + +C GET THE UNIT POINTERS +C --------------------- + + CALL STATUS(LUBFI,LUNI,IL,IM) + CALL STATUS(LUBFJ,LUNJ,JL,JM) + +C STEP THROUGH THE BUFFERS COMPARING THE INVENTORY AND MERGING DATA +C ----------------------------------------------------------------- + + DO WHILE(IS.LE.NVAL(LUNI)) + +C CHECK TO SEE WE ARE AT THE SAME NODE IN EACH BUFFER +C --------------------------------------------------- + + NODE = INV(IS,LUNI) + NODJ = INV(JS,LUNJ) + IF(NODE.NE.NODJ) GOTO 900 + + ITYP = ITP(NODE) + +C FOR TYPE 1 NODES DO AN ENTIRE SEQUENCE REPLACEMENT +C -------------------------------------------------- + + IF(ITYP.EQ.1) THEN + IF(TYP(NODE).EQ.'DRB') IOFF = 0 + IF(TYP(NODE).NE.'DRB') IOFF = 1 + IWRDS = NWORDS(IS,LUNI)+IOFF + JWRDS = NWORDS(JS,LUNJ)+IOFF + IF(IWRDS.GT.IOFF .AND. JWRDS.EQ.IOFF) THEN + DO N=NVAL(LUNJ),JS+1,-1 + INV(N+IWRDS-JWRDS,LUNJ) = INV(N,LUNJ) + VAL(N+IWRDS-JWRDS,LUNJ) = VAL(N,LUNJ) + ENDDO + DO N=0,IWRDS + INV(JS+N,LUNJ) = INV(IS+N,LUNI) + VAL(JS+N,LUNJ) = VAL(IS+N,LUNI) + ENDDO + NVAL(LUNJ) = NVAL(LUNJ)+IWRDS-JWRDS + JWRDS = IWRDS + NRPL = NRPL+1 + ENDIF + IS = IS+IWRDS + JS = JS+JWRDS + ENDIF + +C FOR TYPES 2 AND 3 FILL MISSINGS +C ------------------------------- + + IF((ITYP.EQ.2).OR.(ITYP.EQ.3)) THEN + HEREI = IBFMS(VAL(IS,LUNI)).EQ.0 + HEREJ = IBFMS(VAL(JS,LUNJ)).EQ.0 + MISSI = .NOT.(HEREI) + MISSJ = .NOT.(HEREJ) + SAMEI = VAL(IS,LUNI).EQ.VAL(JS,LUNJ) + IF(HEREI.AND.MISSJ) THEN + VAL(JS,LUNJ) = VAL(IS,LUNI) + NMRG = NMRG+1 + ELSEIF(HEREI.AND.HEREJ.AND..NOT.SAMEI) THEN + NAMB = NAMB+1 + ENDIF + ENDIF + +C BUMP THE COUNTERS AND GO CHECK THE NEXT PAIR +C -------------------------------------------- + + IS = IS + 1 + JS = JS + 1 + ENDDO + + NTOT = NTOT+1 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '// + . '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), '// + . 'TABULAR MISMATCH")') NODE,NODJ + CALL BORT(BORT_STR) + END diff --git a/src/bufr/invtag.f b/src/bufr/invtag.f new file mode 100644 index 0000000000..32a063a4fc --- /dev/null +++ b/src/bufr/invtag.f @@ -0,0 +1,99 @@ + FUNCTION INVTAG(NODE,LUN,INV1,INV2) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: INVTAG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION LOOKS FOR A SPECIFIED MNEMONIC WITHIN THE +C PORTION OF THE CURRENT SUBSET BUFFER BOUNDED BY THE INDICES INV1 +C AND INV2. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION INVWIN, +C EXCEPT THAT INVWIN SEARCHES BASED ON THE ACTUAL NODE WITHIN THE +C INTERNAL JUMP/LINK TABLE, RATHER THAN ON THE MNEMONIC CORRESPONDING +C TO THAT NODE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN UNUSUAL THINGS HAPPEN +C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: INVTAG (NODE, LUN, INV1, INV2) +C INPUT ARGUMENT LIST: +C NODE - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK +C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK +C +C OUTPUT ARGUMENT LIST: +C INVTAG - INTEGER: LOCATION INDEX OF NODE WITHIN SPECIFIED +C PORTION OF SUBSET BUFFER +C 0 = NOT FOUND +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT +C THIS ROUTINE IS CALLED BY: UFBRP UFBSEQ UFBSP +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET/ IPRT + + CHARACTER*10 TAG,TAGN + CHARACTER*3 TYP + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + INVTAG = 0 + IF(NODE.EQ.0) GOTO 200 + TAGN = TAG(NODE) + +C SEARCH BETWEEN INV1 AND INV2 +C ---------------------------- + +10 DO INVTAG=INV1,INV2 + IF(TAG(INV(INVTAG,LUN)).EQ.TAGN) GOTO 100 + ENDDO + + INVTAG = 0 + +200 IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT('BUFRLIB: INVTAG - RETURNING WITH A VALUE OF 0') + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/invwin.f b/src/bufr/invwin.f new file mode 100644 index 0000000000..48f5217255 --- /dev/null +++ b/src/bufr/invwin.f @@ -0,0 +1,90 @@ + FUNCTION INVWIN(NODE,LUN,INV1,INV2) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: INVWIN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION LOOKS FOR A SPECIFIED NODE WITHIN THE PORTION +C OF THE CURRENT SUBSET BUFFER BOUNDED BY THE INDICES INV1 AND INV2. +C IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION INVTAG, EXCEPT THAT +C INVTAG SEARCHES BASED ON THE MNEMONIC CORRESPONDING TO THE NODE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN UNUSUAL THINGS HAPPEN +C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: INVWIN (NODE, LUN, INV1, INV2) +C INPUT ARGUMENT LIST: +C NODE - INTEGER: JUMP/LINK TABLE INDEX TO LOOK FOR +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK +C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK +C +C OUTPUT ARGUMENT LIST: +C INVWIN - INTEGER: LOCATION INDEX OF NODE WITHIN SPECIFIED +C PORTION OF SUBSET BUFFER +C 0 = NOT FOUND +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT +C THIS ROUTINE IS CALLED BY: DRSTPL GETWIN NEVN TRYBUMP +C UFBGET UFBRW UFBSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET/ IPRT + + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + INVWIN = 0 + IF(NODE.EQ.0) GOTO 200 + +C SEARCH BETWEEN INV1 AND INV2 +C ---------------------------- + +10 DO INVWIN=INV1,INV2 + IF(INV(INVWIN,LUN).EQ.NODE) GOTO 100 + ENDDO + + INVWIN = 0 + + 200 IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT('BUFRLIB: INVWIN - RETURNING WITH A VALUE OF 0') + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/iok2cpy.f b/src/bufr/iok2cpy.f new file mode 100644 index 0000000000..ec2d000240 --- /dev/null +++ b/src/bufr/iok2cpy.f @@ -0,0 +1,97 @@ + INTEGER FUNCTION IOK2CPY(LUI,LUO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IOK2CPY +C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-06-26 +C +C ABSTRACT: THIS FUNCTION DETERMINES WHETHER A MESSAGE, OR A SUBSET +C FROM A MESSAGE, CAN BE COPIED FROM LOGICAL UNIT IOLUN(LUI) TO +C LOGICAL UNIT IOLUN(LUO). THE DECISION IS BASED ON WHETHER THE +C EXACT SAME DEFINITION FOR THE GIVEN MESSAGE TYPE APPEARS WITHIN +C THE DICTIONARY TABLE INFORMATION FOR BOTH LOGICAL UNITS. NOTE THAT +C IT IS POSSIBLE FOR A MESSAGE TYPE TO BE IDENTICALLY DEFINED FOR TWO +C DIFFERENT LOGICAL UNITS EVEN IF THE UNITS THEMSELVES DON'T SHARE +C THE EXACT SAME FULL SET OF DICTIONARY TABLES. +C +C PROGRAM HISTORY LOG: +C 2009-06-26 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IOK2CPY (LUI, LUO) +C INPUT ARGUMENT LIST: +C LUI - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR LOGICAL UNIT TO COPY FROM +C LUO - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR LOGICAL UNIT TO COPY TO +C +C OUTPUT ARGUMENT LIST: +C IOK2CPY - INTEGER: RETURN CODE INDICATING WHETHER IT IS OKAY TO +C COPY FROM IOLUN(LUI) TO IOLUN(LUO) +C 0 - NO +C 1 - YES +C +C REMARKS: +C THIS ROUTINE CALLS: ICMPDX NEMTBAX +C THIS ROUTINE IS CALLED BY: COPYSB COPYMG CPYMEM UFBCPY +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*8 SUBSET + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IOK2CPY = 0 + +C Do both logical units have the same internal table information? + + IF ( ICMPDX(LUI,LUO) .EQ. 1 ) THEN + IOK2CPY = 1 + RETURN + ENDIF + +C No, so get the Table A mnemonic from the message to be copied, +C then check whether that mnemonic is defined within the dictionary +C tables for the logical unit to be copied to. + + SUBSET = TAG(INODE(LUI)) + CALL NEMTBAX(LUO,SUBSET,MTYP,MSBT,INOD) + IF ( INOD .EQ. 0 ) RETURN + +C The Table A mnemonic is defined within the dictionary tables for +C both units, so now make sure the definitions are identical. + + NTEI = ISC(INODE(LUI))-INODE(LUI) + NTEO = ISC(INOD)-INOD + IF ( NTEI .NE. NTEO ) RETURN + + DO I = 1, NTEI + IF ( TAG(INODE(LUI)+I) .NE. TAG(INOD+I) ) RETURN + IF ( TYP(INODE(LUI)+I) .NE. TYP(INOD+I) ) RETURN + IF ( ISC(INODE(LUI)+I) .NE. ISC(INOD+I) ) RETURN + IF ( IRF(INODE(LUI)+I) .NE. IRF(INOD+I) ) RETURN + IF ( IBT(INODE(LUI)+I) .NE. IBT(INOD+I) ) RETURN + ENDDO + + IOK2CPY = 1 + + RETURN + END diff --git a/src/bufr/ipkm.f b/src/bufr/ipkm.f new file mode 100644 index 0000000000..c3c24d03bc --- /dev/null +++ b/src/bufr/ipkm.f @@ -0,0 +1,77 @@ + SUBROUTINE IPKM(CBAY,NBYT,N) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IPKM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER N INTO A CHARACTER STRING +C CBAY OF LENGTH NBYT BYTES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS +C IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL IPKM (CBAY, NBYT, N) +C INPUT ARGUMENT LIST: +C NBYT - INTEGER: NUMBER OF BYTES INTO WHICH TO PACK N (LENGTH +C OF STRING) +C N - INTEGER: INTEGER TO BE PACKED +C +C OUTPUT ARGUMENT LIST: +C CBAY - CHARACTER*8: STRING OF LENGTH NBYT BYTES CONTAINING +C PACKED INTEGER N +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IREV +C THIS ROUTINE IS CALLED BY: BFRINI CHRTRNA CRBMG PKC +C PKTDD UPC WRDXTB WRTREE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*128 BORT_STR + CHARACTER*8 CBAY,CINT + EQUIVALENCE (CINT,INT) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(NBYT.GT.NBYTW) GOTO 900 + +C Note that the widths of input variable N and local variable INT +C will both be equal to the default size of an integer (= NBYTW), +C since they aren't specifically declared otherwise. + + INT = IREV(ISHFT(N,(NBYTW-NBYT)*8)) + DO I=1,NBYT + CBAY(I:I) = CINT(I:I) + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: IPKM - NUMBER OF BYTES BEING PACKED '// + . ', NBYT (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// + . 'MACHINE, NBYTW (",I3,")")') NBYT,NBYTW + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ipks.f b/src/bufr/ipks.f new file mode 100644 index 0000000000..b0698a44ce --- /dev/null +++ b/src/bufr/ipks.f @@ -0,0 +1,96 @@ + INTEGER FUNCTION IPKS(VAL,NODE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IPKS +C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-03-02 +C +C ABSTRACT: THIS FUNCTION PACKS A REAL*8 USER VALUE INTO A BUFR +C INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES. +C NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX +C NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*); +C HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A +C 2-03 OPERATOR IS IN EFFECT FOR THIS NODE. +C +C PROGRAM HISTORY LOG: +C 2012-03-02 J. ATOR -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL +C STATEMENT FUNCTION IN WRTREE +C +C USAGE: IPKS (VAL,NODE) +C INPUT ARGUMENT LIST: +C VAL - REAL*8: USER VALUE +C NODE - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES +C +C OUTPUT ARGUMENT LIST: +C IPKS - INTEGER: PACKED BUFR VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: WRTREE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), + . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV + + CHARACTER*10 TAG + CHARACTER*8 TAGNRV + CHARACTER*3 TYP + + REAL*8 TEN,VAL + + DATA TEN /10./ + +C----------------------------------------------------------------------- + + IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - IRF(NODE) + + IF ( NNRV .GT. 0 ) THEN + +C There are redefined reference values in the jump/link table, +C so we need to check if this node is affected by any of them. + + DO JJ = 1, NNRV + IF ( NODE .EQ. INODNRV(JJ) ) THEN + +C This node contains a redefined reference value. +C Per the rules of BUFR, negative values should be encoded +C as positive integers with the left-most bit set to 1. + + NRV(JJ) = NINT(VAL) + IF ( NRV(JJ) .LT. 0 ) THEN + IMASK = 2**(IBT(NODE)-1) + IPKS = IOR(IABS(NRV(JJ)),IMASK) + ELSE + IPKS = NRV(JJ) + END IF + RETURN + ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND. + . ( NODE .GE. ISNRV(JJ) ) .AND. + . ( NODE .LE. IENRV(JJ) ) ) THEN + +C The corresponding redefinded reference value needs to +C be used when encoding this value. + + IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - NRV(JJ) + RETURN + END IF + END DO + + END IF + + RETURN + END diff --git a/src/bufr/ireadmg.f b/src/bufr/ireadmg.f new file mode 100644 index 0000000000..98743b2cb9 --- /dev/null +++ b/src/bufr/ireadmg.f @@ -0,0 +1,54 @@ + FUNCTION IREADMG(LUNIT,SUBSET,IDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IREADMG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READMG +C AND PASSES BACK ITS RETURN CODE. SEE READMG FOR MORE DETAILS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1999-11-18 J. WOOLLEN -- ADDED NEW FUNCTION ENTRY POINTS IREADMM AND +C IREADIBM +C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINTS ICOPYSB, IREADFT, +C IREADIBM, IREADMM, IREADNS AND IREADSB +C (THEY BECAME SEPARATE ROUTINES IN THE +C BUFRLIB TO INCREASE PORTABILITY TO OTHER +C PLATFORMS) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: IREADMG (LUNIT, SUBSET, IDATE) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IREADMG - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more BUFR messages in LUNIT +C +C REMARKS: +C THIS ROUTINE CALLS: READMG +C THIS ROUTINE IS CALLED BY: UFBTAB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*8 SUBSET + CALL READMG(LUNIT,SUBSET,IDATE,IRET) + IREADMG = IRET + RETURN + END diff --git a/src/bufr/ireadmm.f b/src/bufr/ireadmm.f new file mode 100644 index 0000000000..1f10ee2e9e --- /dev/null +++ b/src/bufr/ireadmm.f @@ -0,0 +1,56 @@ + FUNCTION IREADMM(IMSG,SUBSET,IDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IREADMM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 +C +C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READMM +C AND PASSES BACK ITS RETURN CODE. SEE READMM FOR MORE DETAILS. +C +C PROGRAM HISTORY LOG: +C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: IREADMM (IMSG, SUBSET, IDATE) +C INPUT ARGUMENT LIST: +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C STORAGE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IREADMM - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = IMSG is either 0 or greater than the +C number of messages in memory +C +C REMARKS: +C THIS ROUTINE CALLS: READMM +C THIS ROUTINE IS CALLED BY: UFBMNS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*8 SUBSET + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL READMM(IMSG,SUBSET,IDATE,IRET) + IREADMM = IRET + + RETURN + END diff --git a/src/bufr/ireadns.f b/src/bufr/ireadns.f new file mode 100644 index 0000000000..fcf2f1407f --- /dev/null +++ b/src/bufr/ireadns.f @@ -0,0 +1,51 @@ + FUNCTION IREADNS(LUNIT,SUBSET,IDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IREADNS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READNS +C AND PASSES BACK ITS RETURN CODE. SEE READNS FOR MORE DETAILS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: IREADNS (LUNIT, SUBSET, IDATE) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE +C CONTAINING SUBSET BEING READ +C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE CONTAINING SUBSET BEING READ, IN FORMAT OF +C EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON DATELEN() +C VALUE +C IREADNS - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the BUFR file +C +C REMARKS: +C THIS ROUTINE CALLS: READNS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*8 SUBSET + CALL READNS(LUNIT,SUBSET,IDATE,IRET) + IREADNS = IRET + RETURN + END diff --git a/src/bufr/ireadsb.f b/src/bufr/ireadsb.f new file mode 100644 index 0000000000..c68aa539d2 --- /dev/null +++ b/src/bufr/ireadsb.f @@ -0,0 +1,44 @@ + FUNCTION IREADSB(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IREADSB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READSB +C AND PASSES BACK ITS RETURN CODE. SEE READSB FOR MORE DETAILS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: IREADSB (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C IREADSB - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the BUFR +C message +C +C REMARKS: +C THIS ROUTINE CALLS: READSB +C THIS ROUTINE IS CALLED BY: UFBTAB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CALL READSB(LUNIT,IRET) + IREADSB = IRET + RETURN + END diff --git a/src/bufr/irev.F b/src/bufr/irev.F new file mode 100755 index 0000000000..fd0ab62208 --- /dev/null +++ b/src/bufr/irev.F @@ -0,0 +1,80 @@ + FUNCTION IREV(N) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IREV +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION WILL, WHEN THE LOCAL MACHINE IS "LITTLE- +C ENDIAN" (I.E., USES A RIGHT TO LEFT SCHEME FOR NUMBERING THE BYTES +C WITHIN A MACHINE WORD), RETURN A COPY OF AN INPUT INTEGER WORD WITH +C THE BYTES REVERSED. ALTHOUGH, BY DEFINITION (WITHIN WMO MANUAL +C 306), A BUFR MESSAGE IS A STREAM OF INDIVIDUAL OCTETS (I.E., BYTES) +C THAT IS INDEPENDENT OF ANY PARTICULAR MACHINE REPRESENTATION, THE +C BUFR ARCHIVE LIBRARY SOFTWARE OFTEN NEEDS TO INTERPRET ALL OR PARTS +C OF TWO OR MORE ADJACENT BYTES IN ORDER TO CONSTRUCT AN INTEGER +C WORD. BY DEFAULT, THE SOFTWARE USES THE "BIG-ENDIAN" (LEFT TO +C RIGHT) SCHEME FOR NUMBERING BYTES. BY REVERSING THE BYTES, IREV +C ALLOWS THE INTEGER WORD TO BE PROPERLY READ OR WRITTEN (DEPENDING +C ON WHETHER INPUT OR OUTPUT OPERATIONS, RESPECTIVELY, ARE BEING +C PERFORMED) ON LITTLE-ENDIAN MACHINES. IF THE LOCAL MACHINE IS +C BIG-ENDIAN, IREV SIMPLY RETURNS A COPY OF THE SAME INTEGER THAT WAS +C INPUT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2007-01-19 J. ATOR -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW +C DETERMINED AT COMPILE TIME AND CONFIGURED +C WITHIN BUFRLIB VIA CONDITIONAL COMPILATION +C DIRECTIVES +C +C USAGE: IREV (N) +C INPUT ARGUMENT LIST: +C N - INTEGER: INTEGER WORD WITH BYTES ORDERED ACCORDING TO +C THE "BIG-ENDIAN" NUMBERING SCHEME +C +C OUTPUT ARGUMENT LIST: +C IREV - INTEGER: INTEGER WORD WITH BYTES ORDERED ACCORDING TO +C THE NUMBERING SCHEME OF THE LOCAL MACHINE (EITHER +C "BIG-ENDIAN" OR "LITTLE-ENDIAN", IF "BIG-ENDIAN THEN +C THIS IS JUST A DIRECT COPY OF N) +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: IPKM IUPM PKB PKC +C UPBB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*8 CINT,DINT + EQUIVALENCE(CINT,INT) + EQUIVALENCE(DINT,JNT) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +#ifdef BIG_ENDIAN + IREV = N +#else + INT = N + DO I=1,NBYTW + DINT(I:I) = CINT(IORD(I):IORD(I)) + ENDDO + IREV = JNT +#endif + + RETURN + END diff --git a/src/bufr/ishrdx.f b/src/bufr/ishrdx.f new file mode 100644 index 0000000000..40ede2ce67 --- /dev/null +++ b/src/bufr/ishrdx.f @@ -0,0 +1,80 @@ + INTEGER FUNCTION ISHRDX(LUD,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ISHRDX +C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-11-30 +C +C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) IS +C SHARING INTERNAL TABLE INFORMATION WITH LOGICAL UNIT IOLUN(LUD). +C NOTE THAT TWO LOGICAL UNITS CAN HAVE THE SAME INTERNAL TABLE +C INFORMATION WITHOUT ACTUALLY SHARING IT. +C +C PROGRAM HISTORY LOG: +C 2009-11-30 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: ISHRDX (LUD, LUN) +C INPUT ARGUMENT LIST: +C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR FIRST LOGICAL UNIT +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C FOR SECOND LOGICAL UNIT +C +C OUTPUT ARGUMENT LIST: +C ISHRDX - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN) +C IS SHARING TABLE INFORMATION WITH IOLUN(LUD): +C 0 - NO +C 1 - YES +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: ICMPDX MAKESTAB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Note that, for any I/O stream index value LUx, the MTAB(*,LUx) +C array contains pointer indices into the internal jump/link table +C for each of the Table A mnemonics that is currently defined for +C that LUx value. Thus, if all of these indices are identical for +C two different LUx values, then the associated logical units are +C sharing table information. + + IF ( ( NTBA(LUD) .GE. 1 ) .AND. + + ( NTBA(LUD) .EQ. NTBA(LUN) ) ) THEN + II = 1 + ISHRDX = 1 + DO WHILE ( ( II .LE. NTBA(LUD) ) .AND. ( ISHRDX .EQ. 1 ) ) + IF ( ( MTAB(II,LUD) .NE. 0 ) .AND. + + ( MTAB(II,LUD) .EQ. MTAB(II,LUN) ) ) THEN + II = II + 1 + ELSE + ISHRDX = 0 + ENDIF + ENDDO + ELSE + ISHRDX = 0 + ENDIF + + RETURN + END diff --git a/src/bufr/isize.f b/src/bufr/isize.f new file mode 100644 index 0000000000..fe4b44b27c --- /dev/null +++ b/src/bufr/isize.f @@ -0,0 +1,51 @@ + INTEGER FUNCTION ISIZE (NUM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ISIZE +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS FUNCTION COMPUTES AND RETURNS THE NUMBER OF CHARACTERS +C NEEDED TO ENCODE THE INPUT INTEGER NUM AS A STRING. IT DOES NOT +C ACTUALLY ENCODE THE STRING BUT RATHER ONLY FIGURES OUT THE REQUIRED +C SIZE. NUM MUST BE AN INTEGER IN THE RANGE OF 0 TO 99999. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL ISIZE ( NUM ) +C INPUT ARGUMENT LIST: +C NUM - INTEGER: NUMBER TO BE ENCODED +C +C OUTPUT ARGUMENT LIST: +C ISIZE - INTEGER: NUMBER OF CHARACTERS NECESSARY TO ENCODE NUM +C AS A STRING +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: READMT UFBDMP UFDUMP +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF ( NUM .LT. 0 ) GOTO 900 + DO ISIZE = 1, 5 + IF ( NUM .LT. 10**ISIZE ) RETURN + ENDDO + GOTO 900 + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: ISIZE - INPUT NUMBER (",I7,'// + . '") IS OUT OF RANGE")') NUM + CALL BORT(BORT_STR) + END diff --git a/src/bufr/istdesc.f b/src/bufr/istdesc.f new file mode 100644 index 0000000000..def330bd11 --- /dev/null +++ b/src/bufr/istdesc.f @@ -0,0 +1,56 @@ + FUNCTION ISTDESC( IDN ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ISTDESC +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF THE FXY VALUE +C FOR A DESCRIPTOR, THIS FUNCTION DETERMINES WHETHER THE DESCRIPTOR +C IS A WMO-STANDARD DESCRIPTOR OR A LOCAL DESCRIPTOR. +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: ISTDESC( IDN ) +C INPUT ARGUMENT LIST: +C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE +C FOR DESCRIPTOR TO BE CHECKED +C +C OUTPUT ARGUMENT LIST: +C ISTDESC - INTEGER: RETURN VALUE: +C 0 - IDN IS A LOCAL DESCRIPTOR +C 1 - IDN IS A WMO-STANDARD DESCRIPTOR +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 +C THIS ROUTINE IS CALLED BY: READS3 RESTD STNDRD +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*6 ADSC, ADN30 + + ADSC = ADN30( IDN, 6 ) + + READ(ADSC,'(I1,I2,I3)') IF,IX,IY + IF ( ( IF .EQ. 1 ) .OR. ( IF .EQ. 2 ) ) THEN + +C ADSC IS EITHER A REPLICATOR OR TABLE C OPERATOR DESCRIPTOR. +C SINCE LOCAL VERSIONS OF SUCH DESCRIPTORS ARE NOT ALLOWED, +C THEN ADSC IS STANDARD BY DEFAULT. + + ISTDESC = 1 + ELSE IF ( ( IX .LT. 48 ) .AND. ( IY .LT. 192 ) ) THEN + ISTDESC = 1 + ELSE + ISTDESC = 0 + END IF + + RETURN + END diff --git a/src/bufr/iupb.f b/src/bufr/iupb.f new file mode 100644 index 0000000000..1a98765b63 --- /dev/null +++ b/src/bufr/iupb.f @@ -0,0 +1,55 @@ + FUNCTION IUPB(MBAY,NBYT,NBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IUPB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD +C CONTAINED WITHIN NBIT BITS OF A BUFR MESSAGE PACKED INTO THE +C INTEGER ARRAY MBAY, STARTING WITH THE FIRST BIT OF BYTE NBYT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C +C USAGE: IUPB (MBAY, NBYT, NBIT) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE +C NBYT - INTEGER: BYTE WITHIN MBAY AT WHOSE FIRST BIT TO BEGIN +C UNPACKING +C NBIT - INTEGER: NUMBER OF BITS WITHIN MBAY TO BE UNPACKED +C +C OUTPUT ARGUMENT LIST: +C IUPB - INTEGER: UNPACKED INTEGER WORD +C +C REMARKS: +C THIS ROUTINE CALLS: UPB +C THIS ROUTINE IS CALLED BY: CKTABA CPYUPD GETLENS IUPBS01 +C IUPBS3 MSGUPD MSGWRT RDMEMS +C STNDRD STRCPT SUBUPD UPDS3 +C WRITLC +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MBAY(*) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + MBIT = (NBYT-1)*8 + CALL UPB(IRET,NBIT,MBAY,MBIT) + IUPB = IRET + RETURN + END diff --git a/src/bufr/iupbs01.f b/src/bufr/iupbs01.f new file mode 100644 index 0000000000..e02dd1230f --- /dev/null +++ b/src/bufr/iupbs01.f @@ -0,0 +1,179 @@ + FUNCTION IUPBS01(MBAY,S01MNEM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IUPBS01 +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE +C FROM SECTION 0 OR SECTION 1 OF THE BUFR MESSAGE STORED IN ARRAY +C MBAY. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 +C OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST +C BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE +C UNPACKED IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS EXPLAINED IN +C FURTHER DETAIL BELOW. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2006-04-14 J. ATOR -- ADDED OPTIONS FOR 'YCEN' AND 'CENT'; +C RESTRUCTURED LOGIC +C +C USAGE: IUPBS01 (MBAY, S01MNEM) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR MESSAGE +C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE +C UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE: +C 'LENM' = LENGTH (IN BYTES) OF BUFR MESSAGE +C 'LEN0' = LENGTH (IN BYTES) OF SECTION 0 +C 'BEN' = BUFR EDITION NUMBER +C 'LEN1' = LENGTH (IN BYTES) OF SECTION 1 +C 'BMT' = BUFR MASTER TABLE +C 'OGCE' = ORIGINATING CENTER +C 'GSES' = ORIGINATING SUBCENTER +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 3 OR 4 MESSAGES!) +C 'USN' = UPDATE SEQUENCE NUMBER +C 'ISC2' = FLAG INDICATING ABSENCE/PRESENCE OF +C (OPTIONAL) SECTION 2 IN BUFR MESSAGE: +C 0 = SECTION 2 ABSENT +C 1 = SECTION 2 PRESENT +C 'MTYP' = DATA CATEGORY +C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MSBT' = DATA SUBCATEGORY (LOCAL) +C 'MTV' = VERSION NUMBER OF MASTER TABLE +C 'MTVL' = VERSION NUMBER OF LOCAL TABLES +C 'YCEN' = YEAR OF CENTURY (1-100) +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 2 AND 3 MESSAGES!) +C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, +C 21 FOR YEARS 2001-2100) +C (NOTE: THIS VALUE *MAY* BE PRESENT IN +C BUFR EDITION 2 AND 3 MESSAGES, +C BUT IT IS NEVER PRESENT IN ANY +C BUFR EDITION 4 MESSAGES!) +C 'YEAR' = YEAR (4-DIGIT) +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 4 MESSAGES. FOR +C BUFR EDITION 2 AND 3 MESSAGES +C IT WILL BE CALCULATED USING THE +C VALUES FOR 'YCEN' AND 'CENT', +C EXCEPT WHEN THE LATTER IS NOT +C PRESENT AND IN WHICH CASE A +C "WINDOWING" TECHNIQUE WILL BE +C USED INSTEAD!) +C 'MNTH' = MONTH +C 'DAYS' = DAY +C 'HOUR' = HOUR +C 'MINU' = MINUTE +C 'SECO' = SECOND +C (NOTE: THIS VALUE IS PRESENT ONLY IN +C BUFR EDITION 4 MESSAGES!) +C +C OUTPUT ARGUMENT LIST: +C IUPBS01 - INTEGER: UNPACKED INTEGER VALUE +C -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID FOR +C THE EDITION OF BUFR MESSAGE IN MBAY +C +C REMARKS: +C THIS ROUTINE CALLS: GETS1LOC I4DY IUPB WRDLEN +C THIS ROUTINE IS CALLED BY: ATRCPT CKTABA CNVED4 COPYBF +C COPYMG CPYMEM CRBMG CRDBUFR +C DUMPBF GETLENS IDXMSG IGETDATE +C IUPVS01 MESGBC MESGBF MSGWRT +C NMWRD PADMSG PKBS1 RDMSGB +C READS3 RTRCPT STBFDX STNDRD +C UFBMEX WRCMPS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MBAY(*) + + CHARACTER*(*) S01MNEM + + LOGICAL OK4CENT + +C----------------------------------------------------------------------- +C This statement function checks whether its input value contains +C a valid century value. + + OK4CENT(IVAL) = ((IVAL.GE.19).AND.(IVAL.LE.21)) +C----------------------------------------------------------------------- + +C Call subroutine WRDLEN to initialize some important information +C about the local machine, just in case subroutine OPENBF hasn't +C been called yet. + + CALL WRDLEN + +C Handle some simple requests that do not depend on the BUFR +C edition number. + + IF(S01MNEM.EQ.'LENM') THEN + IUPBS01 = IUPB(MBAY,5,24) + RETURN + ENDIF + + LEN0 = 8 + IF(S01MNEM.EQ.'LEN0') THEN + IUPBS01 = LEN0 + RETURN + ENDIF + +C Get the BUFR edition number. + + IBEN = IUPB(MBAY,8,8) + IF(S01MNEM.EQ.'BEN') THEN + IUPBS01 = IBEN + RETURN + ENDIF + +C Use the BUFR edition number to handle any other requests. + + CALL GETS1LOC(S01MNEM,IBEN,ISBYT,IWID,IRET) + IF(IRET.EQ.0) THEN + IUPBS01 = IUPB(MBAY,LEN0+ISBYT,IWID) + IF(S01MNEM.EQ.'CENT') THEN + +C Test whether the returned value was a valid +C century value. + + IF(.NOT.OK4CENT(IUPBS01)) IUPBS01 = -1 + ENDIF + ELSE IF( (S01MNEM.EQ.'YEAR') .AND. (IBEN.LT.4) ) THEN + +C Calculate the 4-digit year. + + IYOC = IUPB(MBAY,21,8) + ICEN = IUPB(MBAY,26,8) + +C Does ICEN contain a valid century value? + + IF(OK4CENT(ICEN)) THEN + +C YES, so use it to calculate the 4-digit year. Note that, +C by international convention, the year 2000 was the 100th +C year of the 20th century, and the year 2001 was the 1st +C year of the 21st century + + IUPBS01 = (ICEN-1)*100 + IYOC + ELSE + +C NO, so use a windowing technique to determine the +C 4-digit year from the year of the century. + + IUPBS01 = I4DY(MOD(IYOC,100)*1000000)/10**6 + ENDIF + ELSE + IUPBS01 = -1 + ENDIF + + RETURN + END diff --git a/src/bufr/iupbs3.f b/src/bufr/iupbs3.f new file mode 100644 index 0000000000..0bf11729e7 --- /dev/null +++ b/src/bufr/iupbs3.f @@ -0,0 +1,85 @@ + FUNCTION IUPBS3(MBAY,S3MNEM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IUPBS3 +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE +C FROM SECTION 3 OF THE BUFR MESSAGE STORED IN ARRAY MBAY. IT WILL +C WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE START +C OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE +C FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE UNPACKED IS SPECIFIED +C VIA THE MNEMONIC S3MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IUPBS3 (MBAY, S3MNEM) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR MESSAGE +C S3MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE +C UNPACKED FROM SECTION 3 OF BUFR MESSAGE: +C 'NSUB' = NUMBER OF DATA SUBSETS +C 'IOBS' = FLAG INDICATING WHETHER THE MESSAGE +C CONTAINS OBSERVED DATA: +C 0 = NO +C 1 = YES +C 'ICMP' = FLAG INDICATING WHETHER THE MESSAGE +C CONTAINS COMPRESSED DATA: +C 0 = NO +C 1 = YES +C +C OUTPUT ARGUMENT LIST: +C IUPBS3 - INTEGER: UNPACKED INTEGER VALUE +C -1 = THE INPUT S3MNEM MNEMONIC WAS INVALID +C +C REMARKS: +C THIS ROUTINE CALLS: GETLENS IUPB +C THIS ROUTINE IS CALLED BY: CKTABA CPDXMM DUMPBF MESGBC +C RDBFDX READERME STNDRD WRITLC +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MBAY(*) + + CHARACTER*(*) S3MNEM + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Call subroutine WRDLEN to initialize some important information +C about the local machine, just in case subroutine OPENBF hasn't +C been called yet. + + CALL WRDLEN + +C Skip to the beginning of Section 3. + + CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) + IPT = LEN0 + LEN1 + LEN2 + +C Unpack the requested value. + + IF(S3MNEM.EQ.'NSUB') THEN + IUPBS3 = IUPB(MBAY,IPT+5,16) + ELSE IF( (S3MNEM.EQ.'IOBS') .OR. (S3MNEM.EQ.'ICMP') ) THEN + IVAL = IUPB(MBAY,IPT+7,8) + IF(S3MNEM.EQ.'IOBS') THEN + IMASK = 128 + ELSE + IMASK = 64 + ENDIF + IUPBS3 = MIN(1,IAND(IVAL,IMASK)) + ELSE + IUPBS3 = -1 + ENDIF + + RETURN + END diff --git a/src/bufr/iupm.f b/src/bufr/iupm.f new file mode 100644 index 0000000000..e6070c225e --- /dev/null +++ b/src/bufr/iupm.f @@ -0,0 +1,74 @@ + FUNCTION IUPM(CBAY,NBITS) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IUPM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD +C CONTAINED WITHIN NBITS BITS OF A CHARACTER STRING CBAY, STARTING +C WITH THE FIRST BIT OF THE FIRST BYTE OF CBAY. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS +C IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: IUPM (CBAY, NBITS) +C INPUT ARGUMENT LIST: +C CBAY - CHARACTER*8: CHARACTER STRING CONTAINING PACKED +C INTEGER +C NBITS - INTEGER: NUMBER OF BITS WITHIN CBAY TO BE UNPACKED +C +C OUTPUT ARGUMENT LIST: +C IUPM - INTEGER: UNPACKED INTEGER WORD +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IREV +C THIS ROUTINE IS CALLED BY: CHRTRNA CRBMG DXMINI ICBFMS +C PKC PKTDD STBFDX UPC +C UPTDD WRDLEN WRDXTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*128 BORT_STR + CHARACTER*8 CBAY + CHARACTER*8 CINT + DIMENSION INT(2) + EQUIVALENCE (CINT,INT) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(NBITS.GT.NBITW) GOTO 900 + CINT = CBAY + INT(1) = IREV(INT(1)) + IUPM = ISHFT(INT(1),NBITS-NBITW) + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: IUPM - NUMBER OF BITS BEING UNPACKED'// + . ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// + . 'MACHINE, NBITW (",I3,")")') NBITS,NBITW + CALL BORT(BORT_STR) + END diff --git a/src/bufr/iupvs01.f b/src/bufr/iupvs01.f new file mode 100644 index 0000000000..eaf4be7b0d --- /dev/null +++ b/src/bufr/iupvs01.f @@ -0,0 +1,82 @@ + FUNCTION IUPVS01(LUNIT,S01MNEM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IUPVS01 +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE +C FROM SECTION 0 OR SECTION 1 OF THE LAST BUFR MESSAGE THAT WAS READ +C FROM LOGICAL UNIT NUMBER LUNIT VIA BUFR ARCHIVE LIBRARY SUBROUTINE +C READMG, READERME OR EQUIVALENT. IT WILL WORK ON ANY MESSAGE ENCODED +C USING BUFR EDITION 2, 3 OR 4, AND THE VALUE TO BE UNPACKED IS +C SPECIFIED VIA THE MNEMONIC S01MNEM (SEE THE DOCBLOCK OF BUFR ARCHIVE +C LIBRARY FUNCTION IUPBS01 FOR A LISTING OF POSSIBLE VALUES FOR +C S01MNEM). NOTE THAT THIS FUNCTION IS SIMILAR TO BUFR ARCHIVE +C LIBRARY FUNCTION IUPBS01 EXCEPT THAT IT OPERATES ON A BUFR MESSAGE +C THAT HAS ALREADY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY +C ARRAYS (VIA A PREVIOUS CALL TO READMG, READERME, ETC.) RATHER THAN +C ON A BUFR MESSAGE PASSED DIRECTLY INTO THE FUNCTION VIA A MEMORY +C ARRAY. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: IUPVS01 (LUNIT, S01MNEM) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE +C UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE +C (SEE DOCBLOCK OF FUNCTION IUPBS01 FOR LISTING OF +C POSSIBLE VALUES) +C +C OUTPUT ARGUMENT LIST: +C IUPVS01 - INTEGER: UNPACKED INTEGER VALUE +C -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IUPBS01 STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + CHARACTER*(*) S01MNEM + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,ILST,IMST) + IF(ILST.EQ.0) GOTO 900 + IF(ILST.GT.0) GOTO 901 + IF(IMST.EQ.0) GOTO 902 + +C UNPACK THE REQUESTED VALUE +C -------------------------- + + IUPVS01 = IUPBS01(MBAY(1,LUN),S01MNEM) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: IUPVS01 - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') + END diff --git a/src/bufr/jstchr.f b/src/bufr/jstchr.f new file mode 100644 index 0000000000..79a448e8a4 --- /dev/null +++ b/src/bufr/jstchr.f @@ -0,0 +1,68 @@ + SUBROUTINE JSTCHR(STR,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: JSTCHR +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE LEFT-JUSTIFIES (I.E. REMOVES ALL LEADING +C BLANKS FROM) A CHARACTER STRING. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY) +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS +C THEN REMOVED BECAUSE IT WAS JUST A DUMMY +C ROUTINE WITH ENTRIES) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2007-01-19 J. ATOR -- RESTRUCTURED AND ADDED IRET ARGUMENT +C +C USAGE: CALL JSTCHR (STR, IRET) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING +C +C OUTPUT ARGUMENT LIST: +C STR - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS +C REMOVED +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = input string was empty (i.e. all blanks) +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: ELEMDX IGETFXY SNTBBE +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(STR.EQ.' ') THEN + IRET = -1 + ELSE + IRET = 0 + LSTR = LEN(STR) + DO WHILE(STR(1:1).EQ.' ') + STR = STR(2:LSTR) + ENDDO + ENDIF + + RETURN + END diff --git a/src/bufr/jstnum.f b/src/bufr/jstnum.f new file mode 100644 index 0000000000..adeaff3834 --- /dev/null +++ b/src/bufr/jstnum.f @@ -0,0 +1,108 @@ + SUBROUTINE JSTNUM(STR,SIGN,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: JSTNUM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE REMOVES ALL LEADING BLANKS FROM A CHARACTER +C STRING CONTAINING AN ENCODED INTEGER VALUE. IF THE VALUE HAS A +C LEADING SIGN CHARACTER ('+' OR '-'), THEN THIS CHARACTER IS ALSO +C REMOVED AND IS RETURNED SEPARATELY WITHIN SIGN. IF THE RESULTANT +C STRING CONTAINS ANY NON-NUMERIC CHARACTERS, THAN AN APPROPRIATE +C CALL IS MADE TO TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY) +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS +C THEN REMOVED BECAUSE IT WAS JUST A DUMMY +C ROUTINE WITH ENTRIES) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY OR UNUSUAL THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL JSTNUM (STR, SIGN, IRET) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE +C +C OUTPUT ARGUMENT LIST: +C STR - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS +C AND SIGN CHARACTER REMOVED +C SIGN - CHARACTER*1: SIGN OF ENCODED INTEGER VALUE: +C '+' = positive value +C '-' = negative value +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = encoded value within STR was not an integer +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT STRNUM +C THIS ROUTINE IS CALLED BY: ELEMDX +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + + CHARACTER*128 ERRSTR + CHARACTER*1 SIGN + + COMMON /QUIET / IPRT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + + IF(STR.EQ.' ') GOTO 900 + + LSTR = LEN(STR) +2 IF(STR(1:1).EQ.' ') THEN + STR = STR(2:LSTR) + GOTO 2 + ENDIF + IF(STR(1:1).EQ.'+') THEN + STR = STR(2:LSTR) + SIGN = '+' + ELSEIF(STR(1:1).EQ.'-') THEN + STR = STR(2:LSTR) + SIGN = '-' + ELSE + SIGN = '+' + ENDIF + + CALL STRNUM(STR,NUM) + IF(NUM.LT.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: JSTNUM: ENCODED VALUE WITHIN RESULTANT '// + . 'CHARACTER STRING (' // STR // ') IS NOT AN INTEGER - '// + . 'RETURN WITH IRET = -1' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IRET = -1 + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT '// + . 'ALLOWED') + END diff --git a/src/bufr/lcmgdf.f b/src/bufr/lcmgdf.f new file mode 100644 index 0000000000..c52470255e --- /dev/null +++ b/src/bufr/lcmgdf.f @@ -0,0 +1,79 @@ + INTEGER FUNCTION LCMGDF(LUNIT,SUBSET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: LCMGDF +C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-07-09 +C +C ABSTRACT: THIS FUNCTION CHECKS WHETHER AT LEAST ONE "LONG" (I.E. +C GREATER THAN 8 BYTES) CHARACTER STRING EXISTS WITHIN THE INTERNAL +C DICTIONARY DEFINITION FOR THE TABLE A MESSAGE TYPE GIVEN BY SUBSET. +C +C PROGRAM HISTORY LOG: +C 2009-07-09 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: LCMGDF (LUNIT, SUBSET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED WITH +C SUBSET DEFINITION +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR MESSAGE TYPE +C +C OUTPUT ARGUMENT LIST: +C LCMGDF - INTEGER: RETURN CODE INDICATING WHETHER SUBSET CONTAINS +C AT LEAST ONE "LONG" CHARACTER STRING IN ITS DEFINITION +C 0 - NO +C 1 - YES +C +C REMARKS: +C THIS ROUTINE CALLS: BORT NEMTBA STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*8 SUBSET + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Get LUN from LUNIT. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF (IL.EQ.0) GOTO 900 + +C Confirm that SUBSET is defined for this logical unit. + + CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD) + +C Check if there's a long character string in the definition. + + NTE = ISC(INOD)-INOD + + DO I = 1, NTE + IF ( (TYP(INOD+I).EQ.'CHR') .AND. (IBT(INOD+I).GT.64) ) THEN + LCMGDF = 1 + RETURN + ENDIF + ENDDO + + LCMGDF = 0 + + RETURN +900 CALL BORT('BUFRLIB: LCMGDF - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN') + END diff --git a/src/bufr/lmsg.f b/src/bufr/lmsg.f new file mode 100644 index 0000000000..4ebccfa544 --- /dev/null +++ b/src/bufr/lmsg.f @@ -0,0 +1,56 @@ + FUNCTION LMSG(SEC0) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: LMSG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: GIVEN A CHARACTER STRING CONTAINING SECTION ZERO FROM A +C BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT OF MACHINE WORDS +C (I.E. INTEGER ARRAY MEMBERS) THAT WILL HOLD THE ENTIRE MESSAGE. +C NOTE THAT THIS COUNT MAY BE GREATER THAN THE MINIMUM NUMBER +C OF WORDS REQUIRED TO HOLD THE MESSAGE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION +C 2005-11-29 J. ATOR -- USE NMWRD +C +C USAGE: LMSG (SEC0) +C INPUT ARGUMENT LIST: +C SEC0 - CHARACTER*8: PACKED BUFR MESSAGE SECTION ZERO +C +C OUTPUT ARGUMENT LIST: +C LMSG - INTEGER: BUFR MESSAGE LENGTH (IN MACHINE WORDS) +C +C REMARKS: +C THIS ROUTINE CALLS: NMWRD +C THIS ROUTINE IS CALLED BY: RDMSGB RDMSGW READERME +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*8 SEC0,CSEC0 + DIMENSION MSEC0(2) + + EQUIVALENCE(MSEC0,CSEC0) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CSEC0 = SEC0 + LMSG = NMWRD(MSEC0) + +C EXIT +C ---- + + RETURN + END diff --git a/src/bufr/lstjpb.f b/src/bufr/lstjpb.f new file mode 100644 index 0000000000..46e30a3e2b --- /dev/null +++ b/src/bufr/lstjpb.f @@ -0,0 +1,110 @@ + FUNCTION LSTJPB(NODE,LUN,JBTYP) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: LSTJPB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION SEARCHES BACKWARDS, BEGINNING FROM A GIVEN +C NODE WITHIN THE JUMP/LINK TABLE, UNTIL IT FINDS THE MOST RECENT +C NODE OF TYPE JBTYP. THE INTERNAL JMPB ARRAY IS USED TO JUMP +C BACKWARDS WITHIN THE JUMP/LINK TABLE, AND THE FUNCTION RETURNS +C THE TABLE INDEX OF THE FOUND NODE. IF THE INPUT NODE ITSELF IS +C OF TYPE JBTYP, THEN THE FUNCTION SIMPLY RETURNS THE INDEX OF THAT +C SAME NODE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION +C +C USAGE: LSTJPB (NODE, LUN, JBTYP) +C INPUT ARGUMENT LIST: +C NODE - INTEGER: JUMP/LINK TABLE INDEX OF ENTRY TO BEGIN +C SEARCHING BACKWARDS FROM +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C JBTYP - CHARACTER*(*): TYPE OF NODE FOR WHICH TO SEARCH +C +C OUTPUT ARGUMENT LIST: +C LSTJPB - INTEGER: INDEX OF FIRST NODE OF TYPE JBTYP FOUND BY +C JUMPING BACKWARDS FROM INPUT NODE +C 0 = NO SUCH NODE FOUND +C +C REMARKS: +C +C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE TABSUB FOR AN +C EXPLANATION OF THE VARIOUS NODE TYPES PRESENT WITHIN AN INTERNAL +C JUMP/LINK TABLE +C +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: GETWIN NEVN NEWWIN NXTWIN +C PARUSR TRYBUMP UFBRW +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*(*) JBTYP + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*3 TYP + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(NODE.LT.INODE(LUN)) GOTO 900 + IF(NODE.GT.ISC(INODE(LUN))) GOTO 901 + + NOD = NODE + +C FIND THIS OR THE PREVIOUS "JBTYP" NODE +C -------------------------------------- + +10 IF(TYP(NOD).NE.JBTYP) THEN + NOD = JMPB(NOD) + IF(NOD.NE.0) GOTO 10 + ENDIF + + LSTJPB = NOD + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT '// + . 'OF BOUNDS, < LOWER BOUNDS (",I7,"); TAG IS ",A10)') + . NODE,INODE(LUN),TAG(NODE) + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT '// + . 'OF BOUNDS, > UPPER BOUNDS (",I7,"); TAG IS ",A10)') + . NODE,ISC(INODE(LUN)),TAG(NODE) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/makebufrlib.sh b/src/bufr/makebufrlib.sh new file mode 100755 index 0000000000..5e8f5fe21c --- /dev/null +++ b/src/bufr/makebufrlib.sh @@ -0,0 +1,289 @@ +#!/bin/sh +############################################################### +# +# PURPOSE: This script uses the make utility to update the BUFR +# archive libraries (libbufr*.a). +# It first reads a list of source files in the library and +# then generates a makefile used to update the archive +# libraries. The make command is then executed for each +# archive library, where the archive library name and +# compilation flags are passed to the makefile through +# environment variables. +# +# REMARKS: Only source files that have been modified since the last +# library update are recompiled and replaced in the object +# archive libraries. The make utility determines this +# from the file modification times. +# +# New source files are also compiled and added to the object +# archive libraries. +# +############################################################### + +#------------------------------------------------------------------------------- +# Determine the OS of the local machine. + +OS=`uname` +if [ $OS = "AIX" ] +then + export FC=ncepxlf + export CC=ncepxlc + CPPFLAGS=" -P" +elif [ $OS = "Linux" ] +then + export FC=ifort + export CC=icc + CPPFLAGS=" -P -traditional-cpp -C" +fi + +#------------------------------------------------------------------------------- +# Determine the byte-ordering scheme used by the local machine. + +cat > endiantest.c << ENDIANTEST + +void fill(p, size) char *p; int size; { + char *ab= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + int i; + + for (i=0; i>(byte_size*(sizeof(j)-i)))&mask); + putchar(c==0 ? '?' : (char)c); + } + printf("\n"); +} + +int cprop() { + /* Properties of type char */ + char c; + int byte_size; + + c=1; byte_size=0; + do { c<<=1; byte_size++; } while(c!=0); + + return byte_size; +} + +main() +{ + int byte_size; + + byte_size= cprop(); + endian(byte_size); +} +ENDIANTEST + +$CC -o endiantest endiantest.c + +if [ `./endiantest | cut -c1` = "A" ] +then + byte_order=BIG_ENDIAN +else + byte_order=LITTLE_ENDIAN +fi +echo +echo "byte_order is $byte_order" +echo + +rm -f endiantest.c endiantest + + +#------------------------------------------------------------------------------- +# Preprocess any Fortran *.F files into corresponding *.f files. + +BNFS="" + +for i in `ls *.F` +do + bn=`basename $i .F` + bnf=${bn}.f + BNFS="$BNFS $bnf" + cpp $CPPFLAGS -D$byte_order $i $bnf +done + +#------------------------------------------------------------------------------- +# Generate a list of object files that correspond to the +# list of Fortran ( *.f ) files in the current directory. + +OBJS="" + +for i in `ls *.f` +do + obj=`basename $i .f` + OBJS="$OBJS ${obj}.o" +done + +#------------------------------------------------------------------------------- +# Generate a list of object files that corresponds to the +# list of C ( .c ) files in the current directory. + +for i in `ls *.c` +do + obj=`basename $i .c` + OBJS="$OBJS ${obj}.o" +done + +#------------------------------------------------------------------------------- +# Remove make file, if it exists. May need a new make file +# with an updated object file list. + +if [ -f make.libbufr ] +then + rm -f make.libbufr +fi + +#------------------------------------------------------------------------------- +# Generate a new make file ( make.libbufr), with the updated object list, +# from this HERE file. + +cat > make.libbufr << EOF +SHELL=/bin/sh + +\$(LIB): \$(LIB)( ${OBJS} ) + +.f.a: + \$(FC) -c \$(FFLAGS) \$< + ar -ruv \$(AFLAGS) \$@ \$*.o + rm -f \$*.o + +.c.a: + \$(CC) -c \$(CFLAGS) \$< + ar -ruv \$(AFLAGS) \$@ \$*.o + rm -f \$*.o +EOF + +#------------------------------------------------------------------------------- +# Generate the bufrlib.prm header file. + +cpp $CPPFLAGS -DBUILD=NORMAL bufrlib.PRM bufrlib.prm + +#------------------------------------------------------------------------------- +# Update libbufr_4_64.a (4-byte REAL, 4-byte INT, 64-bit compilation, +# Fortran optimization level 3, C optimization level 3) + +export LIB="../../libbufr_v10.2.5_4_64.a" +if [ $OS = "AIX" ] +then + export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=4 -qrealsize=4 -qxlf77=leadzero" + export CFLAGS=" -O3 -q64" + export AFLAGS=" -X64" +elif [ $OS = "Linux" ] +then + export FFLAGS=" -O3" + export CFLAGS=" -O3 -DUNDERSCORE" + export AFLAGS=" " +fi +make -f make.libbufr +err_make=$? +[ $err_make -ne 0 ] && exit 99 + +#------------------------------------------------------------------------------- +# Update libbufr_8_64.a (8-byte REAL, 8-byte INT, 64-bit compilation, +# Fortran optimization level 3, C optimization level 3) + +export LIB="../../libbufr_v10.2.5_8_64.a" +if [ $OS = "AIX" ] +then + export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=8 -qrealsize=8 -qxlf77=leadzero" + export CFLAGS=" -O3 -q64 -DF77_INTSIZE_8" + export AFLAGS=" -X64" +elif [ $OS = "Linux" ] +then + export FFLAGS=" -O3 -r8 -i8" + export CFLAGS=" -O3 -DUNDERSCORE -DF77_INTSIZE_8" + export AFLAGS=" " +fi +make -f make.libbufr +err_make=$? +[ $err_make -ne 0 ] && exit 99 + +#------------------------------------------------------------------------------- +# Update libbufr_d_64.a (8-byte REAL, 4-byte INT, 64-bit compilation, +# Fortran optimization level 3, C optimization level 3) + +export LIB="../../libbufr_v10.2.5_d_64.a" +if [ $OS = "AIX" ] +then + export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=4 -qrealsize=8 -qxlf77=leadzero" + export CFLAGS=" -O3 -q64" + export AFLAGS=" -X64" +elif [ $OS = "Linux" ] +then + export FFLAGS=" -O3 -r8" + export CFLAGS=" -O3 -DUNDERSCORE" + export AFLAGS=" " +fi +make -f make.libbufr +err_make=$? +[ $err_make -ne 0 ] && exit 99 + +if [ $OS = "AIX" ] +then + #------------------------------------------------------------------------------- + # Generate a new bufrlib.prm header file. + + /usr/lib/cpp -P -DBUILD=C32BITS bufrlib.PRM bufrlib.prm + + #------------------------------------------------------------------------------- + # Update libbufr_4_32.a (4-byte REAL, 4-byte INT, 32-bit compilation, + # Fortran optimization level 3, C optimization level 3) + + export LIB="../../libbufr_v10.2.5_4_32.a" + export FFLAGS=" -O3 -q32 -qsource -qnosave -qintsize=4 -qrealsize=4 -qxlf77=leadzero" + export CFLAGS=" -O3 -q32" + export AFLAGS=" -X32" + make -f make.libbufr + err_make=$? + [ $err_make -ne 0 ] && exit 99 +fi + +#------------------------------------------------------------------------------- +# Generate a new bufrlib.prm header file. + +cpp $CPPFLAGS -DBUILD=SUPERSIZE bufrlib.PRM bufrlib.prm + +#------------------------------------------------------------------------------- +# Update libbufr_s_64.a (4-byte REAL, 4-byte INT, 64-bit compilation, extra-large array sizes, +# Fortran optimization level 3, C optimization level 3) + +export LIB="../../libbufr_v10.2.5_s_64.a" +if [ $OS = "AIX" ] +then + export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=4 -qrealsize=4 -qxlf77=leadzero" + export CFLAGS=" -O3 -q64" + export AFLAGS=" -X64" +elif [ $OS = "Linux" ] +then + export FFLAGS=" -O3 -mcmodel=medium -shared-intel" + export CFLAGS=" -O3 -mcmodel=medium -shared-intel -DUNDERSCORE" + export AFLAGS=" " +fi +make -f make.libbufr +err_make=$? +[ $err_make -ne 0 ] && exit 99 + +#------------------------------------------------------------------------------- + +# Clean up and check how we did. + +rm -f make.libbufr bufrlib.prm $BNFS + +if [ -s ../../libbufr_v10.2.5_s_64.a ] ; then + echo + echo "SUCCESS: The script updated all BUFR archive libraries" + echo + [ $OS = "AIX" ] && rm *.lst +else + echo + echo "FAILURE: The script did NOT update all BUFR archive libraries" + echo +fi diff --git a/src/bufr/makestab.f b/src/bufr/makestab.f new file mode 100644 index 0000000000..1b298a3b3d --- /dev/null +++ b/src/bufr/makestab.f @@ -0,0 +1,400 @@ + SUBROUTINE MAKESTAB + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MAKESTAB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE +C WITHIN COMMON BLOCK /TABLES/, USING THE INFORMATION WITHIN THE +C INTERNAL BUFR TABLE ARRAYS (WITHIN COMMON BLOCK /TABABD/) FOR ALL OF +C THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO +C THE BUFR ARCHIVE LIBRARY SOFTWARE. NOTE THAT THE ENTIRE JUMP/LINK +C TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF +C SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS +C ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS +C SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN +C PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET +C BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G. +C THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE +C VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY; NOW ALLOWS FOR THE +C POSSIBILITY THAT A CONNECTED FILE MAY NOT +C CONTAIN ANY DICTIONARY TABLE INFO (E.G., +C AN EMPTY FILE), SUBSEQUENT CONNECTED FILES +C WHICH ARE NOT EMPTY WILL NO LONGER GET +C TRIPPED UP BY THIS (THIS AVOIDS THE NEED +C FOR AN APPLICATION PROGRAM TO DISCONNECT +C ANY EMPTY FILES VIA A CALL TO CLOSBF) +C 2009-03-18 J. WOOLLEN -- ADDED LOGIC TO RESPOND TO THE CASES WHERE +C AN INPUT FILE'S TABLES CHANGE IN MIDSTREAM. +C THE NEW LOGIC MOSTLY ADDRESSES CASES WHERE +C OTHER FILES ARE CONNECTED TO THE TABLES OF +C THE FILE WHOSE TABLES HAVE CHANGED. +C 2009-06-25 J. ATOR -- TWEAK WOOLLEN LOGIC TO HANDLE SPECIAL CASE +C WHERE TABLE WAS RE-READ FOR A PARTICULAR +C LOGICAL UNIT BUT IS STILL THE SAME ACTUAL +C TABLE AS BEFORE AND IS STILL SHARING THAT +C TABLE WITH A DIFFERENT LOGICAL UNIT +C 2009-11-17 J. ATOR -- ADDED CHECK TO PREVENT WRITING OUT OF TABLE +C INFORMATION WHEN A TABLE HAS BEEN RE-READ +C WITHIN A SHARED LOGICAL UNIT BUT HASN'T +C REALLY CHANGED +C +C USAGE: CALL MAKESTAB +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CHEKSTAB CLOSMG CPBFDX +C ERRWRT ICMPDX ISHRDX STRCLN +C TABSUB WRDXTB +C THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM RDUSDX READDX +C READERME READS3 +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET/ IPRT + COMMON /STBFR/ IOLUN(NFILES),IOMSG(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), + . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV + COMMON /LUSHR/ LUS(NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*10 TAG + CHARACTER*8 NEMO,TAGNRV + CHARACTER*3 TYP + LOGICAL EXPAND,XTAB(NFILES) + REAL*8 VAL + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C RESET POINTER TABLE AND STRING CACHE +C ------------------------------------ + + NTAB = 0 + NNRV = 0 + CALL STRCLN + +C FIGURE OUT WHICH UNITS SHARE TABLES +C ----------------------------------- + +C The LUS array is static between calls to this subroutine, and it +C keeps track of which logical units share dictionary table +C information: +C if LUS(I) = 0, then IOLUN(I) does not share dictionary table +C information with any other logical unit +C if LUS(I) > 0, then IOLUN(I) shares dictionary table +C information with logical unit IOLUN(LUS(I)) +C if LUS(I) < 0, then IOLUN(I) does not now, but at one point in +C the past, shared dictionary table information +C with logical unit IOLUN(ABS(LUS(I))) + +C The XTAB array is non-static and is recomputed within the below +C loop during each call to this subroutine: +C if XTAB(I) = .TRUE., then the dictionary table information +C has changed for IOLUN(I) since the last +C call to this subroutine +C if XTAB(I) = .FALSE., then the dictionary table information +C has not changed for IOLUN(I) since the +C last call to this subroutine + + DO LUN=1,NFILES + XTAB(LUN) = .FALSE. + IF(IOLUN(LUN).EQ.0) THEN + +C Logical unit IOLUN(LUN) is not defined to the BUFRLIB. + + LUS(LUN) = 0 + ELSE IF(MTAB(1,LUN).EQ.0) THEN + +C New dictionary table information has been read for logical +C unit IOLUN(LUN) since the last call to this subroutine. + + XTAB(LUN) = .TRUE. + IF(LUS(LUN).NE.0) THEN + IF(IOLUN(ABS(LUS(LUN))).EQ.0) THEN + LUS(LUN) = 0 + ELSE IF(LUS(LUN).GT.0) THEN + +C IOLUN(LUN) was sharing table information with logical +C unit IOLUN(LUS(LUN)), so check whether the table +C information has really changed. If not, then IOLUN(LUN) +C just re-read a copy of the exact same table information +C as before, and therefore it can continue to share with +C logical unit IOLUN(LUS(LUN)). + + IF(ICMPDX(LUS(LUN),LUN).EQ.1) THEN + XTAB(LUN) = .FALSE. + CALL CPBFDX(LUS(LUN),LUN) + ELSE + LUS(LUN) = (-1)*LUS(LUN) + ENDIF + ELSE IF(ICMPDX(ABS(LUS(LUN)),LUN).EQ.1) THEN + +C IOLUN(LUN) was not sharing table information with logical +C unit IOLUN(LUS(LUN)), but it did at one point in the past +C and now once again has the same table information as that +C logical unit. Since the two units shared table +C information at one point in the past, allow them to do +C so again. + + XTAB(LUN) = .FALSE. + LUS(LUN) = ABS(LUS(LUN)) + CALL CPBFDX(LUS(LUN),LUN) + ENDIF + ENDIF + ELSE IF(LUS(LUN).GT.0) THEN + +C Logical unit IOLUN(LUN) is sharing table information with +C logical unit IOLUN(LUS(LUN)), so make sure that the latter +C unit is still defined to the BUFRLIB. + + IF(IOLUN(LUS(LUN)).EQ.0) THEN + LUS(LUN) = 0 + ELSE IF( XTAB(LUS(LUN)) .AND. + + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN + +C The table information for logical unit IOLUN(LUS(LUN)) +C just changed (in midstream). If IOLUN(LUN) is an output +C file, then we will have to update it with the new table +C information later on in this subroutine. Otherwise, +C IOLUN(LUN) is an input file and is no longer sharing +C tables with IOLUN(LUS(LUN)). + + IF(IOLUN(LUN).LT.0) LUS(LUN) = (-1)*LUS(LUN) + ENDIF + ELSE + +C Determine whether logical unit IOLUN(LUN) is sharing table +C information with any other logical units. + + LUM = 1 + DO WHILE ((LUM.LT.LUN).AND.(LUS(LUN).EQ.0)) + IF(ISHRDX(LUM,LUN).EQ.1) THEN + LUS(LUN) = LUM + ELSE + LUM = LUM+1 + ENDIF + ENDDO + ENDIF + ENDDO + +C INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS +C ----------------------------------------------------------- + + DO LUN=1,NFILES + + IF(IOLUN(LUN).NE.0 .AND. NTBA(LUN).GT.0) THEN + +C Reset any existing inventory pointers. + + IF(IOMSG(LUN).NE.0) THEN + IF(LUS(LUN).EQ.0) THEN + INC = (NTAB+1)-MTAB(1,LUN) + ELSE + INC = MTAB(1,LUS(LUN))-MTAB(1,LUN) + ENDIF + DO N=1,NVAL(LUN) + INV(N,LUN) = INV(N,LUN)+INC + ENDDO + ENDIF + + IF(LUS(LUN).LE.0) THEN + +C The dictionary table information corresponding to logical +C unit IOLUN(LUN) has not yet been written into the internal +C jump/link table, so add it in now. + + CALL CHEKSTAB(LUN) + DO ITBA=1,NTBA(LUN) + INOD = NTAB+1 + NEMO = TABA(ITBA,LUN)(4:11) + CALL TABSUB(LUN,NEMO) + MTAB(ITBA,LUN) = INOD + ISC(INOD) = NTAB + ENDDO + ELSE IF( XTAB(LUS(LUN)) .AND. + + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN + +C Logical unit IOLUN(LUN) is an output file that is sharing +C table information with logical unit IOLUN(LUS(LUN)) whose +C table just changed (in midstream). Flush any existing data +C messages from IOLUN(LUN), then update the table information +C for this logical unit with the corresponding new table +C information from IOLUN(LUS(LUN)), then update IOLUN(LUN) +C itself with a copy of the new table information. + + LUNIT = ABS(IOLUN(LUN)) + IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT) + CALL CPBFDX(LUS(LUN),LUN) + LUNDX = ABS(IOLUN(LUS(LUN))) + CALL WRDXTB(LUNDX,LUNIT) + ENDIF + + ENDIF + + ENDDO + +C STORE TYPES AND INITIAL VALUES AND COUNTS +C ----------------------------------------- + + DO NODE=1,NTAB + IF(TYP(NODE).EQ.'SUB') THEN + VALI(NODE) = 0 + KNTI(NODE) = 1 + ITP (NODE) = 0 + ELSEIF(TYP(NODE).EQ.'SEQ') THEN + VALI(NODE) = 0 + KNTI(NODE) = 1 + ITP (NODE) = 0 + ELSEIF(TYP(NODE).EQ.'RPC') THEN + VALI(NODE) = 0 + KNTI(NODE) = 0 + ITP (NODE) = 0 + ELSEIF(TYP(NODE).EQ.'RPS') THEN + VALI(NODE) = 0 + KNTI(NODE) = 0 + ITP (NODE) = 0 + ELSEIF(TYP(NODE).EQ.'REP') THEN + VALI(NODE) = BMISS + KNTI(NODE) = IRF(NODE) + ITP (NODE) = 0 + ELSEIF(TYP(NODE).EQ.'DRS') THEN + VALI(NODE) = 0 + KNTI(NODE) = 1 + ITP (NODE) = 1 + ELSEIF(TYP(NODE).EQ.'DRP') THEN + VALI(NODE) = 0 + KNTI(NODE) = 1 + ITP (NODE) = 1 + ELSEIF(TYP(NODE).EQ.'DRB') THEN + VALI(NODE) = 0 + KNTI(NODE) = 0 + ITP (NODE) = 1 + ELSEIF(TYP(NODE).EQ.'NUM') THEN + VALI(NODE) = BMISS + KNTI(NODE) = 1 + ITP (NODE) = 2 + ELSEIF(TYP(NODE).EQ.'CHR') THEN + VALI(NODE) = BMISS + KNTI(NODE) = 1 + ITP (NODE) = 3 + ELSE + GOTO 901 + ENDIF + ENDDO + +C SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES +C ---------------------------------------------------------------- + + NEWN = 0 + + DO N=1,NTAB + ISEQ(N,1) = 0 + ISEQ(N,2) = 0 + EXPAND = TYP(N).EQ.'SUB' .OR. TYP(N).EQ.'DRP' .OR. TYP(N).EQ.'DRS' + . .OR. TYP(N).EQ.'REP' .OR. TYP(N).EQ.'DRB' + IF(EXPAND) THEN + ISEQ(N,1) = NEWN+1 + NODA = N + NODE = N+1 + DO K=1,MAXJL + KNT(K) = 0 + ENDDO + IF(TYP(NODA).EQ.'REP') KNT(NODE) = KNTI(NODA) + IF(TYP(NODA).NE.'REP') KNT(NODE) = 1 + +1 NEWN = NEWN+1 + IF(NEWN.GT.MAXJL) GOTO 902 + JSEQ(NEWN) = NODE + KNT(NODE) = MAX(KNTI(NODE),KNT(NODE)) +2 IF(JUMP(NODE)*KNT(NODE).GT.0) THEN + NODE = JUMP(NODE) + GOTO 1 + ELSE IF(LINK(NODE).GT.0) THEN + NODE = LINK(NODE) + GOTO 1 + ELSE + NODE = JMPB(NODE) + IF(NODE.EQ.NODA) GOTO 3 + IF(NODE.EQ.0 ) GOTO 903 + KNT(NODE) = MAX(KNT(NODE)-1,0) + GOTO 2 + ENDIF +3 ISEQ(N,2) = NEWN + ENDIF + ENDDO + +C PRINT THE SEQUENCE TABLES +C ------------------------ + + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + DO I=1,NTAB + WRITE ( UNIT=ERRSTR, FMT='(A,I5,2X,A10,A5,6I8)' ) + . 'BUFRLIB: MAKESTAB ', I, TAG(I), TYP(I), JMPB(I), JUMP(I), + . LINK(I), IBT(I), IRF(I), ISC(I) + CALL ERRWRT(ERRSTR) + ENDDO + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '// + . 'DUPLICATED IN SUBSET: ",A)') NEMO,TAG(N1) + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)')TYP(NODE) + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'// + . ' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') MAXJL + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '// + . 'CIRCULATE (TAG IS ",A,")")') TAG(N) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/maxout.f b/src/bufr/maxout.f new file mode 100644 index 0000000000..90eda54681 --- /dev/null +++ b/src/bufr/maxout.f @@ -0,0 +1,88 @@ + SUBROUTINE MAXOUT(MAXO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MAXOUT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE ALLOWS AN APPLICATION PROGRAM TO SET THE +C RECORD LENGTH OF NEWLY CREATED BUFR MESSAGES, OVERRIDING THE VALUE +C SET IN BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI. THIS MUST BE CALLED +C AFTER THE INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF +C SINCE OPENBF CALLS BFRINI. THE RECORD LENGTH WILL REMAIN MAX0 +C UNLESS THIS SUBROUTINE IS CALLED AGAIN WITH A NEW MAX0. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO FOR +C INFORMATIONAL PURPOSES +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2006-04-14 J. ATOR -- ADDED MAX0=0 OPTION AND OVERFLOW CHECK +C 2009-03-23 D. KEYSER -- NO LONGER PRINTS THE RECORD LENGTH CHANGE +C DIAGNOSTIC IF THE REQUESTED RECORD LENGTH +C PASSED IN AS MAX0 IS ACTUALLY THE SAME AS +C THE PREVIOUS RECORD LENGTH +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL MAXOUT (MAXO) +C INPUT ARGUMENT LIST: +C MAXO - INTEGER: DESIRED MESSAGE LENGTH (BYTES): +C 0 = SET RECORD LENGTH TO THE MAXIMUM ALLOWABLE +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + COMMON /QUIET / IPRT + + CHARACTER*128 ERRSTR + CHARACTER*56 DXSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF((MAXO.EQ.0).OR.(MAXO.GT.MXMSGL)) THEN + NEWSIZ = MXMSGL + ELSE + NEWSIZ = MAXO + ENDIF + + IF(IPRT.GE.0) THEN + IF(MAXBYT.NE.NEWSIZ) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A,I7)' ) + . 'BUFRLIB: MAXOUT - THE RECORD LENGTH OF ALL BUFR MESSAGES ', + . 'CREATED FROM THIS POINT ON IS BEING CHANGED FROM ', MAXBYT, + . ' TO ', NEWSIZ + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ENDIF + + MAXBYT = NEWSIZ + MAXCMB = NEWSIZ + MAXDX = NEWSIZ + + RETURN + END diff --git a/src/bufr/mesgbc.f b/src/bufr/mesgbc.f new file mode 100644 index 0000000000..9602acd96b --- /dev/null +++ b/src/bufr/mesgbc.f @@ -0,0 +1,192 @@ + SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MESGBC +C PRGMMR: KEYSER ORG: NP22 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH +C THE MESSAGE TYPE FROM SECTION 1 AND A MESSAGE COMPRESSION INDICATOR +C UNPACKED FROM SECTION 3. IT OBTAINS THE BUFR MESSAGE VIA TWO +C DIFFERENT METHODS, BASED UPON THE SIGN OF LUNIN. +C IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE READS AND EXAMINES +C SECTION 1 OF MESSAGES IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE +C FIRST MESSAGE THAT ACTUALLY CONTAINS REPORT DATA {I.E., BEYOND THE +C BUFR TABLE (DICTIONARY) MESSAGES AT THE TOP AND, FOR DUMP FILES, +C BEYOND THE TWO DUMMY MESSAGES CONTAINING THE CENTER TIME AND THE +C DUMP TIME}. IT THEN RETURNS THE MESSAGE TYPE AND COMPRESSION +C INDICATOR FOR THIS FIRST DATA MESSAGE. IN THIS CASE, THE BUFR FILE +C SHOULD NOT BE OPENED VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF +C PRIOR TO CALLING THIS SUBROUTINE. HOWEVER, THE BUFR FILE MUST BE +C CONNECTED TO UNIT ABS(LUNIN). WHEN USED THIS WAY, THIS SUBROUTINE +C IS IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE MESGBF EXCEPT MESGBF +C DOES NOT RETURN ANY INFORMATION ABOUT COMPRESSION AND MESGBF READS +C UNTIL IT FINDS THE FIRST NON-DICTIONARY MESSAGE REGARDLESS OF +C WHETHER OR NOT IT CONTAINS ANY REPORTS (I.E., IT WOULD STOP AT THE +C DUMMY MESSAGE CONTAINING THE CENTER TIME FOR DUMP FILES). +C THE SECOND METHOD IN WHICH THIS SUBROUTINE CAN BE USED OCCURS +C WHEN LUNIN IS PASSED IN WITH A VALUE LESS THAN ZERO. IN THIS CASE, +C IT SIMPLY RETURNS THE MESSAGE TYPE AND COMPRESSION INDICATOR FOR THE +C BUFR MESSAGE CURRENTLY STORED IN THE INTERNAL MESSAGE BUFFER (ARRAY +C MBAY IN COMMON BLOCK /BITBUF/). IN THIS CASE, THE BUFR FILE +C CONNECTED TO ABS(LUNIN) MUST HAVE BEEN PREVIOUSLY OPENED FOR INPUT +C OPERATIONS BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE BUFR +C MESSAGE MUST HAVE BEEN READ INTO MEMORY BY BUFR ARCHIVE LIBRARY +C ROUTINE READMG OR EQUIVALENT. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 D. KEYSER -- ORIGINAL AUTHOR +C 2004-06-29 D. KEYSER -- ADDED NEW OPTION TO RETURN MESSAGE TYPE AND +C COMPRESSION INDICATOR FOR BUFR MESSAGE +C CURRENTLY STORED IN MEMORY (TRIGGERED BY +C INPUT ARGUMENT LUNIN LESS THAN ZERO) +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE IUPBS01, GETLENS AND RDMSGW +C 2009-03-23 J. ATOR -- USE IUPBS3 AND IDXMSG +C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE +C ADD OPENBF AND CLOSBF FOR THE CASE +C WHEN LUNIN GT 0 +C +C USAGE: CALL MESGBC (LUNIN, MESGTYP, ICOMP) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE +C - IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE +C READS THROUGH ALL BUFR MESSAGES FROM BEGINNING OF +C FILE UNTIL IT FINDS THE FIRST MESSAGE CONTAINING +C REPORT DATA +C - IF LUNIN IS LESS THAN ZERO, THIS SUBROUTINE +C OPERATES ON THE BUFR MESSAGE CURRENTLY STORED IN +C MEMORY +C +C OUTPUT ARGUMENT LIST: +C MESGTYP - INTEGER: BUFR MESSAGE TYPE FOR EITHER THE FIRST +C MESSAGE IN FILE CONTAINING REPORT DATA (IF LUNIN > 0), +C OR FOR THE MESSAGE CURRENTLY IN MEMORY (IF LUNIN < 0) +C -256 = for LUNIN > 0 case only: no messages read +C or error reading file +C < 0 = for LUNIN > 0 case only: none of the +C messages read contain reports; this is the +C negative of the message type the last +C message read (i.e., -11 indicates the BUFR +C file contains only BUFR table messages) +C ICOMP - INTEGER: BUFR MESSAGE COMPRESSION SWITCH: +C -3 = for LUNIN > 0 case only: BUFR file does not +C exist +C -2 = for LUNIN > 0 case only: BUFR file does not +C contain any report messages +C -1 = for LUNIN > 0 case only: cannot determine +C if first BUFR message containing report +C data is compressed due to error reading +C file +C 0 = BUFR message (either first containing +C report data if LUNIN > 0, or that currently +C in memory if LUNIN < 0) is NOT compressed +C 1 = BUFR message (either first containing +C report data if LUNIN > 0, or that currently +C in memory if LUNIN < 0) IS compressed +C +C INPUT FILES: +C UNIT ABS(LUNIN) - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: CLOSBF IDXMSG IUPBS01 IUPBS3 +C OPENBF RDMSGW STATUS +C THIS ROUTINE IS CALLED BY: COPYSB UFBTAB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + DIMENSION MSGS(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LUNIT = ABS(LUNIN) + +C DETERMINE METHOD OF OPERATION BASED ON SIGN OF LUNIN +C LUNIN > 0 - REWIND AND LOOK FOR FIRST DATA MESSAGE (ITYPE = 0) +C LUNIN < 0 - LOOK AT MESSAGE CURRENLY IN MEMORY (ITYPE = 1) +C --------------------------------------------------------------- + + ITYPE = 0 + IF(LUNIT.NE.LUNIN) ITYPE = 1 + + ICOMP = -1 + MESGTYP = -256 + + IF(ITYPE.EQ.0) THEN + + IREC = 0 + +C CALL OPENBF SINCE FILE IS NOT OPEN TO THE C INTERFACE YET +C --------------------------------------------------------- + + CALL OPENBF(LUNIT,'INX',LUNIT) + +C READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND +C ----------------------------------------------------------------- + +1 CALL RDMSGW(LUNIT,MSGS,IER) + IF(IER.EQ.-1) GOTO 900 + IF(IER.EQ.-2) GOTO 901 + + IREC = IREC + 1 + + MESGTYP = IUPBS01(MSGS,'MTYP') + + IF((IDXMSG(MSGS).EQ.1).OR.(IUPBS3(MSGS,'NSUB').EQ.0)) GOTO 1 + + ELSE + +C RETURN MESSAGE TYPE FOR MESSAGE CURRENTLY STORED IN MEMORY +C ---------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + + DO I=1,12 + MSGS(I) = MBAY(I,LUN) + ENDDO + + MESGTYP = IUPBS01(MSGS,'MTYP') + + END IF + +C SET THE COMPRESSION SWITCH +C -------------------------- + + ICOMP = IUPBS3(MSGS,'ICMP') + + GOTO 100 + +C CAN ONLY GET TO STATEMENTS 900 OR 901 WHEN ITYPE = 0 +C ---------------------------------------------------- + +900 IF(IREC.EQ.0) THEN + MESGTYP = -256 + ICOMP = -3 + ELSE + IF(MESGTYP.GE.0) MESGTYP = -MESGTYP + ICOMP = -2 + ENDIF + GOTO 100 + +901 MESGTYP = -256 + ICOMP = -1 + +C EXIT +C ---- + +100 IF(ITYPE.EQ.0) CALL CLOSBF(LUNIT) + RETURN + END diff --git a/src/bufr/mesgbf.f b/src/bufr/mesgbf.f new file mode 100644 index 0000000000..0834c9ab19 --- /dev/null +++ b/src/bufr/mesgbf.f @@ -0,0 +1,98 @@ + SUBROUTINE MESGBF(LUNIT,MESGTYP) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MESGBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS AND EXAMINES SECTION 1 OF MESSAGES +C IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE FIRST MESSAGE THAT +C IS NOT A BUFR TABLE (DICTIONARY) MESSAGE. IT THEN RETURNS THE +C MESSAGE TYPE FOR THIS FIRST NON-DICTIONARY MESSAGE. THE BUFR FILE +C SHOULD NOT BE OPEN VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF PRIOR +C TO CALLING THIS SUBROUTINE; HOWEVER, THE BUFR FILE MUST BE CONNECTED +C TO UNIT LUNIT. THIS SUBROUTINE IS IDENTICAL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE MESGBC EXCEPT THAT MESGBC RETURNS THE MESSAGE TYPE FOR +C THE FIRST NON-DICTIONARY MESSAGE THAT ACTUALLY CONTAINS REPORT DATA +C (WHEREAS MESGBF WOULD RETURN THE REPORT TYPE OF A DUMMY MESSAGE +C CONTAINING THE CENTER TIME FOR DUMP FILES), AND MESGBC ALSO +C INDICATES WHETHER OR NOT THE FIRST REPORT DATA MESSAGE IS BUFR +C COMPRESSED. MESGBC ALSO HAS AN OPTION TO OPERATE ON THE CURRENT +C MESSAGE STORED IN MEMORY, WHICH IS SOMETHING THAT MESGBF CANNOT DO. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE IUPBS01 AND RDMSGW +C 2009-03-23 J. ATOR -- USE IDXMSG +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE +C THE C FILE WITHOUT CLOSING THE FORTRAN FILE +C 2013-01-25 J. WOOLLEN -- ALWAYS CALL CLOSBF BEFORE EXITING +C +C USAGE: CALL MESGBF (LUNIT, MESGTYP) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C MESGTYP - INTEGER: BUFR MESSAGE TYPE FOR FIRST NON-DICTIONARY +C MESSAGE +C -1 = no messages read or error +C 11 = if only BUFR table messages in BUFR file +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: CLOSBF IDXMSG IUPBS01 OPENBF +C RDMSGW +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + DIMENSION MBAY(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + MESGTYP = -1 + +C SINCE OPENBF HAS NOT YET BEEN CALLED, CALL IT +C --------------------------------------------- + + CALL OPENBF(LUNIT,'INX',LUNIT) + +C READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND +C ----------------------------------------------------------------- + +1 CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.EQ.0) THEN + MESGTYP = IUPBS01(MBAY,'MTYP') + IF(IDXMSG(MBAY).EQ.1) GOTO 1 + ENDIF + +C CLOSE THE FILE +C -------------- + + CALL CLOSBF(LUNIT) + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/minimg.f b/src/bufr/minimg.f new file mode 100644 index 0000000000..6d60fa0c3c --- /dev/null +++ b/src/bufr/minimg.f @@ -0,0 +1,79 @@ + SUBROUTINE MINIMG(LUNIT,MINI) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MINIMG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PACKS THE VALUE OF MINI INTO SECTION 1 OF +C THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT, +C SO THAT THIS VALUE THEN BECOMES THE MINUTES COMPONENT OF THE +C SECTION 1 DATE-TIME FOR THE MESSAGE. THIS SUBROUTINE SHOULD ONLY +C BE CALLED WHEN LOGICAL UNIT LUNIT HAS BEEN OPENED FOR OUTPUT +C OPERATIONS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN MSGINI) +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" (IN PARENT ROUTINE MSGINI) +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) (IN PARENT +C ROUTINE MSGINI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES (IN PARENT ROUTINE +C MSGINI) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE PKBS1 +C +C USAGE: CALL MINIMG (LUNIT, MINI) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C MINI - INTEGER: MINUTES VALUE TO BE PACKED +C +C REMARKS: +C THIS ROUTINE CALLS: BORT PKBS1 STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + + CALL PKBS1(MINI,MBAY(1,LUN),'MINU') + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: MINIMG - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') + END diff --git a/src/bufr/mrginv.f b/src/bufr/mrginv.f new file mode 100644 index 0000000000..7ab6b662d8 --- /dev/null +++ b/src/bufr/mrginv.f @@ -0,0 +1,66 @@ + SUBROUTINE MRGINV + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MRGINV +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 +C +C ABSTRACT: THIS SUBROUTINE PRINTS A SUMMARY OF MERGE ACTIVITY. +C +C PROGRAM HISTORY LOG: +C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN INVMRG) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL MRGINV +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT + COMMON /QUIET / IPRT + + CHARACTER*128 ERRSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') + CALL ERRWRT('---------------------------------------------------') + CALL ERRWRT('INVENTORY FROM MERGE PROCESS IN SUBROUTINE INVMRG:') + CALL ERRWRT('---------------------------------------------------') + WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) + . 'NUMBER OF DRB EXPANSIONS = ', NRPL + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) + . 'NUMBER OF MERGES = ', NMRG + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) + . 'NUMBER THAT ARE AMBIGUOUS = ', NAMB + CALL ERRWRT(ERRSTR) + CALL ERRWRT('---------------------------------------------------') + WRITE ( UNIT=ERRSTR, FMT='(A,I9)' ) + . 'TOTAL NUMBER OF VISITS = ', NTOT + CALL ERRWRT(ERRSTR) + CALL ERRWRT('---------------------------------------------------') + CALL ERRWRT('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + RETURN + END diff --git a/src/bufr/msgfull.f b/src/bufr/msgfull.f new file mode 100644 index 0000000000..4748fe4c3b --- /dev/null +++ b/src/bufr/msgfull.f @@ -0,0 +1,79 @@ + LOGICAL FUNCTION MSGFULL(MSIZ,ITOADD,MXSIZ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MSGFULL +C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS LOGICAL FUNCTION DETERMINES WHETHER THE CURRENT SUBSET +C (OF LENGTH ITOADD BYTES) WILL FIT WITHIN THE CURRENT BUFR MESSAGE. +C A FINITE AMOUNT OF "WIGGLE ROOM" IS ALLOWED FOR AS SHOWN BELOW. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: MSGFULL (MSIZ,ITOADD,MXSIZ) +C INPUT ARGUMENT LIST: +C MSIZ - INTEGER: SIZE OF CURRENT MESSAGE (IN BYTES) +C ITOADD - INTEGER: SIZE OF SUBSET TO BE ADDED (IN BYTES) +C MXSIZ - INTEGER: MAXIMUM SIZE OF A BUFR MESSAGE +C +C OUTPUT ARGUMENT LIST: +C MSGFULL - LOGICAL: FALSE IF SUBSET WILL FIT; TRUE OTHERWISE +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD WRCMPS WRDXTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGSTD/ CSMF + COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT + + CHARACTER*1 CSMF + CHARACTER*1 CTRT + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C Allow for at least 11 additional bytes of "wiggle room" in the +C message, because subroutine MSGWRT may do any or all of the +C following: +C 3 bytes may be added by a call to subroutine CNVED4 +C + 1 byte (at most) of padding may be added to Section 4 +C + 7 bytes (at most) of padding may be added up to the next +C word boundary after Section 5 +C ---- +C 11 + + IWGBYT = 11 + +C But subroutine MSGWRT may also do any of all of the following: + +C 6 bytes may be added by a call to subroutine ATRCPT + + IF(CTRT.EQ.'Y') IWGBYT = IWGBYT + 6 + +C (MAXNC*2) bytes (at most) may be added by a call to +C subroutine STNDRD + + IF(CSMF.EQ.'Y') IWGBYT = IWGBYT + (MAXNC*2) + +C Determine whether the subset will fit. + + IF ( ( MSIZ + ITOADD + IWGBYT ) .GT. MXSIZ ) THEN + MSGFULL = .TRUE. + ELSE + MSGFULL = .FALSE. + ENDIF + + RETURN + END diff --git a/src/bufr/msgini.f b/src/bufr/msgini.f new file mode 100644 index 0000000000..2adc9ae57d --- /dev/null +++ b/src/bufr/msgini.f @@ -0,0 +1,214 @@ + SUBROUTINE MSGINI(LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MSGINI +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A +C NEW BUFR MESSAGE FOR OUTPUT. ARRAYS ARE FILLED IN COMMON BLOCKS +C /MSGPTR/, /MSGCWD/ AND /BITBUF/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-12-11 J. WOOLLEN -- MODIFIED TO ALLOW INCLUSION OF MINUTES IN +C WRITING THE MESSAGE DATE INTO A BUFR +C MESSAGE +C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION +C WRITTEN IN SECTION 0 FROM 2 TO 3 +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT MINIMG (IT BECAME A +C SEPARATE ROUTINE IN THE BUFRLIB TO +C INCREASE PORTABILITY TO OTHER PLATFORMS) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 +C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13 +C 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO INITIALIZE LUNCPY +C +C USAGE: CALL MSGINI (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: BORT NEMTAB NEMTBA PKB +C PKC +C THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD OPENMB OPENMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 + COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /UFBCPL/ LUNCPY(NFILES) + + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*8 SUBTAG + CHARACTER*4 BUFR,SEVN + CHARACTER*3 TYP + CHARACTER*1 TAB + + DATA BUFR/'BUFR'/ + DATA SEVN/'7777'/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE +C --------------------------------------------------- + + SUBTAG = TAG(INODE(LUN)) +c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD + CALL NEMTBA(LUN,SUBTAG,MTYP,MSBT,INOD) + IF(INODE(LUN).NE.INOD) GOTO 900 + CALL NEMTAB(LUN,SUBTAG,ISUB,TAB,IRET) + IF(IRET.EQ.0) GOTO 901 + +C DATE CAN BE YYMMDDHH OR YYYYMMDDHH +C ---------------------------------- + + MCEN = MOD(IDATE(LUN)/10**8,100)+1 + MEAR = MOD(IDATE(LUN)/10**6,100) + MMON = MOD(IDATE(LUN)/10**4,100) + MDAY = MOD(IDATE(LUN)/10**2,100) + MOUR = MOD(IDATE(LUN) ,100) + MMIN = 0 + +c .... DK: Can this happen?? (investigate) + IF(MCEN.EQ.1) GOTO 902 + + IF(MEAR.EQ.0) MCEN = MCEN-1 + IF(MEAR.EQ.0) MEAR = 100 + +C INITIALIZE THE MESSAGE +C ---------------------- + + MBIT = 0 + NBY0 = 8 + NBY1 = 18 + NBY2 = 0 + NBY3 = 20 + NBY4 = 4 + NBY5 = 4 + NBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5 + +C SECTION 0 +C --------- + + CALL PKC(BUFR , 4 , MBAY(1,LUN),MBIT) + CALL PKB(NBYT , 24 , MBAY(1,LUN),MBIT) + CALL PKB( 3 , 8 , MBAY(1,LUN),MBIT) + +C SECTION 1 +C --------- + + CALL PKB(NBY1 , 24 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 3 , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 7 , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MTYP , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MSBT , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 13 , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MEAR , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MMON , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MDAY , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MOUR , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MMIN , 8 , MBAY(1,LUN),MBIT) + CALL PKB(MCEN , 8 , MBAY(1,LUN),MBIT) + +C SECTION 3 +C --------- + + CALL PKB(NBY3 , 24 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 16 , MBAY(1,LUN),MBIT) + CALL PKB(2**7 , 8 , MBAY(1,LUN),MBIT) + CALL PKB(IBCT , 16 , MBAY(1,LUN),MBIT) + CALL PKB(ISUB , 16 , MBAY(1,LUN),MBIT) + CALL PKB(IPD1 , 16 , MBAY(1,LUN),MBIT) + CALL PKB(IPD2 , 16 , MBAY(1,LUN),MBIT) + CALL PKB(IPD3 , 16 , MBAY(1,LUN),MBIT) + CALL PKB(IPD4 , 16 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + +C SECTION 4 +C --------- + + CALL PKB(NBY4 , 24 , MBAY(1,LUN),MBIT) + CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) + +C SECTION 5 +C --------- + + CALL PKC(SEVN , 4 , MBAY(1,LUN),MBIT) + +C DOUBLE CHECK INITIAL MESSAGE LENGTH +C ----------------------------------- + + IF(MOD(MBIT,8).NE.0) GOTO 903 + IF(MBIT/8.NE.NBYT ) GOTO 904 + + NMSG(LUN) = NMSG(LUN)+1 + NSUB(LUN) = 0 + MBYT(LUN) = NBYT + + LUNCPY(LUN)=0 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",'// + . 'I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN '// + . 'DICTIONARY")') INODE(LUN),INOD,SUBTAG + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE '// + . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBTAG + CALL BORT(BORT_STR) +902 CALL BORT + . ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') +903 CALL BORT('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END '// + . 'ON A BYTE BOUNDARY') +904 WRITE(BORT_STR,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR '// + . 'INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '// + . 'CALCULATED, NBYT (",I6)') MBIT/8,NBYT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/msgupd.f b/src/bufr/msgupd.f new file mode 100644 index 0000000000..686369656d --- /dev/null +++ b/src/bufr/msgupd.f @@ -0,0 +1,143 @@ + SUBROUTINE MSGUPD(LUNIT,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MSGUPD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY +C (ARRAY IBAY IN COMMON BLOCK /BITBUF/) AND THEN TRIES TO ADD IT TO +C THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT +C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IF THE SUBSET WILL NOT FIT +C INTO THE CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO +C LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE CURRENT SUBSET. +C IF THE SUBSET IS LARGER THAN AN EMPTY MESSAGE, THE SUBSET IS +C DISCARDED AND A DIAGNOSTIC IS PRINTED. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1998-12-14 J. WOOLLEN -- NO LONGER CALLS BORT IF A SUBSET IS LARGER +C THAN A MESSAGE, JUST DISCARDS THE SUBSET +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- USE MSGFULL AND ERRWRT +C +C USAGE: CALL MSGUPD (LUNIT, LUN) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT IUPB MSGFULL MSGINI +C MSGWRT MVB PAD PKB +C USRTPL +C THIS ROUTINE IS CALLED BY: WRITSA WRITSB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /QUIET / IPRT + + LOGICAL MSGFULL + + CHARACTER*128 ERRSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C PAD THE SUBSET BUFFER +C --------------------- + + CALL PAD(IBAY,IBIT,IBYT,8) + +C SEE IF THE NEW SUBSET FITS +C -------------------------- + + IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) THEN +c .... NO it does not fit + CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) + CALL MSGINI(LUN) + ENDIF + + IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) GOTO 900 + +C SET A BYTE COUNT AND TRANSFER THE SUBSET BUFFER INTO THE MESSAGE +C ---------------------------------------------------------------- + + LBIT = 0 + CALL PKB(IBYT,16,IBAY,LBIT) + +C Note that we want to append the data for this subset to the end +C of Section 4, but the value in MBYT(LUN) already includes the +C length of Section 5 (i.e. 4 bytes). Therefore, we need to begin +C writing at the point 3 bytes prior to the byte currently pointed +C to by MBYT(LUN). + + CALL MVB(IBAY,1,MBAY(1,LUN),MBYT(LUN)-3,IBYT) + +C UPDATE THE SUBSET AND BYTE COUNTERS +C -------------------------------------- + + MBYT(LUN) = MBYT(LUN) + IBYT + NSUB(LUN) = NSUB(LUN) + 1 + + LBIT = (NBY0+NBY1+NBY2+4)*8 + CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT) + + LBYT = NBY0+NBY1+NBY2+NBY3 + NBYT = IUPB(MBAY(1,LUN),LBYT+1,24) + LBIT = LBYT*8 + CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT) + +C RESET THE USER ARRAYS AND EXIT NORMALLY +C --------------------------------------- + + CALL USRTPL(LUN,1,1) + GOTO 100 + +C ON ENCOUTERING OVERLARGE SUBSETS, EXIT GRACEFULLY (SUBSET DISCARDED) +C -------------------------------------------------------------------- + +900 IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A)') + . 'BUFRLIB: MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE ', + . '{MAXIMUM MESSAGE LENGTH = ', MAXBYT, '}' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('>>>>>>>OVERLARGE SUBSET DISCARDED FROM FILE<<<<<<<<') + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/msgwrt.f b/src/bufr/msgwrt.f new file mode 100644 index 0000000000..625b05243a --- /dev/null +++ b/src/bufr/msgwrt.f @@ -0,0 +1,307 @@ + SUBROUTINE MSGWRT(LUNIT,MESG,MGBYT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MSGWRT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PERFORMS SOME FINAL CHECKS ON AN OUTPUT +C BUFR MESSAGE (E.G., CONFIRMING THAT EACH SECTION OF THE MESSAGE HAS +C AN EVEN NUMBER OF BYTES WHEN NECESSARY, "STANDARDIZING" THE MESSAGE +C IF REQUESTED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE +C STDMSG, ETC.), AND THEN PREPARES THE MESSAGE FOR FINAL OUTPUT TO +C LOGICAL UNIT LUNIT (E.G., ADDING THE STRING "7777" TO THE LAST FOUR +C BYTES OF THE MESSAGE, APPENDING ZEROED-OUT BYTES UP TO A SUBSEQUENT +C MACHINE WORD BOUNDARY, ETC.). IT THEN WRITES OUT THE FINISHED +C MESSAGE TO LOGICAL UNIT LUNIT AND ALSO STORES A COPY OF IT WITHIN +C COMMON /BUFRMG/ FOR POSSIBLE LATER RETRIEVAL VIA BUFR ARCHIVE +C LIBRARY SUBROUTINE WRITSA. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION +C WRITTEN IN SECTION 0 FROM 2 TO 3 +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1998-11-24 J. WOOLLEN -- MODIFIED TO ZERO OUT THE PADDING BYTES +C WRITTEN AT THE END OF SECTION 4 +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 J. ATOR -- DON'T WRITE TO LUNIT IF OPENED AS A NULL +C FILE BY OPENBF {NULL(LUN) = 1 IN NEW +C COMMON BLOCK /NULBFR/} (WAS IN DECODER +C VERSION); ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION; ADDED LOGIC TO CALL +C STNDRD IF REQUESTED VIA COMMON /MSGSTD/; +C ADDED LOGIC TO CALL OVRBS1 IF NECESSARY; +C MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01, PADMSG, PKBS1 AND +C NMWRD; ADDED LOGIC TO CALL PKBS1 AND/OR +C CNVED4 WHEN NECESSARY +C 2009-03-23 J. ATOR -- USE IDXMSG AND ERRWRT; ADD CALL TO ATRCPT; +C ALLOW STANDARDIZING VIA COMMON /MSGSTD/ +C EVEN IF DATA IS COMPRESSED; WORK ON LOCAL +C COPY OF INPUT MESSAGE +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C CALL NEW ROUTINE BLOCKS FOR FILE BLOCKING +C AND NEW C ROUTINE CWRBUFR TO WRITE BUFR +C MESSAGE TO DISK FILE +C +C USAGE: CALL MSGWRT (LUNIT, MESG, MGBYT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE TO OUTPUT TO LUNIT +C MGBYT - INTEGER: LENGTH OF BUFR MESSAGE IN BYTES +C +C OUTPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: ATRCPT BORT CNVED4 ERRWRT +C GETLENS IDXMSG IUPB IUPBS01 +C NMWRD PADMSG PKB PKBS1 +C PKC STATUS STNDRD BLOCKS +C CWRBUFR +C THIS ROUTINE IS CALLED BY: CLOSMG COPYBF COPYMG CPYMEM +C CPYUPD MSGUPD WRCMPS WRDXTB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + PARAMETER (MXCOD=15) + + COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) + COMMON /NULBFR/ NULL(NFILES) + COMMON /QUIET / IPRT + COMMON /MSGSTD/ CSMF + COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) + COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT + + CHARACTER*128 ERRSTR + + CHARACTER*8 CMNEM + CHARACTER*4 BUFR,SEVN + CHARACTER*1 CSMF + CHARACTER*1 CTRT + DIMENSION MESG(*) + DIMENSION MBAY(MXMSGLD4),MSGNEW(MXMSGLD4) + DIMENSION IEC0(2) + + DATA BUFR/'BUFR'/ + DATA SEVN/'7777'/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C MAKE A LOCAL COPY OF THE INPUT MESSAGE FOR USE WITHIN THIS +C SUBROUTINE, SINCE CALLS TO ANY OR ALL OF THE SUBROUTINES STNDRD, +C CNVED4, PKBS1, ATRCPT, ETC. MAY END UP MODIFYING THE MESSAGE +C BEFORE IT FINALLY GETS WRITTEN OUT TO LUNIT. + + MBYT = MGBYT + + IEC0(1) = MESG(1) + IEC0(2) = MESG(2) + IBIT = 32 + CALL PKB(MBYT,24,IEC0,IBIT) + + DO II = 1, NMWRD(IEC0) + MBAY(II) = MESG(II) + ENDDO + +C OVERWRITE ANY VALUES WITHIN SECTION 0 OR SECTION 1 THAT WERE +C REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE +C PKVS01. IF A REQUEST WAS MADE TO CHANGE THE BUFR EDITION NUMBER +C TO 4, THEN ACTUALLY CONVERT THE MESSAGE AS WELL. + + IF(NS01V.GT.0) THEN + DO I=1,NS01V + IF(CMNEM(I).EQ.'BEN') THEN + IF(IVMNEM(I).EQ.4) THEN + +C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4. + + IBIT = 32 + CALL PKB(MBYT,24,MBAY,IBIT) + + CALL CNVED4(MBAY,MXMSGLD4,MSGNEW) + +C COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE. + + MBYT = IUPBS01(MSGNEW,'LENM') + +C COPY THE MSGNEW ARRAY BACK INTO MBAY. + + DO II = 1, NMWRD(MSGNEW) + MBAY(II) = MSGNEW(II) + ENDDO + ENDIF + ELSE + +C OVERWRITE THE REQUESTED VALUE. + + CALL PKBS1(IVMNEM(I),MBAY,CMNEM(I)) + ENDIF + ENDDO + ENDIF + +C "STANDARDIZE" THE MESSAGE IF REQUESTED VIA COMMON /MSGSTD/. +C HOWEVER, WE DO NOT WANT TO DO THIS IF THE MESSAGE CONTAINS BUFR +C TABLE (DX) INFORMATION, IN WHICH CASE IT IS ALREADY "STANDARD". + + IF ( ( CSMF.EQ.'Y' ) .AND. ( IDXMSG(MBAY).NE.1 ) ) THEN + +C INSTALL SECTION 0 BYTE COUNT AND SECTION 5 '7777' INTO THE +C ORIGINAL MESSAGE. THIS IS NECESSARY BECAUSE SUBROUTINE STNDRD +C REQUIRES A COMPLETE AND WELL-FORMED BUFR MESSAGE AS ITS INPUT. + + IBIT = 32 + CALL PKB(MBYT,24,MBAY,IBIT) + IBIT = (MBYT-4)*8 + CALL PKC(SEVN,4,MBAY,IBIT) + + CALL STNDRD(LUNIT,MBAY,MXMSGLD4,MSGNEW) + +C COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE. + + MBYT = IUPBS01(MSGNEW,'LENM') + +C COPY THE MSGNEW ARRAY BACK INTO MBAY. + + DO II = 1, NMWRD(MSGNEW) + MBAY(II) = MSGNEW(II) + ENDDO + ENDIF + +C APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA +C COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX) +C INFORMATION. + + IF ( ( CTRT.EQ.'Y' ) .AND. ( IDXMSG(MBAY).NE.1 ) ) THEN + +C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE ATRCPT. + + IBIT = 32 + CALL PKB(MBYT,24,MBAY,IBIT) + + CALL ATRCPT(MBAY,MXMSGLD4,MSGNEW) + +C COMPUTE MBYT FOR THE REVISED MESSAGE. + + MBYT = IUPBS01(MSGNEW,'LENM') + +C COPY THE MSGNEW ARRAY BACK INTO MBAY. + + DO II = 1, NMWRD(MSGNEW) + MBAY(II) = MSGNEW(II) + ENDDO + ENDIF + +C GET THE SECTION LENGTHS. + + CALL GETLENS(MBAY,4,LEN0,LEN1,LEN2,LEN3,LEN4,L5) + +C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE +C THAT EACH SECTION WITHIN THE MESSAGE HAS AN EVEN NUMBER OF BYTES. + + IF(IUPBS01(MBAY,'BEN').LT.4) THEN + IF(MOD(LEN1,2).NE.0) GOTO 901 + IF(MOD(LEN2,2).NE.0) GOTO 902 + IF(MOD(LEN3,2).NE.0) GOTO 903 + IF(MOD(LEN4,2).NE.0) THEN + +C PAD SECTION 4 WITH AN ADDITIONAL BYTE +C THAT IS ZEROED OUT. + + IAD4 = LEN0+LEN1+LEN2+LEN3 + IAD5 = IAD4+LEN4 + IBIT = IAD4*8 + LEN4 = LEN4+1 + CALL PKB(LEN4,24,MBAY,IBIT) + IBIT = IAD5*8 + CALL PKB(0,8,MBAY,IBIT) + MBYT = MBYT+1 + ENDIF + ENDIF + +C WRITE SECTION 0 BYTE COUNT AND SECTION 5 +C ---------------------------------------- + + IBIT = 0 + CALL PKC(BUFR, 4,MBAY,IBIT) + CALL PKB(MBYT,24,MBAY,IBIT) + + KBIT = (MBYT-4)*8 + CALL PKC(SEVN, 4,MBAY,KBIT) + +C ZERO OUT THE EXTRA BYTES WHICH WILL BE WRITTEN +C ---------------------------------------------- + +C I.E. SINCE THE BUFR MESSAGE IS STORED WITHIN THE INTEGER ARRAY +C MBAY(*) (RATHER THAN WITHIN A CHARACTER ARRAY), WE NEED TO MAKE +C SURE THAT THE "7777" IS FOLLOWED BY ZEROED-OUT BYTES UP TO THE +C BOUNDARY OF THE LAST MACHINE WORD THAT WILL BE WRITTEN OUT. + + CALL PADMSG(MBAY,MXMSGLD4,NPBYT) + +C WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0 +C ------------------------------------------------------------------ + + MWRD = NMWRD(MBAY) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(NULL(LUN).EQ.0) then + CALL BLOCKS(MBAY,MWRD) + call cwrbufr(lun,mbay,mwrd) + ENDIF + + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,I7)') + . 'BUFRLIB: MSGWRT: LUNIT =', LUNIT, ', BYTES =', MBYT+NPBYT + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C SAVE A MEMORY COPY OF THIS MESSAGE, UNLESS IT'S A DX MESSAGE +C ------------------------------------------------------------ + + IF(IDXMSG(MBAY).NE.1) THEN + +C STORE A COPY OF THIS MESSAGE WITHIN COMMON /BUFRMG/, +C FOR POSSIBLE LATER RETRIEVAL DURING THE NEXT CALL TO +C SUBROUTINE WRITSA. + + MSGLEN = MWRD + DO I=1,MSGLEN + MSGTXT(I) = MBAY(I) + ENDDO + ENDIF + +C EXITS +C ----- + + RETURN +901 CALL BORT + . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2') +902 CALL BORT + . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2') +903 CALL BORT + . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') + END diff --git a/src/bufr/mtinfo.f b/src/bufr/mtinfo.f new file mode 100644 index 0000000000..be82da1557 --- /dev/null +++ b/src/bufr/mtinfo.f @@ -0,0 +1,62 @@ + SUBROUTINE MTINFO ( CMTDIR, LUNMT1, LUNMT2 ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MTINFO +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY THE DIRECTORY LOCATION +C AND FORTRAN LOGICAL UNIT NUMBERS TO USE WHEN READING BUFR MASTER +C TABLES ON THE LOCAL FILE SYSTEM. THE INPUT LOGICAL UNIT NUMBERS +C SHOULD BE UNIQUE BUT SHOULD NOT ALREADY BE ASSIGNED TO ANY ACTUAL +C BUFR MASTER TABLE FILES. IF THIS SUBROUTINE IS NOT CALLED, THEN +C DEFAULT VALUES ARE USED AS DEFINED WITHIN BUFR ARCHIVE LIBRARY +C SUBROUTINE BFRINI. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL MTINFO ( CMTDIR, LUNMT1, LUNMT2 ) +C INPUT ARGUMENT LIST: +C CMTDIR - CHARACTER*(*): DIRECTORY LOCATION OF BUFR MASTER TABLES +C ON LOCAL FILE SYSTEM (UP TO 100 CHARACTERS) +C LUNMT1 - INTEGER: FIRST FORTRAN LOGICAL UNIT NUMBER TO USE WHEN +C READING BUFR MASTER TABLES ON LOCAL FILE SYSTEM +C LUNMT2 - INTEGER: SECOND FORTRAN LOGICAL UNIT NUMBER TO USE WHEN +C READING BUFR MASTER TABLES ON LOCAL FILE SYSTEM +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 STRSUC +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR + + CHARACTER*(*) CMTDIR + + CHARACTER*128 BORT_STR + CHARACTER*100 MTDIR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL STRSUC ( CMTDIR, MTDIR, LMTD ) + IF ( LMTD .LT. 0 ) GOTO 900 + + LUN1 = LUNMT1 + LUN2 = LUNMT2 + +C EXITS +C ----- + + RETURN +900 BORT_STR = 'BUFRLIB: MTINFO - BAD INPUT MASTER TABLE DIRECTORY:' + CALL BORT2(BORT_STR,CMTDIR) + END diff --git a/src/bufr/mvb.f b/src/bufr/mvb.f new file mode 100644 index 0000000000..5ae94eb343 --- /dev/null +++ b/src/bufr/mvb.f @@ -0,0 +1,79 @@ + SUBROUTINE MVB(IB1,NB1,IB2,NB2,NBM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: MVB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF BYTES FROM +C ONE PACKED BINARY ARRAY TO ANOTHER. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2005-11-29 J. ATOR -- MAXIMUM NUMBER OF BYTES TO COPY INCREASED +C FROM 24000 TO MXIMB +C +C USAGE: CALL MVB (IB1, NB1, IB2, NB2, NBM) +C INPUT ARGUMENT LIST: +C IB1 - INTEGER: *-WORD PACKED INPUT BINARY ARRAY +C NB1 - INTEGER: POINTER TO FIRST BYTE IN IB1 TO COPY FROM +C NB2 - INTEGER: POINTER TO FIRST BYTE IN IB2 TO COPY TO +C NBM - INTEGER: NUMBER OF BYTES TO COPY +C +C OUTPUT ARGUMENT LIST: +C IB2 - INTEGER: *-WORD PACKED OUTPUT BINARY ARRAY +C +C REMARKS: +C THIS ROUTINE CALLS: BORT PKB UPB +C THIS ROUTINE IS CALLED BY: ATRCPT CNVED4 CPYUPD MSGUPD +C STNDRD +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + CHARACTER*128 BORT_STR + DIMENSION IB1(*),IB2(*),NVAL(MXIMB) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(NBM.GT.MXIMB) GOTO 900 + JB1 = 8*(NB1-1) + JB2 = 8*(NB2-1) + + DO N=1,NBM + CALL UPB(NVAL(N),8,IB1,JB1) + ENDDO + + DO N=1,NBM + CALL PKB(NVAL(N),8,IB2,JB2) + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: MVB - THE NUMBER OF BYTES BEING '// + . 'REQUESTED TO COPY (",I7,") EXCEEDS THE LIMIT (",I7,")")') + . NBM, MXIMB + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nemock.f b/src/bufr/nemock.f new file mode 100644 index 0000000000..9dacfa2dee --- /dev/null +++ b/src/bufr/nemock.f @@ -0,0 +1,89 @@ + FUNCTION NEMOCK(NEMO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEMOCK +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CHECKS A MNEMONIC TO VERIFY THAT IT HAS A +C LENGTH OF BETWEEN ONE AND EIGHT CHARACTERS AND THAT IT ONLY +C CONTAINS CHARACTERS FROM THE ALLOWABLE CHARACTER SET. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- SPLIT NON-ZERO RETURN INTO -1 FOR LENGTH +C NOT 1-8 CHARACTERS AND -2 FOR INVALID +C CHARACTERS (RETURN ONLY -1 BEFORE FOR ALL +C PROBLEMATIC CASES); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION +C +C USAGE: NEMOCK (NEMO) +C INPUT ARGUMENT LIST: +C NEMO - CHARACTER*(*): MNEMONIC TO BE CHECKED +C +C OUTPUT ARGUMENT LIST: +C NEMOCK - INTEGER: INDICATOR AS TO WHETHER NEMO IS VALID: +C 0 = yes +C -1 = no, length not between 1 and 8 characters +C -2 = no, it does not contain characters from the +C allowable character set +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: RDUSDX SEQSDX SNTBBE SNTBDE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) NEMO + CHARACTER*38 CHRSET + + DATA CHRSET /'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_.'/ + DATA NCHR /38/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C GET THE LENGTH OF NEMO +C ---------------------- + + LNEMO = 0 + + DO I=LEN(NEMO),1,-1 + IF(NEMO(I:I).NE.' ') THEN + LNEMO = I + GOTO 1 + ENDIF + ENDDO + +1 IF(LNEMO.LT.1 .OR. LNEMO.GT.8) THEN + NEMOCK = -1 + GOTO 100 + ENDIF + +C SCAN NEMO FOR ALLOWABLE CHARACTERS +C ---------------------------------- + + DO 10 I=1,LNEMO + DO J=1,NCHR + IF(NEMO(I:I).EQ.CHRSET(J:J)) GOTO 10 + ENDDO + NEMOCK = -2 + GOTO 100 +10 ENDDO + + NEMOCK = 0 + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/nemtab.f b/src/bufr/nemtab.f new file mode 100644 index 0000000000..8cb273cb72 --- /dev/null +++ b/src/bufr/nemtab.f @@ -0,0 +1,149 @@ + SUBROUTINE NEMTAB(LUN,NEMO,IDN,TAB,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEMTAB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE +C INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS +C IN COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT +C THAT MNEMONIC FROM WITHIN THESE ARRAYS. OTHERWISE, IT CHECKS +C WHETHER NEMO IS A TABLE C OPERATOR DESCRIPTOR AND, IF SO, DIRECTLY +C COMPUTES AND RETURNS SIMILAR INFORMATION ABOUT THAT DESCRIPTOR. +C THIS SUBROUTINE MAY BE USEFUL TO APPLICATION PROGRAMS WHICH WANT +C TO CHECK WHETHER A PARTICULAR MNEMONIC IS IN THE DICTIONARY. IN +C THIS CASE, BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF MUST FIRST BE +C CALLED TO STORE THE DICTIONARY TABLE INTERNALLY, AND BUFR ARCHIVE +C LIBRARY SUBROUTINE STATUS MUST BE CALLED TO CONNECT THE LOGICAL +C UNIT NUMBER FOR THE BUFR FILE OPENED IN OPENBF TO LUN. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA +C USING THE OPERATOR DESCRIPTORS (BUFR TABLE +C C) FOR CHANGING WIDTH AND CHANGING SCALE +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS +C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 AND 205 OPERATORS +C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR +C +C USAGE: CALL NEMTAB (LUN, NEMO, IDN, TAB, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C NEMO - CHARACTER*(*): MNEMONIC TO SEARCH FOR +C +C OUTPUT ARGUMENT LIST: +C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE +C CORRESPONDING TO NEMO (IF NEMO WAS FOUND) +C TAB - CHARACTER*1: INTERNAL TABLE ARRAY IN WHICH NEMO WAS +C FOUND: +C 'B' = Table B array +C 'C' = Table C array +C 'D' = Table D array +C IRET - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB +C 0 = NEMO was not found within any of the Table +C B, C, or D arrays +C +C REMARKS: +C THIS ROUTINE CALLS: IFXY +C THIS ROUTINE IS CALLED BY: CHEKSTAB CMSGINI ELEMDX MSGINI +C SEQSDX STSEQ TABSUB UFBDMP +C UFBQCD UFDUMP UPFTBV +C Also called by application programs +C (see ABSTRACT). +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*(*) NEMO + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*8 NEMT + CHARACTER*1 TAB + LOGICAL FOLVAL + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + FOLVAL = NEMO(1:1).EQ.'.' + IRET = 0 + TAB = ' ' + +C LOOK FOR NEMO IN TABLE B +C ------------------------ + + DO 1 I=1,NTBB(LUN) + NEMT = TABB(I,LUN)(7:14) + IF(NEMT.EQ.NEMO) THEN + IDN = IDNB(I,LUN) + TAB = 'B' + IRET = I + GOTO 100 + ELSEIF(FOLVAL.AND.NEMT(1:1).EQ.'.') THEN + DO J=2,LEN(NEMT) + IF(NEMT(J:J).NE.'.' .AND. NEMT(J:J).NE.NEMO(J:J)) GOTO 1 + ENDDO + IDN = IDNB(I,LUN) + TAB = 'B' + IRET = I + GOTO 100 + ENDIF +1 ENDDO + +C DON'T LOOK IN TABLE D FOR FOLLOWING VALUE-MNEMONICS +C --------------------------------------------------- + + IF(FOLVAL) GOTO 100 + +C LOOK IN TABLE D IF WE GOT THIS FAR +C ---------------------------------- + + DO I=1,NTBD(LUN) + NEMT = TABD(I,LUN)(7:14) + IF(NEMT.EQ.NEMO) THEN + IDN = IDND(I,LUN) + TAB = 'D' + IRET = I + GOTO 100 + ENDIF + ENDDO + +C IF STILL NOTHING, CHECK HERE FOR TABLE C OPERATOR DESCRIPTORS +C ------------------------------------------------------------- + + IF ( (NEMO(1:2).EQ.'20') .AND. + . ( LGE(NEMO(3:3),'1') .AND. LLE(NEMO(3:3),'8') ) ) THEN + READ(NEMO,'(1X,I2)') IRET + IDN = IFXY(NEMO) + TAB = 'C' + GOTO 100 + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/nemtba.f b/src/bufr/nemtba.f new file mode 100644 index 0000000000..a0142eb831 --- /dev/null +++ b/src/bufr/nemtba.f @@ -0,0 +1,81 @@ + SUBROUTINE NEMTBA(LUN,NEMO,MTYP,MSBT,INOD) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEMTBA +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE +C INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS IN +C COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT THAT +C MNEMONIC FROM WITHIN THESE ARRAYS. IT IS IDENTICAL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE NEMTBAX EXCEPT THAT, IF NEMO IS NOT FOUND, THIS +C SUBROUTINE MAKES AN APPROPRIATE CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2009-05-07 J. ATOR -- USE NEMTBAX +C +C USAGE: CALL NEMTBA (LUN, NEMO, MTYP, MSBT, INOD) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C NEMO - CHARACTER*(*): TABLE A MNEMONIC TO SEARCH FOR +C +C OUTPUT ARGUMENT LIST: +C MTYP - INTEGER: MESSAGE TYPE CORRESPONDING TO NEMO +C MSBT - INTEGER: MESSAGE SUBTYPE CORRESPONDING TO NEMO +C INOD - INTEGER: POSITIONAL INDEX OF NEMO WITHIN INTERNAL +C JUMP/LINK TABLE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT NEMTBAX +C THIS ROUTINE IS CALLED BY: CMSGINI COPYMG CPYMEM LCMGDF +C MSGINI OPENMB OPENMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + CHARACTER*(*) NEMO + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C LOOK FOR NEMO IN TABLE A +C ------------------------ + + CALL NEMTBAX(LUN,NEMO,MTYP,MSBT,INOD) + IF(INOD.EQ.0) GOTO 900 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NEMTBA - CAN''T FIND MNEMONIC ",A)') + . NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nemtbax.f b/src/bufr/nemtbax.f new file mode 100644 index 0000000000..5473ccf115 --- /dev/null +++ b/src/bufr/nemtbax.f @@ -0,0 +1,92 @@ + SUBROUTINE NEMTBAX(LUN,NEMO,MTYP,MSBT,INOD) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEMTBAX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 +C +C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE +C INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS IN +C COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT +C THAT MNEMONIC FROM WITHIN THESE ARRAYS. IT IS IDENTICAL TO BUFR +C ARCHIVE LIBRARY SUBROUTINE NEMTBA EXCEPT THAT, IF NEMO IS NOT +C FOUND, THIS SUBROUTINE RETURNS WITH INOD EQUAL TO ZERO, WHEREAS +C NEMTBA CALLS BUFR ARCHIVE LIBRARY SUBROUTINE BORT IN SUCH CASES. +C +C PROGRAM HISTORY LOG: +C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: CALL NEMTBAX (LUN, NEMO, MTYP, MSBT, INOD) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C NEMO - CHARACTER*(*): TABLE A MNEMONIC TO SEARCH FOR +C +C OUTPUT ARGUMENT LIST: +C MTYP - INTEGER: MESSAGE TYPE CORRESPONDING TO NEMO +C MSBT - INTEGER: MESSAGE SUBTYPE CORRESPONDING TO NEMO +C INOD - INTEGER: POSITIONAL INDEX OF NEMO WITHIN INTERNAL +C JUMP/LINK TABLE IF NEMO FOUND +C 0 = NEMO not found +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: CKTABA IOK2CPY NEMTBA STNDRD +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*(*) NEMO + CHARACTER*600 TABD + CHARACTER*128 BORT_STR + CHARACTER*128 TABB + CHARACTER*128 TABA + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + INOD = 0 + +C LOOK FOR NEMO IN TABLE A +C ------------------------ + + DO I=1,NTBA(LUN) + IF(TABA(I,LUN)(4:11).EQ.NEMO) THEN + MTYP = IDNA(I,LUN,1) + MSBT = IDNA(I,LUN,2) + INOD = MTAB(I,LUN) + IF(MTYP.LT.0 .OR. MTYP.GT.255) GOTO 900 + IF(MSBT.LT.0 .OR. MSBT.GT.255) GOTO 901 + GOTO 100 + ENDIF + ENDDO + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NEMTBAX - INVALID MESSAGE TYPE (",I4'// + . ',") RETURNED FOR MENMONIC ",A)') MTYP,NEMO + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: NEMTBAX - INVALID MESSAGE SUBTYPE ("'// + . ',I4,") RETURNED FOR MENMONIC ",A)') MSBT,NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nemtbb.f b/src/bufr/nemtbb.f new file mode 100644 index 0000000000..7fee620203 --- /dev/null +++ b/src/bufr/nemtbb.f @@ -0,0 +1,129 @@ + SUBROUTINE NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEMTBB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CHECKS ALL OF THE PROPERTIES (E.G. FXY +C VALUE, UNITS, SCALE FACTOR, REFERENCE VALUE, ETC.) OF A SPECIFIED +C MNEMONIC WITHIN THE INTERNAL BUFR TABLE B ARRAYS (IN COMMON BLOCK +C /TABABD/) IN ORDER TO VERIFY THAT THE VALUES OF THOSE PROPERTIES +C ARE ALL LEGAL AND WELL-DEFINED. IF ANY ERRORS ARE FOUND, THEN AN +C APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS +C 1999-11-18 J. WOOLLEN -- CHANGED CALL TO FUNCTION "VAL$" TO "VALX" +C (IT HAS BEEN RENAMED TO REMOVE THE +C POSSIBILITY OF THE "$" SYMBOL CAUSING +C PROBLEMS ON OTHER PLATFORMS) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL NEMTBB (LUN, ITAB, UNIT, ISCL, IREF, IBIT) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C ITAB - INTEGER: POSITIONAL INDEX INTO INTERNAL BUFR TABLE B +C ARRAYS FOR MNEMONIC TO BE CHECKED +C +C OUTPUT ARGUMENT LIST: +C UNIT - CHARACTER*24: UNITS OF MNEMONIC +C ISCL - INTEGER: SCALE FACTOR OF MNEMONIC +C IREF - INTEGER: REFERENCE VALUE OF MNEMONIC +C IBIT - INTEGER: BIT WIDTH OF MNEMONIC +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IFXY VALX +C THIS ROUTINE IS CALLED BY: CHEKSTAB RESTD TABENT +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*24 UNIT + CHARACTER*8 NEMO + REAL*8 MXR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + MXR = 1E11-1 + + IF(ITAB.LE.0 .OR. ITAB.GT.NTBB(LUN)) GOTO 900 + +C PULL OUT TABLE B INFORMATION +C ---------------------------- + + IDN = IDNB(ITAB,LUN) + NEMO = TABB(ITAB,LUN)( 7:14) + UNIT = TABB(ITAB,LUN)(71:94) + ISCL = VALX(TABB(ITAB,LUN)( 95: 98)) + IREF = VALX(TABB(ITAB,LUN)( 99:109)) + IBIT = VALX(TABB(ITAB,LUN)(110:112)) + +C CHECK TABLE B CONTENTS +C ---------------------- + + IF(IDN.LT.IFXY('000000')) GOTO 901 + IF(IDN.GT.IFXY('063255')) GOTO 901 + + IF(ISCL.LT.-999 .OR. ISCL.GT.999) GOTO 902 + IF(IREF.LE.-MXR .OR. IREF.GE.MXR) GOTO 903 + IF(IBIT.LE.0) GOTO 904 + IF(UNIT(1:5).NE.'CCITT' .AND. IBIT.GT.32 ) GOTO 904 + IF(UNIT(1:5).EQ.'CCITT' .AND. MOD(IBIT,8).NE.0) GOTO 905 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - ITAB (",I7,") NOT FOUND IN '// + . 'TABLE B")') ITAB + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - INTEGER REPRESENTATION OF '// + . 'DESCRIPTOR FOR TABLE B MNEMONIC ",A," (",I7,") IS OUTSIDE '// + . 'RANGE 0-16383 (16383 -> 0-63-255)")') NEMO,IDN + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - SCALE VALUE FOR TABLE B '// + .'MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE -999 TO 999")') + . NEMO,ISCL + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - REFERENCE VALUE FOR TABLE B'// + .' MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE +/- 1E11-1")') + . NEMO,IREF + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - BIT WIDTH FOR NON-CHARACTER'// + . ' TABLE B MNEMONIC ",A," (",I7,") IS > 32")') NEMO,IBIT + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - BIT WIDTH FOR CHARACTER '// + . 'TABLE B MNEMONIC ",A," (",I7,") IS NOT A MULTIPLE OF 8")') + . NEMO,IBIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nemtbd.f b/src/bufr/nemtbd.f new file mode 100644 index 0000000000..659bfef88e --- /dev/null +++ b/src/bufr/nemtbd.f @@ -0,0 +1,224 @@ + SUBROUTINE NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEMTBD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE RETURNS A LIST OF THE MNEMONICS (I.E., +C "CHILD" MNEMONICS) CONTAINED WITHIN A TABLE D SEQUENCE MNEMONIC +C (I.E., A "PARENT MNEMONIC"). THIS INFORMATION SHOULD HAVE BEEN +C PACKED INTO THE INTERNAL BUFR TABLE D ENTRY FOR THE PARENT MNEMONIC +C (IN COMMON BLOCK /TABABD/) VIA PREVIOUS CALLS TO BUFR ARCHIVE +C LIBRARY SUBROUTINE PKTDD. NOTE THAT NEMTBD DOES NOT RECURSIVELY +C RESOLVE CHILD MNEMONICS WHICH ARE THEMSELVES TABLE D SEQUENCE +C MNEMONICS; RATHER, SUCH RESOLUTION MUST BE DONE VIA SEPARATE +C SUBSEQUENT CALLS TO THIS SUBROUTINE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MUST NOW CHECK FOR TABLE C (OPERATOR +C DESCRIPTOR) MNEMONICS SINCE THE CAPABILITY +C HAS NOW BEEN ADDED TO ENCODE AND DECODE +C THESE +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL NEMTBD (LUN, ITAB, NSEQ, NEMS, IRPS, KNTS) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C ITAB - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN +C INTERNAL BUFR TABLE D ARRAY TABD(*,*) +C +C OUTPUT ARGUMENT LIST: +C NSEQ - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS FOR THE +C PARENT MNEMONIC GIVEN BY TABD(ITAB,LUN) +C NEMS - CHARACTER*8: (NSEQ)-WORD ARRAY OF CHILD MNEMONICS +C IRPS - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS) +C KNTS - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS) +C +C REMARKS: +C VALUE FOR OUTPUT ARGUMENT IRPS: +C The interpretation of the return value IRPS(I) depends upon the +C type of descriptor corresponding to NEMS(I), as follows: +C +C IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed) +C replication descriptor ) THEN +C IRPS(I) = 1 +C ELSE IF ( NEMS(I) corresponds to a delayed replicator or +C replication factor descriptor ) THEN +C IRPS(I) = positional index of corresponding descriptor +C within internal replication array IDNR(*,*) +C ELSE +C IRPS(I) = 0 +C END IF +C +C +C VALUE FOR OUTPUT ARGUMENT KNTS: +C The interpretation of the return value KNTS(I) depends upon the +C type of descriptor corresponding to NEMS(I), as follows: +C +C IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed) +C replication descriptor ) THEN +C KNTS(I) = number of replications +C ELSE +C KNTS(I) = 0 +C END IF +C +C +C THIS ROUTINE CALLS: ADN30 BORT IFXY NUMTAB +C RSVFVM UPTDD +C THIS ROUTINE IS CALLED BY: CHEKSTAB DXDUMP GETABDB TABSUB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*128 BORT_STR + CHARACTER*8 NEMO,NEMS,NEMT,NEMF + CHARACTER*6 ADN30,CLEMON + CHARACTER*1 TAB + DIMENSION NEMS(MAXCD),IRPS(MAXCD),KNTS(MAXCD) + LOGICAL REP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(ITAB.LE.0 .OR. ITAB.GT.NTBD(LUN)) GOTO 900 + + REP = .FALSE. + +C CLEAR THE RETURN VALUES +C ----------------------- + + NSEQ = 0 + + DO I=1,MAXCD + NEMS(I) = ' ' + IRPS(I) = 0 + KNTS(I) = 0 + ENDDO + +C PARSE THE TABLE D ENTRY +C ----------------------- + + NEMO = TABD(ITAB,LUN)(7:14) + IDSC = IDND(ITAB,LUN) + CALL UPTDD(ITAB,LUN,0,NDSC) + + IF(IDSC.LT.IFXY('300000')) GOTO 901 + IF(IDSC.GT.IFXY('363255')) GOTO 901 +cccc IF(NDSC.LE.0 ) GOTO 902 + +C Loop through each child mnemonic. + +c .... DK: What happens here if NDSC=0 ? + DO J=1,NDSC + IF(NSEQ+1.GT.MAXCD) GOTO 903 + CALL UPTDD(ITAB,LUN,J,IDSC) +c .... get NEMT from IDSC + CALL NUMTAB(LUN,IDSC,NEMT,TAB,IRET) + IF(TAB.EQ.'R') THEN + IF(REP) GOTO 904 + REP = .TRUE. + IF(IRET.LT.0) THEN + +C F=1 regular (i.e. non-delayed) replication. + + IRPS(NSEQ+1) = 1 + KNTS(NSEQ+1) = ABS(IRET) + ELSEIF(IRET.GT.0) THEN + +C Delayed replication. + + IRPS(NSEQ+1) = IRET + ENDIF + ELSEIF(TAB.EQ.'F') THEN + +C Replication factor. + + IF(.NOT.REP) GOTO 904 + IRPS(NSEQ+1) = IRET + REP = .FALSE. + ELSEIF(TAB.EQ.'D'.OR.TAB.EQ.'C') THEN + REP = .FALSE. + NSEQ = NSEQ+1 + NEMS(NSEQ) = NEMT + ELSEIF(TAB.EQ.'B') THEN + REP = .FALSE. + NSEQ = NSEQ+1 + IF(NEMT(1:1).EQ.'.') THEN + +C This is a "following value" mnemonic. + + CALL UPTDD(ITAB,LUN,J+1,IDSC) +c .... get NEMF from IDSC + CALL NUMTAB(LUN,IDSC,NEMF,TAB,IRET) + CALL RSVFVM(NEMT,NEMF) + IF(TAB.NE.'B') GOTO 906 + ENDIF + NEMS(NSEQ) = NEMT + ELSE + GOTO 905 + ENDIF + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - ITAB (",I7,") NOT FOUND IN '// + . 'TABLE D")') ITAB + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - INTEGER REPRESENTATION OF '// + . 'DESCRIPTOR FOR TABLE D MNEMONIC ",A," (",I7,") IS OUTSIDE '// + . 'RANGE 0-65535 (65535 -> 3-63-255)")') NEMO,IDSC + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - TABLE D MNEMONIC ",A," IS A'// + . ' ZERO LENGTH SEQUENCE")') NEMO + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - THERE ARE MORE THAN '// + . '(",I4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '// + . 'MNEMONIC ",A)') MAXCD, NEMO + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - REPLICATOR IS OUT OF ORDER '// + . 'IN TABLE D SEQUENCE MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +905 CLEMON = ADN30(IDSC,6) + WRITE(BORT_STR,'("BUFRLIB: NEMTBD - UNRECOGNIZED DESCRIPTOR '// + . '",A," IN TABLE D SEQUENCE MNEMONIC ",A)') CLEMON,NEMO + CALL BORT(BORT_STR) +906 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - A ''FOLLOWING VALUE'' '// + . 'MNEMONIC (",A,") IS FROM TABLE ",A,", IT MUST BE FROM TABLE B'// + . '")') NEMF,TAB + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nenubd.f b/src/bufr/nenubd.f new file mode 100644 index 0000000000..83c04083b0 --- /dev/null +++ b/src/bufr/nenubd.f @@ -0,0 +1,103 @@ + SUBROUTINE NENUBD(NEMO,NUMB,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NENUBD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CHECKS A MNEMONIC AND FXY VALUE PAIR THAT +C WERE READ FROM A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER +C FORMAT, IN ORDER TO MAKE SURE THAT NEITHER VALUE HAS ALREADY BEEN +C DEFINED WITHIN INTERNAL BUFR TABLE B OR D (IN COMMON BLOCK +C /TABABD/) FOR THE GIVEN LUN. IF EITHER VALUE HAS ALREADY BEEN +C DEFINED FOR THIS LUN, THEN AN APPROPRIATE CALL IS MADE TO +C BUFR ARCHIVE LIBRARY SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN NENUCK) +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" (IN PARENT ROUTINE NENUCK) +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) (IN PARENT +C ROUTINE NENUCK) +C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE +C PORTABILITY TO OTHER PLATFORMS (NENUCK WAS +C THEN REMOVED BECAUSE IT WAS JUST A DUMMY +C ROUTINE WITH ENTRIES) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL NENUBD (NEMO, NUMB, LUN) +C INPUT ARGUMENT LIST: +C NEMO - CHARACTER*8: MNEMONIC +C NUMB - CHARACTER*6: FXY VALUE ASSOCIATED WITH NEMO +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: STBFDX STNTBI +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*8 NEMO + CHARACTER*6 NUMB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C CHECK TABLE B AND D +C ------------------- + + DO N=1,NTBB(LUN) + IF(NUMB.EQ.TABB(N,LUN)(1: 6)) GOTO 900 + IF(NEMO.EQ.TABB(N,LUN)(7:14)) GOTO 901 + ENDDO + + DO N=1,NTBD(LUN) + IF(NUMB.EQ.TABD(N,LUN)(1: 6)) GOTO 902 + IF(NEMO.EQ.TABD(N,LUN)(7:14)) GOTO 903 + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE B FXY VALUE (",A,") '// + . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE B MNEMONIC (",A,") '// + . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE D FXY VALUE (",A,") '// + . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE D MNEMONIC (",A,") '// + . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nevn.f b/src/bufr/nevn.f new file mode 100644 index 0000000000..c0c2722497 --- /dev/null +++ b/src/bufr/nevn.f @@ -0,0 +1,110 @@ + FUNCTION NEVN(NODE,LUN,INV1,INV2,I1,I2,I3,USR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEVN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS FUNCTION LOOKS FOR ALL STACKED DATA EVENTS FOR A +C SPECIFIED DATA VALUE AND LEVEL WITHIN THE PORTION OF THE CURRENT +C SUBSET BUFFER BOUNDED BY THE INDICES INV1 AND INV2. ALL SUCH +C EVENTS ARE ACCUMULATED AND RETURNED TO THE CALLING PROGRAM WITHIN +C ARRAY USR. THE VALUE OF THE FUNCTION ITSELF IS THE TOTAL NUMBER +C OF EVENTS FOUND. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION +C VERSION) +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION +C +C USAGE: NEVN (NODE, LUN, INV1, INV2, I1, I2, I3, USR) +C INPUT ARGUMENT LIST: +C NODE - INTEGER: JUMP/LINK TABLE INDEX OF NODE TO RETURN +C STACKED VALUES FOR +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK FOR STACK VALUES +C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK FOR STACK VALUES +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR +C +C OUTPUT ARGUMENT LIST: +C USR - REAL*8:(I1,I2,I3) STARTING ADDRESS OF DATA VALUES READ +C FROM DATA SUBSET, EVENTS ARE RETURNED IN THE THIRD +C DIMENSION FOR A PARTICULAR DATA VALUE AND LEVEL IN THE +C FIRST AND SECOND DIMENSIONS +C NEVN - INTEGER: NUMBER OF EVENTS IN STACK (MUST BE LESS THAN +C OR EQUAL TO I3) +C +C REMARKS: +C IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY ROUTINE UFBIN3, +C WHICH, ITSELF, IS CALLED ONLY BY VERIFICATION +C APPLICATION PROGRAM GRIDTOBS, WHERE IT WAS PREVIOUSLY +C AN IN-LINE SUBROUTINE. IN GENERAL, NEVN DOES NOT WORK +C PROPERLY IN OTHER APPLICATION PROGRAMS AT THIS TIME. +C +C THIS ROUTINE CALLS: BORT INVWIN LSTJPB +C THIS ROUTINE IS CALLED BY: UFBIN3 +C Should NOT be called by any +C application programs!!! +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*128 BORT_STR + DIMENSION USR(I1,I2,I3) + REAL*8 VAL,USR + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + NEVN = 0 + +C FIND THE ENCLOSING EVENT STACK DESCRIPTOR +C ----------------------------------------- + + NDRS = LSTJPB(NODE,LUN,'DRS') + IF(NDRS.LE.0) GOTO 100 + + INVN = INVWIN(NDRS,LUN,INV1,INV2) + IF(INVN.EQ.0) GOTO 900 + + NEVN = VAL(INVN,LUN) + IF(NEVN.GT.I3) GOTO 901 + +C SEARCH EACH STACK LEVEL FOR THE REQUESTED NODE AND COPY THE VALUE +C ----------------------------------------------------------------- + + N2 = INVN + 1 + + DO L=1,NEVN + N1 = N2 + N2 = N2 + VAL(N1,LUN) + DO N=N1,N2 + IF(INV(N,LUN).EQ.NODE) USR(1,1,L) = VAL(N,LUN) + ENDDO + ENDDO + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: NEVN - CAN''T FIND THE EVENT STACK!!!!!!') +901 WRITE(BORT_STR,'("BUFRLIB: NEVN - THE NO. OF EVENTS FOR THE '// + . 'REQUESTED STACK (",I3,") EXCEEDS THE VALUE OF THE 3RD DIM. OF'// + . ' THE USR ARRAY (",I3,")")') NEVN,I3 + CALL BORT(BORT_STR) + END diff --git a/src/bufr/newwin.f b/src/bufr/newwin.f new file mode 100644 index 0000000000..9fd82ede29 --- /dev/null +++ b/src/bufr/newwin.f @@ -0,0 +1,93 @@ + SUBROUTINE NEWWIN(LUN,IWIN,JWIN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NEWWIN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: GIVEN AN INDEX WITHIN THE INTERNAL JUMP/LINK TABLE WHICH +C POINTS TO THE START OF AN "RPC" WINDOW (I.E. ITERATION OF AN 8-BIT +C OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE COMPUTES +C THE ENDING INDEX OF THE WINDOW. ALTERNATIVELY, IF THE GIVEN INDEX +C POINTS TO THE START OF A "SUB" WINDOW (I.E. THE FIRST NODE OF A +C SUBSET), THE SUBROUTINE RETURNS THE INDEX OF THE LAST NODE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION +C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC +C +C USAGE: CALL NEWWIN (LUN, IWIN, JWIN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IWIN - INTEGER: STARTING INDEX OF WINDOW ITERATION +C +C OUTPUT ARGUMENT LIST: +C JWIN - INTEGER: ENDING INDEX OF WINDOW ITERATION +C +C REMARKS: +C +C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN +C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. +C +C THIS ROUTINE CALLS: BORT LSTJPB +C THIS ROUTINE IS CALLED BY: DRSTPL UFBRW +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*128 BORT_STR + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(IWIN.EQ.1) THEN + +C This is a "SUB" (subset) node, so return JWIN as pointing to +C the last value of the entire subset. + + JWIN = NVAL(LUN) + GOTO 100 + ENDIF + +C Confirm that IWIN points to an RPC node and then compute JWIN. + + NODE = INV(IWIN,LUN) + IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 + JWIN = IWIN+VAL(IWIN,LUN) + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NEWWIN - LSTJPB FOR NODE",I6,'// + . '" (LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC '// + . '(IWIN =",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nmsub.f b/src/bufr/nmsub.f new file mode 100644 index 0000000000..6d63f145fc --- /dev/null +++ b/src/bufr/nmsub.f @@ -0,0 +1,77 @@ + FUNCTION NMSUB(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NMSUB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION RETURNS THE NUMBER OF SUBSETS IN A BUFR +C MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE READMG OR EQUIVALENT. THE SUBSETS THEMSELVES DO NOT +C HAVE TO BE READ. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: NMSUB (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C NMSUB - INTEGER: NUMBER OF SUBSETS IN BUFR MESSAGE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT STATUS +C THIS ROUTINE IS CALLED BY: UFBMNS UFBPOS UFBTAB UFBTAM +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + NMSUB = 0 + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + + NMSUB = MSUB(LUN) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: NMSUB - INPUT BUFR FILE IS CLOSED, IT MUST '// + . 'BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: NMSUB - INPUT BUFR FILE IS OPEN FOR OUTPUT,'// + . ' IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: NMSUB - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') + END diff --git a/src/bufr/nmwrd.f b/src/bufr/nmwrd.f new file mode 100644 index 0000000000..277975cbe1 --- /dev/null +++ b/src/bufr/nmwrd.f @@ -0,0 +1,52 @@ + FUNCTION NMWRD(MBAY) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NMWRD +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: GIVEN AN INTEGER ARRAY CONTAINING SECTION ZERO FROM A +C BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT OF MACHINE WORDS +C (I.E. INTEGER ARRAY MEMBERS) THAT WILL HOLD THE ENTIRE MESSAGE. +C NOTE THAT THIS COUNT MAY BE GREATER THAN THE MINIMUM NUMBER +C OF WORDS REQUIRED TO HOLD THE MESSAGE. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: NMWRD (MBAY) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD ARRAY CONTAINING SECTION ZERO +C FROM A BUFR MESSAGE +C +C OUTPUT ARGUMENT LIST: +C NMWRD - INTEGER: BUFR MESSAGE LENGTH (IN MACHINE WORDS) +C +C REMARKS: +C THIS ROUTINE CALLS: IUPBS01 +C THIS ROUTINE IS CALLED BY: CNVED4 CPDXMM LMSG MSGWRT +C PADMSG STBFDX UFBMEM UFBMEX +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION MBAY(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LENM = IUPBS01(MBAY,'LENM') + IF(LENM.EQ.0) THEN + NMWRD = 0 + ELSE + NMWRD = ((LENM/8)+1)*(8/NBYTW) + ENDIF + + RETURN + END diff --git a/src/bufr/numbck.f b/src/bufr/numbck.f new file mode 100644 index 0000000000..22241d1cdf --- /dev/null +++ b/src/bufr/numbck.f @@ -0,0 +1,91 @@ + FUNCTION NUMBCK(NUMB) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NUMBCK +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION CHECKS THE INPUT CHARACTER STRING TO DETERMINE +C WHETHER IT CONTAINS A VALID FXY (DESCRIPTOR) VALUE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- SPLIT NON-ZERO RETURN INTO -1 FOR INVALID +C CHARACTER IN POSITION 1, -2 FOR INVALID +C CHARACTERS IN POSITIONS 2 THROUGH 6, -3 FOR +C INVALID CHARACTERS IN POSITIONS 2 AND 3 DUE +C TO BEING OUT OF RANGE, AND -4 FOR INVALID +C CHARACTERS IN POSITIONS 4 THROUGH 6 DUE TO +C BEING OUT OF RANGE (RETURN ONLY -1 BEFORE +C FOR ALL PROBLEMATIC CASES); UNIFIED/ +C PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2007-01-19 J. ATOR -- CLEANED UP AND SIMPLIFIED LOGIC +C +C USAGE: NUMBCK (NUMB) +C INPUT ARGUMENT LIST: +C NUMB - CHARACTER*6: FXY VALUE TO BE CHECKED +C +C OUTPUT ARGUMENT LIST: +C NUMBCK - INTEGER: INDICATOR AS TO WHETHER NUMB IS VALID: +C 0 = YES +C -1 = NO - first character ("F" value) is not '0', +C '1', '2' OR '3' +C -2 = NO - remaining characters (2-6) ("X" and "Y" +C values) are not all numeric +C -3 = NO - characters 2-3 ("X" value) are not +C between '00' and '63' +C -4 = NO - characters 4-6 ("Y" value) are not +C between '000' and '255' +C +C REMARKS: +C THIS ROUTINE CALLS: DIGIT +C THIS ROUTINE IS CALLED BY: IGETFXY RDUSDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*6 NUMB + LOGICAL DIGIT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FIRST CHARACTER OF NUMB +C --------------------------------- + + IF( LLT(NUMB(1:1),'0') .OR. LGT(NUMB(1:1),'3') ) THEN + NUMBCK = -1 + RETURN + ENDIF + +C CHECK FOR A VALID DESCRIPTOR +C ---------------------------- + + IF(DIGIT(NUMB(2:6))) THEN + READ(NUMB,'(1X,I2,I3)') IX,IY + ELSE + NUMBCK = -2 + RETURN + ENDIF + + IF(IX.LT.0 .OR. IX.GT. 63) THEN + NUMBCK = -3 + RETURN + ELSE IF(IY.LT.0 .OR. IY.GT.255) THEN + NUMBCK = -4 + RETURN + ENDIF + + NUMBCK = 0 + + RETURN + END diff --git a/src/bufr/nummtb.c b/src/bufr/nummtb.c new file mode 100644 index 0000000000..2d9b46e7ce --- /dev/null +++ b/src/bufr/nummtb.c @@ -0,0 +1,68 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NUMMTB +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS ROUTINE SEARCHES FOR AN ENTRY CORRESPONDING TO IDN +C IN THE BUFR MASTER TABLE (EITHER 'B' OR 'D', DEPENDING ON THE VALUE +C OF IDN). THE SEARCH USES BINARY SEARCH LOGIC, SO ALL OF THE ENTRIES +C IN THE TABLE MUST BE SORTED IN ASCENDING ORDER (BY FXY NUMBER) IN +C ORDER FOR THIS ROUTINE TO WORK PROPERLY. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL NUMMTB( IDN, TAB, IPT ) +C INPUT ARGUMENT LIST: +C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE TO BE +C SEARCHED FOR +C +C OUTPUT ARGUMENT LIST: +C TAB - CHARACTER: TABLE IN WHICH IDN WAS FOUND ('B' OR 'D') +C IPT - INTEGER: INDEX OF ENTRY FOR IDN IN MASTER TABLE TAB +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CADN30 CMPIA +C THIS ROUTINE IS CALLED BY: STSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#define COMMON_MSTABS +#include "bufrlib.h" + +void nummtb( f77int *idn, char *tab, f77int *ipt ) +{ + f77int *pifxyn, *pbs, nmt; + + char adn[7], errstr[129]; + + if ( *idn >= ifxy( "300000", 6 ) ) { + *tab = 'D'; + pifxyn = &mstabs.idfxyn[0]; + nmt = mstabs.nmtd; + } + else { + *tab = 'B'; + pifxyn = &mstabs.ibfxyn[0]; + nmt = mstabs.nmtb; + } + + pbs = ( f77int * ) bsearch( idn, pifxyn, ( size_t ) nmt, sizeof( f77int ), + ( int (*) ( const void *, const void * ) ) cmpia ); + if ( pbs == NULL ) { + cadn30( idn, adn, sizeof( adn ) ); + adn[6] = '\0'; + sprintf( errstr, "BUFRLIB: NUMMTB - COULD NOT FIND DESCRIPTOR " + "%s IN MASTER TABLE %c", adn, *tab ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + *ipt = pbs - pifxyn; + + return; +} diff --git a/src/bufr/numtab.f b/src/bufr/numtab.f new file mode 100644 index 0000000000..d673ab0caa --- /dev/null +++ b/src/bufr/numtab.f @@ -0,0 +1,183 @@ + SUBROUTINE NUMTAB(LUN,IDN,NEMO,TAB,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NUMTAB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE FIRST SEARCHES FOR AN INTEGER IDN, +C CONTAINING THE BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, +C WITHIN THE INTERNAL BUFR REPLICATION ARRAYS IN COMMON BLOCK /REPTAB/ +C TO SEE IF IDN IS A REPLICATION DESCRIPTOR OR A REPLICATION FACTOR +C DESCRIPTOR. IF THIS SEARCH IS UNSUCCESSFUL, IT SEACHES FOR IDN +C WITHIN THE INTERNAL BUFR TABLE D AND B ARRAYS TO SEE IF IDN IS A +C TABLE D OR TABLE B DESCRIPTOR. IF THIS SEARCH IS ALSO UNSUCCESSFUL, +C IT SEARCHES TO SEE IF IDN IS A TABLE C OPERATOR DESCRIPTOR. IF IDN +C IS FOUND IN ANY OF THESE SEARCHES, THIS SUBROUTINE RETURNS THE +C CORRESPONDING MNEMONIC AND OTHER INFORMATION FROM WITHIN EITHER THE +C INTERNAL ARRAYS FOR REPLICATION, REPLICATION FACTOR, TABLE D OR +C TABLE B DESCRIPTORS, OR ELSE FROM THE KNOWN VALUES FOR TABLE C +C DESCRIPTORS. IF IDN IS NOT FOUND, IT RETURNS WITH IRET=0. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA +C USING THE OPERATOR DESCRIPTORS (BUFR TABLE +C C) FOR CHANGING WIDTH AND CHANGING SCALE +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; CORRECTED TYPO ("IDN" WAS +C SPECIFIED AS "ID" IN CALCULATION OF IRET +C FOR TAB='C') +C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS +C 2009-04-21 J. ATOR -- USE NUMTBD +C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 AND 205 OPERATORS +C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR +C +C USAGE: CALL NUMTAB (LUN, IDN, NEMO, TAB, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) +C VALUE +C +C OUTPUT ARGUMENT LIST: +C NEMO - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN +C TAB - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE +C REPRESENTED BY IDN: +C 'B' = BUFR Table B descriptor +C 'C' = BUFR Table C descriptor +C 'D' = BUFR Table D descriptor +C 'R' = BUFR replication descriptor +C 'F' = BUFR replication factor descriptor +C IRET - INTEGER: RETURN VALUE (SEE REMARKS) +C +C REMARKS: +C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE +C RETURN VALUE OF TAB AND THE INPUT VALUE IDN, AS FOLLOWS: +C +C IF ( TAB = 'B' ) THEN +C IRET = positional index of IDN within internal BUFR Table B +C array +C ELSE IF ( TAB = 'C') THEN +C IRET = the X portion of the FXY value that is bit-wise +C represented by IDN +C ELSE IF ( TAB = 'D') THEN +C IRET = positional index of IDN within internal BUFR Table D +C array +C ELSE IF ( TAB = 'R') THEN +C IF ( IDN denoted regular (i.e. non-delayed) replication ) THEN +C IRET = ((-1)*Y), where Y is the number of replications +C ELSE ( i.e. delayed replication ) +C IRET = positional index (=I) of IDN within internal +C replication descriptor array IDNR(I,1), where: +C IRET (=I) =2 --> 16-bit delayed replication descriptor +C IRET (=I) =3 --> 8-bit delayed replication descriptor +C IRET (=I) =4 --> 8-bit delayed replication descriptor +C (stack) +C IRET (=I) =5 --> 1-bit delayed replication descriptor +C END IF +C ELSE IF ( TAB = 'F') THEN +C IRET = positional index (=I) of IDN within internal replication +C factor array IDNR(I,2), where: +C IRET (=I) =2 --> 16-bit replication factor +C IRET (=I) =3 --> 8-bit replication factor +C IRET (=I) =4 --> 8-bit replication factor +C (stack) +C IRET (=I) =5 --> 1-bit replication factor +C ELSE IF ( IRET = 0 ) THEN +C IDN was not found in internal BUFR Table B or D, nor does it +C represent a Table C operator descriptor, a replication +C descriptor, or a replication factor descriptor +C END IF +C +C +C THIS ROUTINE CALLS: ADN30 NUMTBD +C THIS ROUTINE IS CALLED BY: CKTABA NEMTBD SEQSDX STNDRD +C UFBQCP +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + +C Note that the values within the COMMON /REPTAB/ arrays were +C initialized within subroutine BFRINI. + + COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) + + CHARACTER*(*) NEMO + CHARACTER*6 ADN30,CID + CHARACTER*3 TYPS + CHARACTER*1 REPS,TAB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + NEMO = ' ' + IRET = 0 + TAB = ' ' + +C LOOK FOR A REPLICATOR OR A REPLICATION FACTOR DESCRIPTOR +C -------------------------------------------------------- + + IF(IDN.GE.IDNR(1,1) .AND. IDN.LE.IDNR(1,2)) THEN + +C Note that the above test is checking whether IDN is the bit- +C wise representation of a FXY (descriptor) value denoting F=1 +C regular (i.e. non-delayed) replication, since, as was +C initialized within subroutine BFRINI, +C IDNR(1,1) = IFXY('101000'), and IDNR(1,2) = IFXY('101255'). + + TAB = 'R' + IRET = -MOD(IDN,256) + GOTO 100 + ENDIF + + DO I=2,5 + IF(IDN.EQ.IDNR(I,1)) THEN + TAB = 'R' + IRET = I + GOTO 100 + ELSEIF(IDN.EQ.IDNR(I,2)) THEN + TAB = 'F' + IRET = I + GOTO 100 + ENDIF + ENDDO + +C LOOK FOR IDN IN TABLE B AND TABLE D +C ----------------------------------- + + CALL NUMTBD(LUN,IDN,NEMO,TAB,IRET) + IF(IRET.NE.0) GOTO 100 + +C LOOK FOR IDN IN TABLE C +C ----------------------- + + CID = ADN30(IDN,6) + IF ( (CID(1:2).EQ.'20') .AND. + . ( LGE(CID(3:3),'1') .AND. LLE(CID(3:3),'8') ) ) THEN + NEMO = CID(1:6) + READ(NEMO,'(1X,I2)') IRET + TAB = 'C' + GOTO 100 + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/numtbd.f b/src/bufr/numtbd.f new file mode 100644 index 0000000000..d0ebac2bed --- /dev/null +++ b/src/bufr/numtbd.f @@ -0,0 +1,118 @@ + SUBROUTINE NUMTBD(LUN,IDN,NEMO,TAB,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NUMTBD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE SEARCHES FOR AN INTEGER IDN, CONTAINING THE +C BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, WITHIN THE +C INTERNAL BUFR TABLE B AND D ARRAYS IN COMMON BLOCK /TABABD/. IF +C FOUND, IT RETURNS THE CORRESPONDING MNEMONIC AND OTHER INFORMATION +C FROM WITHIN THESE ARRAYS. IF IDN IS NOT FOUND, IT RETURNS WITH +C IRET=0. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C 2009-04-21 J. ATOR -- USE IFXY FOR MORE EFFICIENT SEARCHING +C +C USAGE: CALL NUMTBD (LUN, IDN, NEMO, TAB, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) +C VALUE +C +C OUTPUT ARGUMENT LIST: +C NEMO - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN +C TAB - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE +C REPRESENTED BY IDN: +C 'B' = BUFR Table B descriptor +C 'D' = BUFR Table D descriptor +C IRET - INTEGER: RETURN VALUE (SEE REMARKS) +C +C REMARKS: +C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE +C RETURN VALUE OF TAB, AS FOLLOWS: +C +C IF ( TAB = 'B' ) THEN +C IRET = positional index of IDN within internal BUFR Table B +C array +C ELSE IF ( TAB = 'D') THEN +C IRET = positional index of IDN within internal BUFR Table D +C array +C ELSE IF ( IRET = 0 ) THEN +C IDN was not found in internal BUFR Table B or D +C END IF +C +C +C THIS ROUTINE CALLS: IFXY +C THIS ROUTINE IS CALLED BY: NUMTAB RESTD STSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*(*) NEMO + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*1 TAB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + NEMO = ' ' + IRET = 0 + TAB = ' ' + + IF(IDN.GE.IFXY('300000')) THEN + +C LOOK FOR IDN IN TABLE D +C ----------------------- + + DO I=1,NTBD(LUN) + IF(IDN.EQ.IDND(I,LUN)) THEN + NEMO = TABD(I,LUN)(7:14) + TAB = 'D' + IRET = I + GOTO 100 + ENDIF + ENDDO + + ELSE + +C LOOK FOR IDN IN TABLE B +C ----------------------- + + DO I=1,NTBB(LUN) + IF(IDN.EQ.IDNB(I,LUN)) THEN + NEMO = TABB(I,LUN)(7:14) + TAB = 'B' + IRET = I + GOTO 100 + ENDIF + ENDDO + + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/nvnwin.f b/src/bufr/nvnwin.f new file mode 100644 index 0000000000..d06ce97adf --- /dev/null +++ b/src/bufr/nvnwin.f @@ -0,0 +1,109 @@ + FUNCTION NVNWIN(NODE,LUN,INV1,INV2,INVN,NMAX) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NVNWIN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION LOOKS FOR AND RETURNS ALL OCCURRENCES OF A +C SPECIFIED NODE WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER +C BOUNDED BY THE INDICES INV1 AND INV2. THE RESULTING LIST IS A +C STACK OF "EVENT" INDICES FOR THE REQUESTED NODE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR +C UNUSUAL THINGS HAPPEN +C 2009-03-23 J. ATOR -- USE 1E9 TO PREVENT OVERFLOW WHEN +C INITIALIZING INVN; USE ERRWRT +C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION +C +C USAGE: NVNWIN (NODE, LUN, INV1, INV2, INVN, NMAX) +C INPUT ARGUMENT LIST: +C NODE - INTEGER: JUMP/LINK TABLE INDEX TO LOOK FOR +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK +C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET +C BUFFER IN WHICH TO LOOK +C NMAX - INTEGER: DIMENSIONED SIZE OF INVN; USED BY THE +C FUNCTION TO ENSURE THAT IT DOES NOT OVERFLOW THE +C INVN ARRAY +C +C OUTPUT ARGUMENT LIST: +C INVN - INTEGER: ARRAY OF STACK "EVENT" INDICES FOR NODE +C NVNWIN - INTEGER: NUMBER OF INDICES RETURNED WITHIN INVN +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT +C THIS ROUTINE IS CALLED BY: UFBEVN +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET / IPRT + + CHARACTER*128 BORT_STR + DIMENSION INVN(NMAX) + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + NVNWIN = 0 + + IF(NODE.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT('BUFRLIB: NVNWIN - NODE=0, IMMEDIATE RETURN') + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ENDIF + + DO I=1,NMAX + INVN(I) = 1E9 + ENDDO + +C SEARCH BETWEEN INV1 AND INV2 +C ---------------------------- + + DO N=INV1,INV2 + IF(INV(N,LUN).EQ.NODE) THEN + IF(NVNWIN+1.GT.NMAX) GOTO 900 + NVNWIN = NVNWIN+1 + INVN(NVNWIN) = N + ENDIF + ENDDO + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NVNWIN - THE NUMBER OF EVENTS, '// + . 'NVNWIN (",I5,") EXCEEDS THE LIMIT, NMAX (",I5,")")') NVNWIN,NMAX + CALL BORT(BORT_STR) + END diff --git a/src/bufr/nwords.f b/src/bufr/nwords.f new file mode 100644 index 0000000000..b3b6481aa7 --- /dev/null +++ b/src/bufr/nwords.f @@ -0,0 +1,63 @@ + FUNCTION NWORDS(N,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NWORDS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 +C +C ABSTRACT: THIS FUNCTION ADDS UP THE COMPLETE LENGTH OF THE DELAYED +C REPLICATION SEQUENCE BEGINNING AT INDEX N OF THE DATA SUBSET. +C +C PROGRAM HISTORY LOG: +C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE) +C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION +C +C USAGE: NWORDS (N, LUN) +C INPUT ARGUMENT LIST: +C N - INTEGER: INDEX TO START OF DELAYED REPLICATION SEQUENCE +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C OUTPUT ARGUMENT LIST: +C NWORDS - INTEGER: COMPLETE LENGTH OF DELAYED REPLICATION +C SEQUENCE WITHIN DATA SUBSET +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: INVMRG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + REAL*8 VAL + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + NWORDS = 0 + + DO K=1,NINT(VAL(N,LUN)) + NWORDS = NWORDS + NINT(VAL(NWORDS+N+1,LUN)) + ENDDO + + RETURN + END diff --git a/src/bufr/nxtwin.f b/src/bufr/nxtwin.f new file mode 100644 index 0000000000..e862c17d15 --- /dev/null +++ b/src/bufr/nxtwin.f @@ -0,0 +1,96 @@ + SUBROUTINE NXTWIN(LUN,IWIN,JWIN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: NXTWIN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: GIVEN INDICES WITHIN THE INTERNAL JUMP/LINK TABLE WHICH +C POINT TO THE START AND END OF AN "RPC" WINDOW (I.E. ITERATION OF +C AN 8-BIT OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE +C COMPUTES THE START AND END INDICES OF THE NEXT WINDOW. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE); OUTPUTS MORE +C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION +C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC +C +C USAGE: CALL NXTWIN (LUN, IWIN, JWIN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IWIN - INTEGER: STARTING INDEX OF CURRENT WINDOW ITERATION +C JWIN - INTEGER: ENDING INDEX OF CURRENT WINDOW ITERATION +C +C OUTPUT ARGUMENT LIST: +C IWIN - INTEGER: STARTING INDEX OF NEXT WINDOW ITERATION +C JWIN - INTEGER: ENDING INDEX OF NEXT WINDOW ITERATION +C +C REMARKS: +C +C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN +C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. +C +C THIS ROUTINE CALLS: BORT LSTJPB +C THIS ROUTINE IS CALLED BY: UFBEVN UFBIN3 UFBRW +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*128 BORT_STR + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(JWIN.EQ.NVAL(LUN)) THEN + IWIN = 0 + GOTO 100 + ENDIF + +C FIND THE NEXT SEQUENTIAL WINDOW +C ------------------------------- + + NODE = INV(IWIN,LUN) + IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 + IF(VAL(JWIN,LUN).EQ.0) THEN + IWIN = 0 + ELSE + IWIN = JWIN + JWIN = IWIN+VAL(IWIN,LUN) + ENDIF + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: NXTWIN - LSTJPB FOR NODE",I6," '// + . '(LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN '// + . '=",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN + CALL BORT(BORT_STR) + END diff --git a/src/bufr/openbf.f b/src/bufr/openbf.f new file mode 100644 index 0000000000..d7076c1d65 --- /dev/null +++ b/src/bufr/openbf.f @@ -0,0 +1,318 @@ + SUBROUTINE OPENBF(LUNIT,IO,LUNDX) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: OPENBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE NORMALLY (I.E. EXCEPT WHEN INPUT ARGUMENT +C IO IS 'QUIET') IDENTIFIES A NEW LOGICAL UNIT TO THE BUFR ARCHIVE +C LIBRARY SOFTWARE FOR INPUT OR OUTPUT OPERATIONS. HOWEVER, THE +C FIRST TIME IT IS CALLED, IT ALSO FIGURES OUT SOME IMPORTANT +C INFORMATION ABOUT THE LOCAL MACHINE ON WHICH THE SOFTWARE IS BEING +C RUN (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE WRDLEN), AND IT +C ALSO INITIALIZES ARRAYS IN MANY BUFR ARCHIVE LIBRARY COMMON BLOCKS +C (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI). UP TO 32 +C LOGICAL UNITS CAN BE CONNECTED TO THE BUFR ARCHIVE LIBRARY SOFTWARE +C AT ANY ONE TIME. +C +C NOTE: IF IO IS PASSED IN AS 'QUIET', THEN OPENBF PERFORMS ONLY ONE +C FUNCTION - IT SIMPLY SETS THE "DEGREE OF PRINTOUT" SWITCH IPRT (IN +C COMMON BLOCK /QUIET/) TO THE VALUE OF INPUT ARGUMENT LUNDX, +C OVERRIDING ITS PREVIOUS VALUE. A DEFAULT IPRT VALUE OF 0 (I.E. +C "LIMITED PRINTOUT") IS SET DURING THE FIRST CALL TO THIS ROUTINE, +C BUT THIS OR ANY OTHER IPRT VALUE MAY BE SET AND RESET AS OFTEN AS +C DESIRED VIA SUCCESSIVE CALLS TO OPENBF WITH IO = 'QUIET'. +C IN ALL SUCH CASES, OPENBF SIMPLY (RE)SETS IPRT AND THEN RETURNS +C WITHOUT ACTUALLY OPENING ANY FILES. THE DEGREE OF PRINTOUT +C INCREASES AS IPRT INCREASES FROM "-1" TO "0" TO "1" TO "2". +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED IO='NUL' OPTION IN ORDER TO PREVENT +C LATER WRITING TO BUFR FILE IN LUNIT (WAS IN +C DECODER VERSION); ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY, UNUSUAL THINGS HAPPEN OR FOR +C INFORMATIONAL PURPOSES +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST FLAG AND IO="NODX" +C OPTION +C 2005-11-29 J. ATOR -- ADDED COMMON /MSGFMT/ AND ICHKSTR CALL +C 2009-03-23 J. ATOR -- ADDED IO='SEC3' OPTION; REMOVED CALL TO +C POSAPN; CLARIFIED COMMENTS; USE ERRWRT +C 2010-05-11 J. ATOR -- ADDED COMMON /STCODE/ +C 2012-06-18 J. ATOR -- ADDED IO='INUL' OPTION +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C USE INQUIRE TO OBTAIN THE FILENAME; +C CALL C ROUTINES OPENRB, OPENWB, AND +C OPENAB TO CONNECT BUFR FILES TO C; +C ADDED IO TYPE 'INX' TO ENABLE OPEN AND +C CLOSE FOR C FILE WITHOUT CLOSING FORTRAN +C FILE; ADD IO TYPE 'FIRST' TO SUPPORT CALLS +C TO BFRINI AND WRDLEN PRIOR TO USER RESET +C OF BUFRLIB PARAMETERS FOUND IN NEW ROUTINES +C SETBMISS AND SETBLOCK +C +C USAGE: CALL OPENBF (LUNIT, IO, LUNDX) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C (UNLESS IO IS 'QUIET', THEN A DUMMY) +C IO - CHARACTER*(*): FLAG INDICATING HOW LUNIT IS TO BE +C USED BY THE SOFTWARE: +C 'IN' = input operations with table processing +C 'INX' = input operations w/o table processing +C 'OUX' = output operations w/o table processing +C 'OUT' = output operations with table processing +C 'SEC3' = same as 'IN', except use Section 3 of input +C messages for decoding rather than dictionary +C table information from LUNDX; in this case +C LUNDX is ignored, and user must provide +C appropriate BUFR master tables within +C directory specified by a subsequent call +C to subroutine MTINFO +C 'NODX' = same as 'OUT', except don't write dictionary +C (i.e. DX) table messages to LUNIT +C 'APN' = same as 'NODX', except begin writing at end +C of file ("append") +C 'APX' = same as 'APN', except backspace before +C appending +C 'NUL' = same as 'OUT', except don't write any +C messages whatsoever to LUNIT (e.g. when +C subroutine WRITSA is to be used) +C 'INUL' = same as 'IN', except don't read any +C messages whatsoever from LUNIT (e.g. when +C subroutine READERME is to be used) +C 'QUIET' = LUNIT is ignored, this is an indicator +C that the value for IPRT in COMMON block +C /QUIET/ is being reset (see LUNDX) +C 'FIRST' = calls bfrini and wrdlen as a prelude to user +c resetting of bufrlib parameters such as +c missing value or output block type +C LUNDX - INTEGER: IF IO IS NOT 'QUIET': +C FORTRAN logical unit number containing +C dictionary table information to be used in +C reading/writing from/to LUNIT (depending +C on the case); may be set equal to LUNIT if +C dictionary table information is already +C embedded in LUNIT +C IF IO IS 'QUIET': +C Indicator for degree of printout: +C -1 = NO printout except for ABORT +C messages +C 0 = LIMITED printout (default) +C 1 = ALL warning messages are printed +C out +C 2 = ALL warning AND informational +C messages are printed out +C (Note: this does not change until OPENBF +C is again called with IO equal to +C 'QUIET') +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BFRINI BORT DXINIT ERRWRT +C POSAPX READDX STATUS WRDLEN +C WRITDX WTSTAT OPENRB OPENWB +C OPENAB +C THIS ROUTINE IS CALLED BY: COPYBF GETBMISS MESGBC MESGBF +C RDMGSB UFBINX UFBMEM UFBMEX +C UFBTAB SETBMISS SETBLOCK +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /STBFR / IOLUN(NFILES),IOMSG(NFILES) + COMMON /NULBFR/ NULL(NFILES) + COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) + COMMON /LUSHR/ LUS(NFILES) + COMMON /STCODE/ ISCODES(NFILES) + COMMON /QUIET / IPRT + + CHARACTER*(*) IO + CHARACTER*255 filename,fileacc + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*28 CPRINT(0:3) + CHARACTER*8 TAMNEM + CHARACTER*1 BSTR(4) + + DATA IFIRST/0/ + DATA CPRINT/ + . ' (only ABORTs) ', + . ' (limited - default) ', + . ' (all warnings) ', + . ' (all warning+informational)'/ + + SAVE IFIRST + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C If this is the first call to this subroutine, initialize +C IPRT in /QUIET/ as 0 (limited printout - except for abort +C messages) + + IF(IFIRST.EQ.0) IPRT = 0 + + IF(IO.EQ.'QUIET') THEN +c .... override previous IPRT value (printout indicator) + IF(LUNDX.LT.-1) LUNDX = -1 + IF(LUNDX.GT. 2) LUNDX = 2 + IF(LUNDX.GE.0) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,A,I3,A)' ) + . 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR '// + . 'CHNGED FROM',IPRT,CPRINT(IPRT+1),' TO',LUNDX,CPRINT(LUNDX+1) + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IPRT = LUNDX + ENDIF + + IF(IFIRST.EQ.0) THEN + +C If this is the first call to this subroutine, then call WRDLEN +C to figure out some important information about the local +C machine and call BFRINI to initialize some global variables. + +C NOTE: WRDLEN must be called prior to calling BFRINI! + + CALL WRDLEN + CALL BFRINI + IFIRST = 1 + ENDIF + + IF(IO.EQ.'FIRST') GOTO 100 + IF(IO.EQ.'QUIET') GOTO 100 + +C SEE IF A FILE CAN BE OPENED +C --------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(LUN.EQ.0) GOTO 900 + IF(IL .NE.0) GOTO 901 + NULL(LUN) = 0 + ISC3(LUN) = 0 + ISCODES(LUN) = 0 + LUS(LUN) = 0 + +C USE INQUIRE TO OBTAIN THE FILENAME ASSOCIATED WITH UNIT LUNIT +C ------------------------------------------------------------- + + IF (IO.NE.'NUL' .AND. IO.NE.'INUL') THEN + inquire(lunit,access=fileacc) + if(fileacc=='UNDEFINED') open(lunit) + inquire(lunit,name=filename) + filename=trim(filename)//char(0) + ENDIF + +C SET INITIAL OPEN DEFAULTS (CLEAR OUT A MSG CONTROL WORD PARTITION) +C ------------------------------------------------------------------ + + NMSG (LUN) = 0 + NSUB (LUN) = 0 + MSUB (LUN) = 0 + INODE(LUN) = 0 + IDATE(LUN) = 0 + +C DECIDE HOW TO OPEN THE FILE AND SETUP THE DICTIONARY +C ---------------------------------------------------- + + IF(IO.EQ.'IN') THEN + call openrb(lun,filename) + CALL WTSTAT(LUNIT,LUN,-1,0) + CALL READDX(LUNIT,LUN,LUNDX) + ELSE IF(IO.EQ.'INUL') THEN + CALL WTSTAT(LUNIT,LUN,-1,0) + IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) + NULL(LUN) = 1 + ELSE IF(IO.EQ.'NUL') THEN + CALL WTSTAT(LUNIT,LUN, 1,0) + IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) + NULL(LUN) = 1 + ELSE IF(IO.EQ.'INX') THEN + call openrb(lun,filename) + CALL WTSTAT(LUNIT,LUN,-1,0) + NULL(LUN) = 1 + ELSE IF(IO.EQ.'OUX') THEN + call openwb(lun,filename) + CALL WTSTAT(LUNIT,LUN, 1,0) + ELSE IF(IO.EQ.'SEC3') THEN + call openrb(lun,filename) + CALL WTSTAT(LUNIT,LUN,-1,0) + ISC3(LUN) = 1 + ELSE IF(IO.EQ.'OUT') THEN + call openwb(lun,filename) + CALL WTSTAT(LUNIT,LUN, 1,0) + CALL WRITDX(LUNIT,LUN,LUNDX) + ELSE IF(IO.EQ.'NODX') THEN + call openwb(lun,filename) + CALL WTSTAT(LUNIT,LUN, 1,0) + CALL READDX(LUNIT,LUN,LUNDX) + ELSE IF(IO.EQ.'APN' .OR. IO.EQ.'APX') THEN + call openab(lun,filename) + CALL WTSTAT(LUNIT,LUN, 1,0) + IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) + CALL POSAPX(LUNIT) + ELSE + GOTO 904 + ENDIF + + GOTO 100 + +C FILE OPENED FOR INPUT IS EMPTY - LET READMG OR READERME GIVE +C THE BAD NEWS LATER + +200 REWIND LUNIT + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) + . 'BUFRLIB: OPENBF - INPUT BUFR FILE IN UNIT ', LUNIT, + . ' IS EMPTY' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + CALL WTSTAT(LUNIT,LUN,-1,0) + +C INITIALIZE THE DICTIONARY TABLE PARTITION +C ----------------------------------------- + + CALL DXINIT(LUN,0) + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3,'// + . '" BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') + . NFILES,LUNIT + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT"'// + . ',I5," IS ALREADY OPEN")') LUNIT + CALL BORT(BORT_STR) +904 CALL BORT('BUFRLIB: OPENBF - SECOND (INPUT) ARGUMENT MUST BE'// + . ' "IN", "OUT", "NODX", "NUL", "APN", "APX", "SEC3"'// + . ' OR "QUIET"') + END diff --git a/src/bufr/openbt.f b/src/bufr/openbt.f new file mode 100644 index 0000000000..d0a377ed8b --- /dev/null +++ b/src/bufr/openbt.f @@ -0,0 +1,73 @@ + SUBROUTINE OPENBT(LUNDX,MTYP) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: OPENBT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 +C +C ABSTRACT: THIS IS A DUMMY SUBROUTINE WHICH ALWAYS RETURNS LUNDX = 0. +C OPENBT MUST BE PRESENT BECAUSE IT IS CALLED BY BUFR ARCHIVE LIBRARY +C SUBROUTINE CKTABA AS A LAST RESORT TO TRY AND FIND AN EXTERNAL +C USER-SUPPLIED BUFR DICTIONARY TABLE FILE IN CHARACTER FORMAT FROM +C WHICH A TABLE A MNEMONIC CAN BE LOCATED. IF THE APPLICATION +C PROGRAM DOES NOT HAVE AN IN-LINE VERSION OF OPENBT (OVERRIDING THIS +C ONE), THEN THE RETURNED LUNDX = 0 WILL RESULT IN CKTABA RETURNING +C WITHOUT FINDING A TABLE A MNEMONIC BECAUSE THERE IS NO LINK TO ANY +C EXTERNAL BUFR TABLES. NORMALLY, IT IS EXPECTED THAT AN IN-LINE +C VERSION OF THIS SUBROUTINE WILL ACTUALLY FIND THE APPROPRIATE +C EXTERNAL BUFR TABLE. +C +C PROGRAM HISTORY LOG: +C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); ADDED +C MORE COMPLETE DIAGNOSTIC INFO WHEN UNUSUAL +C THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL OPENBT (LUNDX, MTYP) +C INPUT ARGUMENT LIST: +C MTYP - INTEGER: DUMMY {IN AN APPLICATION PROGRAM (IN-LINE) +C THIS WOULD BE THE BUFR MESSAGE TYPE} +C +C OUTPUT ARGUMENT LIST: +C LUNDX - INTEGER: DUMMY, ALWAYS RETURNED AS ZERO {IN AN +C APPLICATION PROGRAM (IN-LINE) THIS WOULD BE THE +C FORTRAN LOGICAL UNIT NUMBER CONNECTED TO THE FILE +C CONTAINING THE EXTERNAL BUFR TABLE} +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT +C THIS ROUTINE (IN BUFR +C ARCHIVE LIBRARY): Called by CKTABA only to allow the +C BUFR ARCHIVE LIBRARY to compile, CKTABA +C and any application programs should +C always call a version of OPENBT in-line +C in the application program. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /QUIET / IPRT + + CHARACTER*128 ERRSTR + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE'// + . ' CALLED BY CKTABA OR APPL. PGM; OPENBT SHOULD BE INCL.'// + . ' IN-LINE IN APPL. PGM' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + LUNDX = 0 + + RETURN + END diff --git a/src/bufr/openmb.f b/src/bufr/openmb.f new file mode 100644 index 0000000000..68c9382ee3 --- /dev/null +++ b/src/bufr/openmb.f @@ -0,0 +1,111 @@ + SUBROUTINE OPENMB(LUNIT,SUBSET,JDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: OPENMB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE OPENS AND INITIALIZES A NEW BUFR MESSAGE +C WITHIN MEMORY. IT SHOULD ONLY BE CALLED WHEN LOGICAL UNIT LUNIT +C HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT IS SIMILAR TO BUFR +C ARCHIVE LIBRARY SUBROUTINE OPENMG, HOWEVER UNLIKE OPENMG, IT WILL +C NOT OPEN A NEW MESSAGE IF THERE IS ALREADY A BUFR MESSAGE OPEN +C WITHIN MEMORY FOR THIS LUNIT WHICH HAS THE SAME SUBSET AND JDATE +C VALUES (IN WHICH CASE IT DOES NOTHING AND RETURNS TO THE CALLING +C ROUTINE/PROGRAM). OTHERWISE, IF THERE IS ALREADY A BUFR MESSAGE +C OPEN WITHIN MEMORY FOR THIS LUNIT BUT WHICH HAS A DIFFERENT SUBSET +C OR JDATE VALUE, THEN THAT MESSAGE WILL BE CLOSED AND FLUSHED TO +C LUNIT BEFORE OPENING THE NEW ONE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL OPENMB (LUNIT, SUBSET, JDATE) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C SUBSET - CHARACTER*(*): TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING OPENED +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING OPENED, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CLOSMG I4DY MSGINI +C NEMTBA STATUS USRTPL WTSTAT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + + CHARACTER*(*) SUBSET + LOGICAL OPEN + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + +C GET SOME SUBSET PARTICULARS +C --------------------------- + +c .... Given SUBSET, returns MTYP,MSTB,INOD + CALL NEMTBA(LUN,SUBSET,MTYP,MSTB,INOD) + OPEN = IM.EQ.0.OR.INOD.NE.INODE(LUN).OR.I4DY(JDATE).NE.IDATE(LUN) + +C MAYBE(?) OPEN A NEW OR DIFFERENT TYPE OF MESSAGE +C ------------------------------------------------ + + IF(OPEN) THEN + CALL CLOSMG(LUNIT) + CALL WTSTAT(LUNIT,LUN,IL, 1) +c .... Set pos. index for new Tbl A mnem. + INODE(LUN) = INOD +c .... Set date for new message + IDATE(LUN) = I4DY(JDATE) + +C INITIALIZE THE OPEN MESSAGE +C --------------------------- + + CALL MSGINI(LUN) + CALL USRTPL(LUN,1,1) + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') + END diff --git a/src/bufr/openmg.f b/src/bufr/openmg.f new file mode 100644 index 0000000000..f585cff73e --- /dev/null +++ b/src/bufr/openmg.f @@ -0,0 +1,100 @@ + SUBROUTINE OPENMG(LUNIT,SUBSET,JDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: OPENMG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE OPENS AND INITIALIZES A NEW BUFR MESSAGE +C WITHIN MEMORY. IT SHOULD ONLY BE CALLED WHEN LOGICAL UNIT LUNIT +C HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT IS SIMILAR TO BUFR +C ARCHIVE LIBRARY SUBROUTINE OPENMB, HOWEVER UNLIKE OPENMB, IT WILL +C ALWAYS OPEN A NEW MESSAGE REGARDLESS OF THE VALUES OF SUBSET AND +C JDATE. IF THERE IS ALREADY A BUFR MESSAGE OPEN WITHIN MEMORY FOR +C THIS LUNIT, THEN THAT MESSAGE WILL BE CLOSED AND FLUSHED TO LUNIT +C BEFORE OPENING THE NEW ONE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL OPENMG (LUNIT, SUBSET, JDATE) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C SUBSET - CHARACTER*(*): TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING OPENED +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING OPENED, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CLOSMG I4DY MSGINI +C NEMTBA STATUS USRTPL WTSTAT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + + CHARACTER*(*) SUBSET + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.NE.0) CALL CLOSMG(LUNIT) + CALL WTSTAT(LUNIT,LUN,IL, 1) + +C GET SOME SUBSET PARTICULARS +C --------------------------- + +c .... Given SUBSET, returns MTYP,MSTB,INOD + CALL NEMTBA(LUN,SUBSET,MTYP,MSTB,INOD) +c .... Set pos. index for new Tbl A mnem. + INODE(LUN) = INOD +c .... Set date for new message + IDATE(LUN) = I4DY(JDATE) + +C INITIALIZE THE OPEN MESSAGE +C --------------------------- + + CALL MSGINI(LUN) + CALL USRTPL(LUN,1,1) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') + END diff --git a/src/bufr/pad.f b/src/bufr/pad.f new file mode 100644 index 0000000000..c079d2421b --- /dev/null +++ b/src/bufr/pad.f @@ -0,0 +1,92 @@ + SUBROUTINE PAD(IBAY,IBIT,IBYT,IPADB) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PAD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE FIRST PACKS THE VALUE FOR THE NUMBER OF +C BITS BEING "PADDED" (WE'LL GET TO THAT LATER), STARTING WITH BIT +C IBIT+1 AND USING EIGHT BITS IN THE PACKED ARRAY IBAY (WHICH +C REPRESENTS A SUBSET PACKED INTO IBIT BITS). THEN, STARTING WITH +C IBIT+9, IT PACKS ZEROES (I.E., "PADS") TO THE SPECIFIED BIT +C BOUNDARY (IPADB). (NOTE: IT'S THE NUMBER OF BITS PADDED HERE THAT +C WAS PACKED IN BITS IBIT+1 THROUGH IBIT+8 - THIS IS ACTUALLY A +C DELAYED REPLICATION FACTOR). IPADB MUST BE A MULTIPLE OF EIGHT AND +C REPRESENTS THE BIT BOUNDARY ON WHICH THE PACKED SUBSET IN IBAY +C SHOULD END AFTER PADDING. FOR EXAMPLE, IF IPABD IS "8", THEN THE +C NUMBER OF BITS IN IBAY ACTUALLY CONSUMED BY PACKED DATA (INCLUDING +C THE PADDING) WILL BE A MULTIPLE OF EIGHT. IF IPADB IS "16", IT +C WILL BE A MULTIPLE OF SIXTEEN. IN EITHER (OR ANY) CASE, THIS +C ENSURES THAT THE PACKED SUBSET WILL ALWAYS END ON A FULL BYTE +C BOUNDARY. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: CALL PAD (IBAY, IBIT, IBYT, IPADB) +C INPUT ARGUMENT LIST: +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET PADDED +C IBIT - INTEGER: BIT POINTER WITHIN IBAY TO START PADDING FROM +C IPADB - INTEGER: BIT BOUNDARY TO PAD TO (MUST BE A MULTIPLE OF +C 8) +C +C OUTPUT ARGUMENT LIST: +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW PADDED +C IBIT - INTEGER: NUMBER OF BITS WITHIN IBAY CONTAINING PACKED +C DATA (INCLUDING PADDING, MUST BE A MULTIPLE OF 8) +C IBYT - INTEGER: NUMBER OF BYTES WITHIN IBAY CONTAINING PACKED +C DATA (INCLUDING PADDING) (I.E., IBIT/8) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT PKB +C THIS ROUTINE IS CALLED BY: MSGUPD +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*128 BORT_STR + DIMENSION IBAY(*) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C PAD THE SUBSET TO AN IPADB BIT BOUNDARY +C ---------------------------------------- + + IPAD = IPADB - MOD(IBIT+8,IPADB) +c .... First pack the # of bits being padded (this is a delayed +c .... replication factor) + CALL PKB(IPAD,8,IBAY,IBIT) +c .... Now pad with zeroes to the byte boundary + CALL PKB(0,IPAD,IBAY,IBIT) + IBYT = IBIT/8 + + IF(MOD(IBIT,IPADB).NE.0) GOTO 900 + IF(MOD(IBIT,8 ).NE.0) GOTO 901 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: PAD - THE INPUT BIT BOUNDARY TO PAD '// + . 'TO (",I8,") IS NOT A MULTIPLE OF 8")') IPADB + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: PAD - THE NUMBER OF BITS IN A PACKED'// + . ' SUBSET AFTER PADDING (",I8,") IS NOT A MULTIPLE OF 8")') IBIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/padmsg.f b/src/bufr/padmsg.f new file mode 100644 index 0000000000..8db5b59a14 --- /dev/null +++ b/src/bufr/padmsg.f @@ -0,0 +1,63 @@ + SUBROUTINE PADMSG(MESG,LMESG,NPBYT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PADMSG +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE PADS A BUFR MESSAGE WITH ZEROED-OUT BYTES +C FROM THE END OF THE MESSAGE UP TO THE NEXT 8-BYTE BOUNDARY. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL PADMSG (MESG, LMESG, NPBYT ) +C INPUT ARGUMENT LIST: +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE +C LMESG - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MESG; +C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT +C OVERFLOW THE MESG ARRAY +C +C OUTPUT ARGUMENT LIST: +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE WITH NPBYT ZEROED-OUT BYTES APPENDED TO THE END +C NPBYT - INTEGER: NUMBER OF ZEROED-OUT BYTES APPENDED TO MESG +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IUPBS01 NMWRD PKB +C THIS ROUTINE IS CALLED BY: MSGWRT +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION MESG(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Make sure that the array is big enough to hold the additional +C byte padding that will be appended to the end of the message. + + NMW = NMWRD(MESG) + IF(NMW.GT.LMESG) GOTO 900 + +C Pad from the end of the message up to the next 8-byte boundary. + + NMB = IUPBS01(MESG,'LENM') + IBIT = NMB*8 + NPBYT = ( NMW * NBYTW ) - NMB + DO I = 1, NPBYT + CALL PKB(0,8,MESG,IBIT) + ENDDO + + RETURN +900 CALL BORT('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE '// + . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + END diff --git a/src/bufr/parstr.f b/src/bufr/parstr.f new file mode 100644 index 0000000000..65fb12ca6f --- /dev/null +++ b/src/bufr/parstr.f @@ -0,0 +1,98 @@ + SUBROUTINE PARSTR(STR,TAGS,MTAG,NTAG,SEP,LIMIT80) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PARSTR +C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE +C SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS. THE SEPARATOR FOR THE +C SUBSTRINGS IS SPECIFIED DURING INPUT, AND MULTIPLE ADJACENT +C OCCURRENCES OF THIS CHARACTER WILL BE TREATED AS A SINGLE +C OCCURRENCE WHEN THE STRING IS ACTUALLY PARSED. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- BASED UPON SUBROUTINE PARSEQ +C +C USAGE: CALL PARSTR (STR, TAGS, MTAG, NTAG, SEP, LIMIT80) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING +C MTAG - INTEGER: MAXIMUM NUMBER OF SUBSTRINGS TO BE PARSED +C FROM STRING +C SEP - CHARACTER*1: SEPARATOR CHARACTER FOR SUBSTRINGS +C LIMIT80 - LOGICAL: .TRUE. IF AN ABORT SHOULD OCCUR WHEN STR IS +C LONGER THAN 80 CHARACTERS; INCLUDED FOR HISTORICAL +C CONSISTENCY WITH OLD SUBROUTINE PARSEQ +C +C OUTPUT ARGUMENT LIST: +C TAGS - CHARACTER*(*): MTAG-WORD ARRAY OF SUBSTRINGS (FIRST +C NTAG WORDS FILLED) +C NTAG - INTEGER: NUMBER OF SUBSTRINGS RETURNED +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 +C THIS ROUTINE IS CALLED BY: GETNTBE GETTAGPR GETTBH GETVALNB +C PARUSR READLC SEQSDX SNTBBE +C UFBSEQ UFBTAB UFBTAM WRITLC +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR,TAGS(MTAG) + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*1 SEP + LOGICAL SUBSTR,LIMIT80 + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LSTR = LEN(STR) + LTAG = LEN(TAGS(1)) + IF( LIMIT80 .AND. (LSTR.GT.80) ) GOTO 900 + NTAG = 0 + NCHR = 0 + SUBSTR = .FALSE. + + DO I=1,LSTR + + IF( .NOT.SUBSTR .AND. (STR(I:I).NE.SEP) ) THEN + NTAG = NTAG+1 + IF(NTAG.GT.MTAG) GOTO 901 + TAGS(NTAG) = ' ' + ENDIF + + IF( SUBSTR .AND. (STR(I:I).EQ.SEP) ) NCHR = 0 + SUBSTR = STR(I:I).NE.SEP + + IF(SUBSTR) THEN + NCHR = NCHR+1 + IF(NCHR.GT.LTAG) GOTO 902 + TAGS(NTAG)(NCHR:NCHR) = STR(I:I) + ENDIF + + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") HAS ")') + . STR + WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') + . LSTR + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") '// + . 'CONTAINS",I4)') STR,NTAG + WRITE(BORT_STR2,'(18X,"SUBSTRINGS, EXCEEDING THE LIMIT {",I4,'// + . '" - THIRD (INPUT) ARGUMENT}")') MTAG + CALL BORT2(BORT_STR1,BORT_STR2) +902 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") ")') STR + WRITE(BORT_STR2,'(18X,"CONTAINS A PARSED SUBSTRING WITH LENGTH '// + . 'EXCEEDING THE MAXIMUM OF",I4," CHARACTERS")') LTAG + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/parusr.f b/src/bufr/parusr.f new file mode 100644 index 0000000000..1d4f78d460 --- /dev/null +++ b/src/bufr/parusr.f @@ -0,0 +1,197 @@ + SUBROUTINE PARUSR(STR,LUN,I1,IO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PARUSR +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS +C (NODES) FROM A USER-SPECIFIED CHARACTER STRING, AND SEPARATES THEM +C INTO STORE AND CONDITION NODES. INFORMATION ABOUT THE STRING +C "PIECES" (I.E., THE MNEMONICS) IS STORED IN ARRAYS IN COMMON BLOCK +C /USRSTR/. CONDITION NODES ARE SORTED IN THE ORDER EXPECTED IN THE +C INTERNAL JUMP/LINK TABLES AND SEVERAL CHECKS ARE PERFORMED ON THE +C NODES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; IMPROVED MACHINE +C PORTABILITY +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY; CHANGED CALL FROM +C BORT TO BORT2; RESPONDED TO CHANGE IN +C PARUTG (WHICH THIS ROUTINE CALLS) TO NO +C LONGER EXPECT AN ALTERNATE RETURN TO A +C STATEMENT NUMBER IN THIS ROUTINE WHICH +C CALLED BORT (BORT IS NOW CALLED IN PARUTG) +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC +C +C USAGE: CALL PARUSR (STR, LUN, I1, IO) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER +C OF BLANK-SEPARATED MNEMONICS IN STR +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUN: +C 0 = input file +C 1 = output file +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 LSTJPB PARSTR PARUTG +C THIS ROUTINE IS CALLED BY: STRING +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /ACMODE/ IAC + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*80 UST + CHARACTER*20 UTG(30) + LOGICAL BUMP + + DATA MAXUSR /30/ + DATA MAXNOD /20/ + DATA MAXCON /10/ + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + UST = STR + IF(LEN(STR).GT.80) GOTO 900 + + NCON = 0 + NNOD = 0 + +C PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS) +C ----------------------------------------------- + + CALL PARSTR(UST,UTG,MAXUSR,NTOT,' ',.TRUE.) + + DO N=1,NTOT + +C DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE +C --------------------------------------------------------- + + CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL) + IF(KON.NE.0) THEN +c .... it is a condition node + NCON = NCON+1 + IF(NCON.GT.MAXCON) GOTO 901 + NODC(NCON) = NOD + KONS(NCON) = KON + IVLS(NCON) = NINT(VAL) + ELSE +c .... it is a store node + NNOD = NNOD+1 + IF(NNOD.GT.MAXNOD) GOTO 902 + NODS(NNOD) = NOD + ENDIF + ENDDO + +C SORT CONDITION NODES IN JUMP/LINK TABLE ORDER +C --------------------------------------------- + + DO I=1,NCON + DO J=I+1,NCON + IF(NODC(I).GT.NODC(J)) THEN + NOD = NODC(I) + NODC(I) = NODC(J) + NODC(J) = NOD + + KON = KONS(I) + KONS(I) = KONS(J) + KONS(J) = KON + + VAL = IVLS(I) + IVLS(I) = IVLS(J) + IVLS(J) = VAL + ENDIF + ENDDO + ENDDO + +C CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES +C ---------------------------------------------------------------- + + BUMP = .FALSE. + + DO N=1,NCON + IF(KONS(N).EQ.5) THEN + IF(IO.EQ.0) GOTO 903 + IF(N.NE.NCON) GOTO 904 + BUMP = .TRUE. + ENDIF + ENDDO + +C CHECK STORE NODE COUNT AND ALIGNMENT +C ------------------------------------ + + IF(.NOT.BUMP .AND. NNOD.EQ.0) GOTO 905 + IF(NNOD.GT.I1) GOTO 906 + + IRPC = -1 + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + IF(IRPC.LT.0) IRPC = LSTJPB(NODS(I),LUN,'RPC') + IF(IRPC.NE.LSTJPB(NODS(I),LUN,'RPC').AND.IAC.EQ.0) GOTO 907 + ENDIF + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")') + . STR + WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') + . LEN(STR) + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION '// + . 'NODES IN INPUT STRING")') + WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') + . STR,MAXCON + CALL BORT2(BORT_STR1,BORT_STR2) +902 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '// + . 'IN INPUT STRING")') + WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') + . STR,MAXNOD + CALL BORT2(BORT_STR1,BORT_STR2) +903 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '// + . 'STRING ",A)') STR + WRITE(BORT_STR2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '// + . 'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")') + CALL BORT2(BORT_STR1,BORT_STR2) +904 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// + . 'CONTAINS")') STR + WRITE(BORT_STR2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '// + . 'NODE - THE BUMP MUST BE ON THE INNER NODE")') + CALL BORT2(BORT_STR1,BORT_STR2) +905 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")') + . STR + WRITE(BORT_STR2,'(18X,"NO STORE NODES")') + CALL BORT2(BORT_STR1,BORT_STR2) +906 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') STR + WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// + . 'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') NNOD,I1 + CALL BORT2(BORT_STR1,BORT_STR2) +907 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// + . 'CONTAINS")') STR + WRITE(BORT_STR2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'// + . ' THAN ONE REPLICATION GROUP")') + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/parutg.f b/src/bufr/parutg.f new file mode 100644 index 0000000000..27a5568dbb --- /dev/null +++ b/src/bufr/parutg.f @@ -0,0 +1,277 @@ + SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PARUTG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC) +C (UTG) THAT REPRESENTS A VALUE EITHER BEING DECODED FROM A BUFR FILE +C (IF IT IS BEING READ) OR ENCODED INTO A BUFR FILE (IF IT IS BEING +C WRITTEN). THIS SUBROUTINE FIRST CHECKS TO SEE IF THE TAG CONTAINS +C A CONDITION CHARACTER ('=', '!', '<', '>', '^' OR '#'). IF IT DOES +C NOT, NOTHING HAPPENS AT THIS POINT. IF IT DOES, THEN THE TYPE OF +C CONDITION CHARACTER IS NOTED AND THE TAG IS STRIPPED OF ALL +C CHARACTERS AT AND BEYOND THE CONDITION CHARACTER. IN EITHER EVENT, +C THE RESULTANT TAG IS CHECKED AGAINST THOSE IN THE INTERNAL JUMP/ +C LINK SUBSET TABLE (IN COMMON BLOCK /TABLES/). IF FOUND, THE NODE +C ASSOCIATED WITH THE TAG IS RETURNED (AND IT IS EITHER A "CONDITION" +C NODE OR A "STORE" NODE DEPENDING OF THE PRESENCE OR ABSENCE OF A +C CONDITION CHARACTER IN UTG). OTHERWISE THE NODE IS RETURNED AS +C ZERO. IF THE TAG REPRESENTS A CONDITION NODE, THEN THE CONDITION +C VALUE (NUMERIC CHARACTERS BEYOND THE CONDITION CHARACTER IN THE +C USER-SPECIFIED TAG INPUT HERE) IS RETURNED. +C +C AS AN EXAMPLE OF CONDITION CHARACTER USAGE, CONSIDER THE FOLLOWING +C EXAMPLE OF A CALL TO UFBINT: +C +C REAL*8 USR(4,50) +C .... +C .... +C CALL UFBINT(LUNIN,USR,4,50,IRET,'PRLC<50000 TMDB WDIR WSPD') +C +C ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING), +C THEN THE USR ARRAY NOW CONTAINS IRET LEVELS OF DATA (UP TO A MAXIMUM +C OF 50!) WHERE THE VALUE OF PRLC IS/WAS LESS THAN 50000, ALONG WITH +C THE CORRESPONDING VALUES FOR TMDB, WDIR AND WSPD AT THOSE LEVELS. +C +C AS ANOTHER EXAMPLE, CONSIDER THE FOLLOWING EXAMPLE OF A CALL TO +C READLC FOR A LONG CHARACTER STRING: +C +C CHARACTER*200 LCHR +C .... +C .... +C CALL READLC(LUNIN,LCHR,'NUMID#3') +C +C ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING), +C THEN THE LCHR STRING NOW CONTAINS THE VALUE CORRESPONDING TO THE +C THIRD OCCURRENCE OF NUMID WITHIN THE CURRENT SUBSET. +C +C VALID CONDITION CODES INCLUDE: +C '<' - LESS THAN +C '>' - GREATER THAN +C '=' - EQUAL TO +C '!' - NOT EQUAL TO +C '#' - ORDINAL IDENTIFIER FOR A PARTICULAR OCCURRENCE OF A LONG +C CHARACTER STRING +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY; +C CHANGED CALL FROM BORT TO BORT2 IN SOME +C CASES; REPLACED PREVIOUS "RETURN 1" +C STATEMENT WITH "GOTO 900" (AND CALL TO +C BORT) SINCE THE ONLY ROUTINE THAT CALLS +C THIS ROUTINE, PARUSR, USED THIS ALTERNATE +C RETURN TO GO TO A STATEMENT WHICH CALLED +C BORT +C 2005-04-22 J. ATOR -- HANDLED SITUATION WHERE INPUT TAG CONTAINS +C 1-BIT DELAYED REPLICATION, AND IMPROVED +C DOCUMENTATION +C 2009-03-23 J. ATOR -- ADDED '#' CONDITION CODE +C +C USAGE: CALL PARUTG (LUN, IO, UTG, NOD, KON, VAL) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUN: +C 0 = input file +C 1 = output file +C UTG CHARACTER*(*): USER-SUPPLIED TAG REPRESENTING A VALUE TO +C BE ENCODED/DECODED TO/FROM BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C NOD - INTEGER: POSITIONAL INDEX IN INTERNAL JUMP/LINK SUBSET +C TABLE FOR TAG +C 0 = tag not found in table +C KON - INTEGER: INDICATOR FOR TYPE OF CONDITION CHARACTER +C FOUND IN UTG: +C 0 = no condition character found (NOD is a store +C node) +C 1 = character '=' found +C 2 = character '!' found +C 3 = character '<' found +C 4 = character '>' found +C 5 = character '^' found +C 6 = character '#' found +C (1-6 means NOD is a condition node, and +C specifically 5 is a "bump" node) +C VAL - REAL: CONDITION VALUE ASSOCIATED WITH CONDITION +C CHARACTER FOUND IN UTG +C 0 = UTG does not have a condition character +C +C REMARKS: +C THIS ROUTINE CALLS: BORT BORT2 STRNUM +C THIS ROUTINE IS CALLED BY: PARUSR READLC WRITLC +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /UTGPRM/ PICKY + + CHARACTER*(*) UTG + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*20 ATAG + CHARACTER*10 TAG + CHARACTER*3 TYP,ATYP,BTYP + CHARACTER*1 COND(6) + DIMENSION BTYP(8),IOK(8) + LOGICAL PICKY + + DATA NCHK / 8/ + DATA BTYP /'SUB','SEQ','REP','RPC','RPS','DRB','DRP','DRS'/ + DATA IOK / -1 , -1 , -1 , -1 , -1 , 0 , 0 , 0 / + +C---------------------------------------------------------------------- +C For now, set PICKY (see below) to always be .FALSE. + PICKY = .FALSE. + COND(1) = '=' + COND(2) = '!' + COND(3) = '<' + COND(4) = '>' + COND(5) = '^' + COND(6) = '#' + NCOND = 6 +C---------------------------------------------------------------------- + + ATAG = ' ' + ATYP = ' ' + KON = 0 + NOD = 0 + VAL = 0 + LTG = MIN(20,LEN(UTG)) + +C PARSE UTG, SAVING INTO ATAG ONLY CHARACTERS PRIOR TO CONDITION CHAR. +C -------------------------------------------------------------------- + +C But first, take care of the special case where UTG denotes the +C short (i.e. 1-bit) delayed replication of a Table D mnemonic. +C This will prevent confusion later on since '<' and '>' are each +C also valid as condition characters. + + IF((UTG(1:1).EQ.'<').AND.(INDEX(UTG(3:),'>').NE.0)) THEN + ATAG = UTG + GO TO 1 + ENDIF + + DO I=1,LTG + IF(UTG(I:I).EQ.' ') GOTO 1 + DO J=1,NCOND + IF(UTG(I:I).EQ.COND(J)) THEN + KON = J + ICV = I+1 + GOTO 1 + ENDIF + ENDDO + ATAG(I:I) = UTG(I:I) + ENDDO + +C FIND THE NODE ASSOCIATED WITH ATAG IN THE SUBSET TABLE +C ------------------------------------------------------ + +1 INOD = INODE(LUN) + DO NOD=INOD,ISC(INOD) + IF(ATAG.EQ.TAG(NOD)) GOTO 2 + ENDDO + +C ATAG NOT FOUND IN SUBSET TABLE +C ------------------------------ + +C So what do we want to do? We could be "picky" and abort right +C here, or we could allow for the possibility that, e.g. a user +C application has been streamlined to always call UFBINT with the +C same STR, even though some of the mnemonics contained within that +C STR may not exist within the sequence definition of every +C possible type/subtype that is being written by the application. +C In such cases, by not being "picky", we could just allow BUFRLIB +C to subsequently (and quietly, if IPRT happened to be set to -1 +C in COMMON /QUIET/!) not actually store the value corresponding +C to such mnemonics, rather than loudly complaining and aborting. + + IF(KON.EQ.0 .AND. (IO.EQ.0.OR.ATAG.EQ.'NUL'.OR..NOT.PICKY)) THEN +C i.e. (if this tag does not contain any condition characters) +C .AND. +C ((either the file is open for input) .OR. +C (the tag consists of 'NUL') .OR. +C (we aren't being "picky")) + NOD = 0 + GOTO 100 + ELSE +C abort... + GOTO 900 + ENDIF + +C ATAG IS FOUND IN SUBSET TABLE, MAKE SURE IT HAS A VALID NODE TYPE +C ----------------------------------------------------------------- + +2 IF(KON.EQ.5) THEN +c .... Cond. char "^" must be assoc. with a delayed replication +c sequence (this is a "bump" node) (Note: This is obsolete but +c remains for "old" programs using the BUFR ARCHIVE LIBRARY) + IF(TYP(NOD-1).NE.'DRP' .AND. TYP(NOD-1).NE.'DRS') GOTO 901 + ELSEIF(KON.NE.6) THEN +C Allow reading (but not writing) of delayed replication factors. + ATYP = TYP(NOD) + DO I=1,NCHK + IF(ATYP.EQ.BTYP(I) .AND. IO.GT.IOK(I)) GOTO 902 + ENDDO + ENDIF + +C IF CONDITION NODE, GET CONDITION VALUE WHICH IS A NUMBER FOLLOWING IT +C --------------------------------------------------------------------- + + IF(KON.NE.0) THEN + CALL STRNUM(UTG(ICV:LTG),NUM) + IF(NUM.LT.0) GOTO 903 + VAL = NUM + ENDIF + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - TRYING TO WRITE A MNEMONIC'// + . ' (",A,") WHICH DOES NOT EXIST IN SUBSET TABLE")') ATAG + WRITE(BORT_STR2,'(18X,"(UPON INPUT, IT CONTAINED THE CONDITION '// + . 'CHARACTER ",A,")")') UTG(ICV-1:ICV-1) + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - BUMP NODE (MNEMONIC ",A,")'// + . ' MUST REFER TO A DELAYED REPLICATION SEQUENCE, HERE TYPE IS "'// + . ',A)') ATAG,TYP(NOD-1) + CALL BORT(BORT_STR1) +902 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - ILLEGAL NODE TYPE: ",A," '// + . 'FOR MNEMONIC ",A)') ATYP,ATAG + CALL BORT(BORT_STR1) +903 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - CONDITION VALUE IN '// + . 'MNEMONIC ",A," ILLEGAL BECAUSE ALL OTHER CHARACTERS IN '// + . 'MNEMONIC MUST BE NUMERIC")') UTG + CALL BORT(BORT_STR1) + END diff --git a/src/bufr/pkb.f b/src/bufr/pkb.f new file mode 100644 index 0000000000..0cdc1c9850 --- /dev/null +++ b/src/bufr/pkb.f @@ -0,0 +1,87 @@ + SUBROUTINE PKB(NVAL,NBITS,IBAY,IBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PKB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER VALUE (NVAL) INTO NBITS +C BITS OF AN INTEGER ARRAY (IBAY), STARTING WITH BIT (IBIT+1). ON +C OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS PACKED. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS +C IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C +C USAGE: CALL PKB (NVAL, NBITS, IBAY, IBIT) +C INPUT ARGUMENT LIST: +C NVAL - INTEGER: INTEGER TO BE PACKED +C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO PACK +C NVAL +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET CONTAINING +C PACKED NVAL +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER +C WHICH TO START PACKING +C +C OUTPUT ARGUMENT LIST: +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING +C PACKED NVAL +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT +C THAT WAS PACKED +C +C REMARKS: +C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE +C UPB. +C +C THIS ROUTINE CALLS: IREV +C THIS ROUTINE IS CALLED BY: ATRCPT CMSGINI CNVED4 CPYUPD +C DXMINI MSGINI MSGUPD MSGWRT +C MVB PAD PADMSG PKBS1 +C STNDRD WRCMPS WRDXTB WRTREE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION IBAY(*) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + NWD = IBIT/NBITW + 1 + NBT = MOD(IBIT,NBITW) + IVAL = NVAL + IF(ISHFT(IVAL,-NBITS).GT.0) IVAL = -1 + INT = ISHFT(IVAL,NBITW-NBITS) + INT = ISHFT(INT,-NBT) + MSK = ISHFT( -1,NBITW-NBITS) + MSK = ISHFT(MSK,-NBT) + IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT)) + IF(NBT+NBITS.GT.NBITW) THEN + +C There are less than NBITS bits remaining within the current +C word (i.e. array member) of IBAY, so store as many bits as +C will fit within the current word and then store the remaining +C bits within the next word. + + INT = ISHFT(IVAL,2*NBITW-(NBT+NBITS)) + MSK = ISHFT( -1,2*NBITW-(NBT+NBITS)) + IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT)) + ENDIF + + IBIT = IBIT + NBITS + + RETURN + END diff --git a/src/bufr/pkbs1.f b/src/bufr/pkbs1.f new file mode 100644 index 0000000000..64ec92c73d --- /dev/null +++ b/src/bufr/pkbs1.f @@ -0,0 +1,116 @@ + SUBROUTINE PKBS1(IVAL,MBAY,S1MNEM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PKBS1 +C PRGMMR: J. ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE STORES A SPECIFIED INTEGER VALUE INTO A +C SPECIFIED LOCATION WITHIN SECTION 1 OF THE BUFR MESSAGE STORED IN +C ARRAY MBAY, OVERWRITING THE VALUE PREVIOUSLY STORED AT THAT +C LOCATION. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION +C 2, 3 OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") +C MUST BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE LOCATION +C WITHIN WHICH TO STORE THE VALUE IS SPECIFIED VIA THE MNEMONIC +C S1MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2006-04-14 D. KEYSER -- ADDED OPTIONS FOR 'MTYP', 'MSBT', 'YEAR', +C 'MNTH', 'DAYS', 'HOUR', 'YCEN' AND 'CENT' +C +C USAGE: PKBS1 (IVAL, MBAY, S1MNEM) +C INPUT ARGUMENT LIST: +C IVAL - INTEGER: VALUE TO BE STORED +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR MESSAGE PRIOR TO STORING IVAL +C S1MNEM - CHARACTER*(*): MNEMONIC SPECIFYING LOCATION WHERE IVAL +C IS TO BE STORED WITHIN SECTION 1 OF BUFR MESSAGE: +C 'BMT' = BUFR MASTER TABLE +C 'OGCE' = ORIGINATING CENTER +C 'GSES' = ORIGINATING SUBCENTER +C (NOTE: THIS VALUE IS STORED ONLY IN +C BUFR EDITION 3 OR 4 MESSAGES!) +C 'USN' = UPDATE SEQUENCE NUMBER +C 'MTYP' = DATA CATEGORY +C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) +C (NOTE: THIS VALUE IS STORED ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MSBT' = DATA SUBCATEGORY (LOCAL) +C 'MTV' = VERSION NUMBER OF MASTER TABLE +C 'MTVL' = VERSION NUMBER OF LOCAL TABLES +C 'YCEN' = YEAR OF CENTURY (1-100) +C (NOTE: THIS VALUE IS STORED ONLY IN +C BUFR EDITION 2 AND 3 MESSAGES!) +C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, +C 21 FOR YEARS 2001-2100) +C (NOTE: THIS VALUE IS STORED ONLY IN +C BUFR EDITION 2 AND 3 MESSAGES!) +C 'YEAR' = YEAR (4-DIGIT) +C (NOTE: THIS VALUE IS STORED ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MNTH' = MONTH +C 'DAYS' = DAY +C 'HOUR' = HOUR +C 'MINU' = MINUTE +C 'SECO' = SECOND +C (NOTE: THIS VALUE IS STORED ONLY IN +C BUFR EDITION 4 MESSAGES!) +C +C OUTPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE WITH IVAL NOW STORED AS REQUESTED +C +C REMARKS: +C THIS ROUTINE CALLS: BORT GETS1LOC IUPBS01 PKB +C THIS ROUTINE IS CALLED BY: MINIMG MSGWRT +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MBAY(*) + + CHARACTER*(*) S1MNEM + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Note that the following call to function IUPBS01 will ensure +C that subroutine WRDLEN has been called. + + IBEN = IUPBS01(MBAY,'BEN') + +C Determine where to store the value. + + CALL GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) + IF ( (IRET.EQ.0) .AND. + . ( (S1MNEM.EQ.'USN') .OR. (S1MNEM.EQ.'BMT') .OR. + . (S1MNEM.EQ.'OGCE') .OR. (S1MNEM.EQ.'GSES') .OR. + . (S1MNEM.EQ.'MTYP') .OR. (S1MNEM.EQ.'MSBTI') .OR. + . (S1MNEM.EQ.'MSBT') .OR. (S1MNEM.EQ.'MTV') .OR. + . (S1MNEM.EQ.'MTVL') .OR. (S1MNEM.EQ.'YCEN') .OR. + . (S1MNEM.EQ.'CENT') .OR. (S1MNEM.EQ.'YEAR') .OR. + . (S1MNEM.EQ.'MNTH') .OR. (S1MNEM.EQ.'DAYS') .OR. + . (S1MNEM.EQ.'HOUR') .OR. (S1MNEM.EQ.'MINU') .OR. + . (S1MNEM.EQ.'SECO') ) ) THEN + +C Store the value. + + IBIT = (IUPBS01(MBAY,'LEN0')+ISBYT-1)*8 + CALL PKB(IVAL,IWID,MBAY,IBIT) + ELSE + GOTO 900 + ENDIF + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: PKBS1 - CANNOT OVERWRITE LOCATION '// + . 'CORRESPONDING TO MNEMONIC (",A,") WITHIN BUFR EDITION '// + . '(",I1,")")') S1MNEM, IBEN + CALL BORT(BORT_STR) + END diff --git a/src/bufr/pkc.f b/src/bufr/pkc.f new file mode 100644 index 0000000000..615894e47f --- /dev/null +++ b/src/bufr/pkc.f @@ -0,0 +1,118 @@ + SUBROUTINE PKC(CHR,NCHR,IBAY,IBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PKC +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER STRING (CHR) CONTAINING +C NCHR CHARACTERS INTO NCHR BYTES OF AN INTEGER ARRAY (IBAY), +C STARTING WITH BIT (IBIT+1). ON OUTPUT, IBIT IS UPDATED TO POINT TO +C THE LAST BIT THAT WAS PACKED. NOTE THAT THERE IS NO GUARANTEE THAT +C THE NCHR CHARACTERS WILL BE ALIGNED ON BYTE BOUNDARIES WHEN PACKED +C WITHIN IBAY. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS +C IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 +C 2004-08-18 J. ATOR -- MODIFIED TO BE COMPATIBLE WITH WRITLC +C +C USAGE: CALL PKC (CHR, NCHR, IBAY, IBIT) +C INPUT ARGUMENT LIST: +C CHR - CHARACTER*(*): CHARACTER STRING TO BE PACKED +C NCHR - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO PACK +C CHR (I.E., THE NUMBER OF CHARACTERS IN CHR) +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER +C WHICH TO START PACKING +C +C OUTPUT ARGUMENT LIST: +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING +C PACKED CHR +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT +C THAT WAS PACKED +C +C REMARKS: +C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE +C UPC. +C +C THIS ROUTINE CALLS: IPKM IREV IUPM +C THIS ROUTINE IS CALLED BY: CMSGINI DXMINI MSGINI MSGWRT +C STNDRD WRCMPS WRDXTB WRITLC +C WRTREE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*(*) CHR + CHARACTER*1 CVAL(8) + DIMENSION IBAY(*),IVAL(2) + EQUIVALENCE (CVAL,IVAL) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + LB = IORD(NBYTW) + +C LB now points to the "low-order" (i.e. least significant) byte +C within a machine word. + + IVAL(1) = 0 + NBIT = 8 + + DO I=1,NCHR + IF(I.LE.LEN(CHR)) THEN + CVAL(LB) = CHR(I:I) + ELSE + CVAL(LB) = ' ' + ENDIF + +C If the machine is EBCDIC, then translate character CVAL(LB) from +C EBCDIC to ASCII. + + IF(IASCII.EQ.0) CALL IPKM(CVAL(LB),1,IETOA(IUPM(CVAL(LB),8))) + + NWD = IBIT/NBITW + 1 + NBT = MOD(IBIT,NBITW) + INT = ISHFT(IVAL(1),NBITW-NBIT) + INT = ISHFT(INT,-NBT) + MSK = ISHFT( -1,NBITW-NBIT) + MSK = ISHFT(MSK,-NBT) + IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT)) + IF(NBT+NBIT.GT.NBITW) THEN + +C This character will not fit within the current word (i.e. +C array member) of IBAY, because there are less than 8 bits of +C space left. Store as many bits as will fit within the current +C word and then store the remaining bits within the next word. + + INT = ISHFT(IVAL(1),2*NBITW-(NBT+NBIT)) + MSK = ISHFT( -1,2*NBITW-(NBT+NBIT)) + IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT)) + ENDIF + IBIT = IBIT + NBIT + ENDDO + +C EXITS +C ----- + + RETURN + END diff --git a/src/bufr/pkftbv.f b/src/bufr/pkftbv.f new file mode 100644 index 0000000000..3c53135345 --- /dev/null +++ b/src/bufr/pkftbv.f @@ -0,0 +1,50 @@ + REAL*8 FUNCTION PKFTBV(NBITS,IBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PKFTBV +C PRGMMR: JATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS FUNCTION COMPUTES AND RETURNS THE VALUE EQUIVALENT +C TO THE SETTING OF BIT# IBIT WITHIN A FLAG TABLE OF NBITS BITS. +C IF THE COMPUTATION FAILS FOR ANY REASON, THEN THE VALUE BMISS +C (10E10) IS RETURNED. NOTE THAT THIS SUBROUTINE IS THE LOGICAL +C INVERSE OF BUFRLIB SUBROUTINE UPFTBV. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL VERSION +C +C USAGE: PKFTBV (NBITS,IBIT) +C INPUT ARGUMENT LIST: +C NBITS - INTEGER: NUMBER OF BITS IN FLAG TABLE +C IBIT - INTEGER: NUMBER OF BIT TO BE SET WITHIN FLAG TABLE +C +C OUTPUT ARGUMENT LIST: +C PKFTBV - REAL*8: VALUE EQUIVALENT TO THE SETTING OF BIT# IBIT +C WITHIN A FLAG TABLE OF NBITS BITS. +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF((NBITS.LE.0).OR.(IBIT.LE.0).OR.(IBIT.GT.NBITS)) THEN + PKFTBV = BMISS + ELSE + PKFTBV = (2.)**(NBITS-IBIT) + ENDIF + + RETURN + END diff --git a/src/bufr/pktdd.f b/src/bufr/pktdd.f new file mode 100644 index 0000000000..3fb7aac846 --- /dev/null +++ b/src/bufr/pktdd.f @@ -0,0 +1,146 @@ + SUBROUTINE PKTDD(ID,LUN,IDN,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PKTDD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE STORES INFORMATION ABOUT A "CHILD" +C MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (IN COMMON BLOCK +C /TABABD/) FOR A TABLE D SEQUENCE ("PARENT") MNEMONIC WHEN THE +C "CHILD" MNEMONIC IS CONTAINED WITHIN THE SEQUENCE REPRESENTED BY +C THE "PARENT" MNEMONIC (AS DETERMINED WITHIN BUFR ARCHIVE LIBRARY +C SUBROUTINE SEQSDX). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; ADDED MORE COMPLETE +C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL PKTDD (ID, LUN, IDN, IRET) +C INPUT ARGUMENT LIST: +C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN +C INTERNAL BUFR TABLE D ARRAY TABD(*,*) +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE +C CORRESPONDING TO CHILD MNEMONIC +C 0 = delete all information about all child +C mnemonics from within TABD(ID,LUN) +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS STORED THUS +C FAR (INCLUDING IDN) FOR THE PARENT MNEMONIC GIVEN BY +C TABD(ID,LUN) +C 0 = information was cleared from TABD(ID,LUN) +C because input IDN value was 0 +C -1 = bad counter value or maximum number of +C child mnemonics already stored for this +C parent mnemonic +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT IPKM IUPM +C THIS ROUTINE IS CALLED BY: DXINIT SEQSDX STBFDX STSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + COMMON /QUIET / IPRT + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*128 ERRSTR + CHARACTER*56 DXSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LDD = LDXD(IDXV+1)+1 + +C LDD points to the byte within TABD(ID,LUN) which contains (in +C packed integer format) a count of the number of child mnemonics +C stored thus far for this parent mnemonic. + +C ZERO THE COUNTER IF IDN IS ZERO +C ------------------------------- + + IF(IDN.EQ.0) THEN + CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,0) + IRET = 0 + GOTO 100 + ENDIF + +C UPDATE THE STORED DESCRIPTOR COUNT FOR THIS TABLE D ENTRY +C --------------------------------------------------------- + + ND = IUPM(TABD(ID,LUN)(LDD:LDD),8) + +C ND is the (unpacked) count of the number of child mnemonics +C stored thus far for this parent mnemonic. + + IF(ND.LT.0 .OR. ND.EQ.MAXCD) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + IF(ND.LT.0) THEN + WRITE ( UNIT=ERRSTR, FMT='(A,I4,A)' ) + . 'BUFRLIB: PKTDD - BAD COUNTER VALUE (=', ND, + . ') - RETURN WITH IRET = -1' + ELSE + WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,A)' ) + . 'BUFRLIB: PKTDD - MAXIMUM NUMBER OF CHILD MNEMONICS (=', + . MAXCD, ') ALREADY STORED FOR THIS PARENT - RETURN WITH ', + . 'IRET = -1' + ENDIF + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IRET = -1 + GOTO 100 + ELSE + ND = ND+1 + CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,ND) + IRET = ND + ENDIF + +C PACK AND STORE THE DESCRIPTOR +C ----------------------------- + + IDM = LDD+1 + (ND-1)*2 + +C IDM points to the starting byte within TABD(ID,LUN) at which +C the IDN value for this child mnemonic will be stored (as a +C packed integer of width = 2 bytes). + + CALL IPKM(TABD(ID,LUN)(IDM:IDM),2,IDN) + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/pkvs01.f b/src/bufr/pkvs01.f new file mode 100644 index 0000000000..0fdc6f5cca --- /dev/null +++ b/src/bufr/pkvs01.f @@ -0,0 +1,151 @@ + SUBROUTINE PKVS01(S01MNEM,IVAL) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PKVS01 +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY A VALUE TO BE WRITTEN +C INTO A SPECIFIED LOCATION WITHIN SECTION 0 OR SECTION 1 OF ALL BUFR +C MESSAGES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR +C ARCHIVE LIBRARY SUBROUTINES WHICH CREATE SUCH MESSAGES (E.G. WRITCP, +C WRITSB, COPYMG, WRITSA, ETC.). IT WILL WORK ON ANY MESSAGE ENCODED +C USING BUFR EDITION 2, 3 OR 4, AND IT CAN BE CALLED AT ANY TIME, +C INCLUDING BEFORE THE FIRST CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE +C OPENBF IF IT IS DESIRED FOR THE NEW VALUE TO ALSO BE INCLUDED IN ANY +C DX DICTIONARY TABLE MESSAGES THAT WILL BE OUTPUT BY BUFR ARCHIVE +C LIBRARY SUBROUTINE WRITDX. IN ANY CASE, THE LOCATION WITHIN WHICH +C TO STORE THE VALUE IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS +C EXPLAINED IN FURTHER DETAIL BELOW. IF MULTIPLE VALUES ARE DESIRED +C TO BE CHANGED WITHIN SECTION 0 OR SECTION 1 OF FUTURE OUTPUT +C MESSAGES, THEN EACH SUCH VALUE (AND CORRESPONDING LOCATION) +C SHOULD BE SPECIFIED USING A SEPARATE CALL TO THIS SUBROUTINE. +C NOTE THAT EACH CALL TO THIS SUBROUTINE WITH A PARTICULAR LOCATION +C SPECIFICATION WILL OVERRIDE THE EFFECT OF ANY PREVIOUS CALL WITH +C THAT SAME SPECIFICATION (OR, IN THE CASE OF THE FIRST CALL WITH A +C PARTICULAR LOCATION SPECIFICATION, IT WILL OVERRIDE THE DEFAULT +C SECTION 0 OR SECTION 1 VALUE FOR THE CORRESPONDING LOCATION!). +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2006-04-14 D. KEYSER -- UPDATED DOCBLOCK +C +C USAGE: CALL PKVS01(S01MNEM,IVAL) +C INPUT ARGUMENT LIST: +C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING LOCATION WHERE IVAL +C IS TO BE STORED WITHIN SECTION 0 OR SECTION 1 OF ALL +C FUTURE OUTPUT BUFR MESSAGES: +C 'BEN' = BUFR EDITION NUMBER +C 'BMT' = BUFR MASTER TABLE +C 'OGCE' = ORIGINATING CENTER +C 'GSES' = ORIGINATING SUBCENTER +C (NOTE: THIS VALUE WILL BE STORED ONLY IN +C BUFR EDITION 3 OR 4 MESSAGES!) +C 'USN' = UPDATE SEQUENCE NUMBER +C 'MTYP' = DATA CATEGORY +C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) +C (NOTE: THIS VALUE WILL BE STORED ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MSBT' = DATA SUBCATEGORY (LOCAL) +C 'MTV' = VERSION NUMBER OF MASTER TABLE +C 'MTVL' = VERSION NUMBER OF LOCAL TABLES +C 'YCEN' = YEAR OF CENTURY (1-100) +C (NOTE: THIS VALUE WILL BE STORED ONLY IN +C BUFR EDITION 2 AND 3 MESSAGES!) +C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, +C 21 FOR YEARS 2001-2100) +C (NOTE: THIS VALUE WILL BE STORED ONLY IN +C BUFR EDITION 2 AND 3 MESSAGES!) +C 'YEAR' = YEAR (4-DIGIT) +C (NOTE: THIS VALUE WILL BE STORED ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'MNTH' = MONTH +C 'DAYS' = DAY +C 'HOUR' = HOUR +C 'MINU' = MINUTE +C 'SECO' = SECOND +C (NOTE: THIS VALUE WILL BE STORED ONLY IN +C BUFR EDITION 4 MESSAGES!) +C 'INIT' = THIS IS A SPECIAL FLAG TO FORCE THE +C INITIALIZATION OF NS01V = 0 WITHIN +C COMMON /S01CM/; IN THIS CASE IVAL IS +C IGNORED +C (NOTE: AN APPLICATION PROGRAM SHOULD +C NEVER ITSELF NEED TO DO THIS!) +C IVAL - INTEGER: NEW VALUE FOR LOCATION POINTED TO BY S01MNEM +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: BFRINI +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) + + CHARACTER*(*) S01MNEM + + CHARACTER*128 BORT_STR + CHARACTER*8 CMNEM + + DATA IFIRST/0/ + + SAVE IFIRST + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(IFIRST.EQ.0) THEN + +C NOTE THAT WE ARE INITIALIZING NS01V=0 HERE (RATHER THAN WITHIN +C SUBROUTINE BFRINI) IN ORDER TO ALLOW FOR THE POSSIBILITY THAT A +C USER MAY CALL SUBROUTINE PKVS01 PRIOR TO CALLING SUBROUTINE +C OPENBF (WHICH ITSELF CALLS BFRINI!). HOWEVER, IF THE USER DOES +C NOT DO THIS, THEN THE "CALL PKVS01('INIT',-99)" STATEMENT WITHIN +C BFRINI WILL ENSURE THAT THE REQUIRED INITIALIZATION OF NS01V=0 +C STILL GETS DONE; OTHERWISE, WE WOULD RUN THE RISK OF NS01V BEING +C UNINITIALIZED WHEN REFERENCED LATER ON WITHIN SUBROUTINE MSGWRT! + + NS01V = 0 + IFIRST = 1 + ENDIF + + IF (S01MNEM.EQ.'INIT') THEN + RETURN + ENDIF + +C IF AN IVAL HAS ALREADY BEEN ASSIGNED FOR THIS PARTICULAR S01MNEM, +C THEN OVERWRITE THAT ENTRY IN COMMON /S01CM/ USING THE NEW IVAL. + + IF(NS01V.GT.0) THEN + DO I=1,NS01V + IF(S01MNEM.EQ.CMNEM(I)) THEN + IVMNEM(I) = IVAL + RETURN + ENDIF + ENDDO + ENDIF + +C OTHERWISE, USE THE NEXT AVAILABLE UNUSED ENTRY IN COMMON /S01CM/. + + IF(NS01V.GE.MXS01V) GOTO 900 + + NS01V = NS01V + 1 + CMNEM(NS01V) = S01MNEM + IVMNEM(NS01V) = IVAL + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: PKVS01 - CANNOT OVERWRITE MORE THAN '// + . '",I2," DIFFERENT LOCATIONS WITHIN SECTION 0 OR SECTION 1")') + . MXS01V + CALL BORT(BORT_STR) + END diff --git a/src/bufr/posapx.f b/src/bufr/posapx.f new file mode 100644 index 0000000000..85bc89770b --- /dev/null +++ b/src/bufr/posapx.f @@ -0,0 +1,96 @@ + SUBROUTINE POSAPX(LUNXX) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: POSAPX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS TO THE END OF THE FILE POINTED TO BY +C ABS(LUNXX) AND POSITIONS IT FOR APPENDING. THE FILE MUST HAVE +C ALREADY BEEN OPENED FOR OUTPUT OPERATIONS. IF LUNXX > 0, THE FILE +C IS BACKSPACED BEFORE BEING POSITIONED FOR APPEND. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE +C (DICTIONARY) MESSAGES; ADDED LUNXX < 0 +C OPTION TO SIMULATE POSAPN +C 2010-05-11 J. ATOR -- SET ISCODES TO -1 IF UNSUCCESSFUL +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR +C REMOVE UNECESSARY ERROR CHECKING LOGIC +C +C USAGE: CALL POSAPX (LUNXX) +C INPUT ARGUMENT LIST: +C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE (IF LUNXX < 0, THEN THE FILE IS NOT +C BACKSPACED BEFORE POSITIONING FOR APPEND) +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IDXMSG RDBFDX RDMSGW +C STATUS BACKBUFR +C THIS ROUTINE IS CALLED BY: OPENBF +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + DIMENSION MBAY(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LUNIT = ABS(LUNXX) + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 901 + IF(IL.LT.0) GOTO 902 + +C TRY TO READ TO THE END OF THE FILE +C ---------------------------------- + +1 CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.LT.0) RETURN + IF(IDXMSG(MBAY).EQ.1) THEN + +C This is an internal dictionary message that was generated by the +C BUFR archive library software. Backspace the file pointer and +C then read and store all such dictionary messages (they should be +C stored consecutively!) and reset the internal tables. + + call backbufr(lun) !BACKSPACE LUNIT + CALL RDBFDX(LUNIT,LUN) + + ENDIF + GOTO 1 + +C ERROR EXITS +C ----------- + +901 CALL BORT('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT'// + . ', IT MUST BE OPEN FOR OUTPUT') + END diff --git a/src/bufr/rbytes.c b/src/bufr/rbytes.c new file mode 100644 index 0000000000..7c7447aa20 --- /dev/null +++ b/src/bufr/rbytes.c @@ -0,0 +1,62 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RBYTES +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS FUNCTION READS A SPECIFIED NUMBER OF BYTES FROM +C THE SYSTEM FILE MOST RECENTLY OPENED FOR READING/INPUT VIA +C BUFR ARCHIVE LIBRARY ROUTINE COBFL. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: RBYTES( BMG, MXMB, ISLOC, NEWBYTES ) +C INPUT ARGUMENT LIST: +C MXMB - INTEGER: DIMENSIONED SIZE (IN BYTES) OF BMG; USED +C BY THE FUNCTION TO ENSURE THAT IT DOES NOT OVERFLOW +C THE BMG ARRAY +C ISLOC - INTEGER: STARTING BYTE NUMBER WITHIN BMG INTO +C WHICH TO READ THE NEXT NEWBYTES BYTES +C NEWBYTES - INTEGER: NUMBER OF BYTES TO READ FROM THE SYSTEM +C FILE MOST RECENTLY OPENED FOR READING/INPUT VIA +C BUFR ARCHIVE LIBRARY ROUTINE COBFL +C +C OUTPUT ARGUMENT LIST: +C BMG - CHARACTER*1: ARRAY CONTAINING THE NEWBYTES BYTES +C THAT WERE READ, BEGINNING AT BYTE NUMBER ISLOC +C RBYTES - INTEGER: RETURN CODE: +C 0 = normal return +C 1 = overflow of BMG array +C -1 = end-of-file encountered while reading +C -2 = I/O error encountered while reading +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: CRBMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +f77int rbytes( char *bmg, f77int *mxmb, f77int isloc, f77int newbytes ) +{ + short iret; + + if ( ( isloc + newbytes ) > *mxmb ) { + iret = 1; + } + else if ( fread( &bmg[isloc], 1, newbytes, pbf[0] ) != newbytes ) { + iret = ( feof(pbf[0]) ? -1 : -2 ); + } + else { + iret = 0; + } + + return (f77int) iret; +} diff --git a/src/bufr/rcstpl.f b/src/bufr/rcstpl.f new file mode 100644 index 0000000000..b205639f28 --- /dev/null +++ b/src/bufr/rcstpl.f @@ -0,0 +1,187 @@ + SUBROUTINE RCSTPL(LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RCSTPL +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL +C SUBSET ARRAYS IN COMMON BLOCKS /USRINT/ AND /USRBIT/. THIS IS IN +C PREPARATION FOR THE ACTUAL UNPACKING OF THE SUBSET IN BUFR ARCHIVE +C LIBRARY SUBROUTINE RDTREE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); MAXRCR (MAXIMUM +C NUMBER OF RECURSION LEVELS) INCREASED FROM +C 50 TO 100 (WAS IN VERIFICATION VERSION); +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY; COMMENTED OUT +C HARDWIRE OF VTMP TO "BMISS" (10E10) WHEN IT +C IS > 10E9 (CAUSED PROBLEMS ON SOME FOREIGN +C MACHINES) +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C +C USAGE: CALL RCSTPL (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: BORT UPBB +C THIS ROUTINE IS CALLED BY: RDTREE +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + PARAMETER (MAXRCR=100) + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) + COMMON /USRTMP/ ITMP(MAXJL,MAXRCR),VTMP(MAXJL,MAXRCR) + + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*3 TYP + DIMENSION NBMP(2,MAXRCR),NEWN(2,MAXRCR) + DIMENSION KNX(MAXRCR) + REAL*8 VAL,VTMP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C SET THE INITIAL VALUES FOR THE TEMPLATE +C --------------------------------------- + +c .... Positional index of Table A mnem. + INV(1,LUN) = INODE(LUN) + VAL(1,LUN) = 0 + NBMP(1,1) = 1 + NBMP(2,1) = 1 + NODI = INODE(LUN) + NODE = INODE(LUN) + MBMP = 1 + KNVN = 1 + NR = 0 + + DO I=1,MAXRCR + KNX(I) = 0 + ENDDO + +C SET UP THE PARAMETERS FOR A LEVEL OF RECURSION +C ---------------------------------------------- + +10 CONTINUE + + NR = NR+1 + IF(NR.GT.MAXRCR) GOTO 900 + NBMP(1,NR) = 1 + NBMP(2,NR) = MBMP + + N1 = ISEQ(NODE,1) + N2 = ISEQ(NODE,2) + IF(N1.EQ.0 ) GOTO 901 + IF(N2-N1+1.GT.MAXJL) GOTO 902 + NEWN(1,NR) = 1 + NEWN(2,NR) = N2-N1+1 + + DO N=1,NEWN(2,NR) + NN = JSEQ(N+N1-1) + ITMP(N,NR) = NN + VTMP(N,NR) = VALI(NN) + ENDDO + +C STORE NODES AT SOME RECURSION LEVEL +C ----------------------------------- + +20 DO I=NBMP(1,NR),NBMP(2,NR) + IF(KNX(NR).EQ.0000) KNX(NR) = KNVN + IF(I.GT.NBMP(1,NR)) NEWN(1,NR) = 1 + DO J=NEWN(1,NR),NEWN(2,NR) + KNVN = KNVN+1 + NODE = ITMP(J,NR) +c .... INV is positional index in internal jump/link table for packed +c subset element KNVN in MBAY + INV(KNVN,LUN) = NODE +c .... Actual unpacked subset values (VAL) are initialized here +c (numbers as BMISS) + VAL(KNVN,LUN) = VTMP(J,NR) +c .... MBIT is the bit in MBAY pointing to where the packed subset +c element KNVN begins + MBIT(KNVN) = MBIT(KNVN-1)+NBIT(KNVN-1) +c .... NBIT is the number of bits in MBAY occupied by packed subset +c element KNVN + NBIT(KNVN) = IBT(NODE) + IF(ITP(NODE).EQ.1) THEN + CALL UPBB(MBMP,NBIT(KNVN),MBIT(KNVN),MBAY(1,LUN)) + NEWN(1,NR) = J+1 + NBMP(1,NR) = I + GOTO 10 + ENDIF + ENDDO + NEW = KNVN-KNX(NR) + VAL(KNX(NR)+1,LUN) = VAL(KNX(NR)+1,LUN) + NEW + KNX(NR) = 0 + ENDDO + +C CONTINUE AT ONE RECURSION LEVEL BACK +C ------------------------------------ + + IF(NR-1.NE.0) THEN + NR = NR-1 + GOTO 20 + ENDIF + +C FINALLY STORE THE LENGTH OF (NUMBER OF ELEMENTS IN) SUBSET TEMPLATE +C ------------------------------------------------------------------- + + NVAL(LUN) = KNVN + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION '// + . 'LEVELS EXCEEDS THE LIMIT (",I3,")")') MAXRCR + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)') + . TAG(NODI) + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - TEMPLATE ARRAY OVERFLOW, '// + . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdbfdx.f b/src/bufr/rdbfdx.f new file mode 100644 index 0000000000..4c9db1e82f --- /dev/null +++ b/src/bufr/rdbfdx.f @@ -0,0 +1,157 @@ + SUBROUTINE RDBFDX(LUNIT,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDBFDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT, +C THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE +C ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO INTERNAL MEMORY ARRAYS +C IN COMMON /TABABD/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1996-12-17 J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF +C INTERNAL READS (INCREASES PORTABILITY) +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01 AND RDMSGW +C 2009-03-23 J. ATOR -- USE STNTBIA; MODIFY LOGIC TO HANDLE BUFR +C TABLE MESSAGES ENCOUNTERED ANYWHERE IN THE +C FILE (AND NOT JUST AT THE BEGINNING!) +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR +C +C USAGE: CALL RDBFDX (LUNIT, LUN) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C +C THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE RDUSDX, EXCEPT THAT RDUSDX READS FROM A FILE CONTAINING +C A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT. SEE THE +C DOCBLOCK IN RDUSDX FOR A DESCRIPTION OF THE ARRAYS THAT ARE FILLED +C IN COMMON BLOCK /TABABD/. +C +C THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE CPDXMM, EXCEPT THAT CPDXMM WRITES TO THE INTERNAL MEMORY +C ARRAYS IN COMMON BLOCK /MSGMEM/, FOR USE WITH A FILE OF BUFR +C MESSAGES THAT IS BEING READ AND STORED INTO INTERNAL MEMORY BY +C BUFR ARCHIVE LIBRARY SUBROUTINE UFBMEM. +C +C THIS ROUTINE CALLS: BORT DXINIT ERRWRT IDXMSG +C IUPBS3 MAKESTAB RDMSGW STBFDX +C BACKBUFR +C THIS ROUTINE IS CALLED BY: POSAPX READDX READMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET/ IPRT + + DIMENSION MBAY(MXMSGLD4) + + CHARACTER*128 ERRSTR + + LOGICAL DONE + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL DXINIT(LUN,0) + + ICT = 0 + DONE = .FALSE. + +C Read a complete dictionary table from LUNIT, as a set of one or +C more DX dictionary messages. + + DO WHILE ( .NOT. DONE ) + CALL RDMSGW ( LUNIT, MBAY, IER ) + IF ( IER .EQ. -1 ) THEN + +C Don't abort for an end-of-file condition, since it may be +C possible for a file to end with dictionary messages. +C Instead, backspace the file pointer and let the calling +C routine diagnose the end-of-file condition and deal with +C it as it sees fit. + + call backbufr(lun) + DONE = .TRUE. + ELSE IF ( IER .EQ. -2 ) THEN + GOTO 900 + ELSE IF ( IDXMSG(MBAY) .NE. 1 ) THEN + +C This is a non-DX dictionary message. Assume we've reached +C the end of the dictionary table, and backspace LUNIT so that +C the next read (e.g. in the calling routine) will get this +C same message. + + call backbufr(lun) + DONE = .TRUE. + ELSE IF ( IUPBS3(MBAY,'NSUB') .EQ. 0 ) THEN + +C This is a DX dictionary message, but it doesn't contain any +C actual dictionary information. Assume we've reached the end +C of the dictionary table. + + DONE = .TRUE. + ELSE + +C Store this message into COMMON /TABABD/. + + ICT = ICT + 1 + CALL STBFDX(LUN,MBAY) + ENDIF + ENDDO + + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) + . 'BUFRLIB: RDBFDX - STORED NEW DX TABLE CONSISTING OF (', + . ICT, ') MESSAGES;' + CALL ERRWRT(ERRSTR) + ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA IN '// + . 'FILE UNTIL NEXT DX TABLE IS FOUND' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + CALL MAKESTAB + + RETURN + 900 CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '// + . 'MESSAGE') + END diff --git a/src/bufr/rdcmps.f b/src/bufr/rdcmps.f new file mode 100644 index 0000000000..d7ab6a2664 --- /dev/null +++ b/src/bufr/rdcmps.f @@ -0,0 +1,197 @@ + SUBROUTINE RDCMPS(LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDCMPS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 +C +C ABSTRACT: THIS SUBROUTINE UNCOMPRESSES AND UNPACKS THE NEXT SUBSET +C FROM THE INTERNAL COMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON +C BLOCK /BITBUF/) AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL +C ARRAY VAL(*,LUN) IN COMMON BLOCK /USRINT/. +C +C PROGRAM HISTORY LOG: +C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR +C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY RDCMPS +C WOULD NOT RECOGNIZE COMPRESSED DELAYED +C REPLICATION AS A LEGITIMATE DATA STRUCTURE +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION +C 2004-08-18 J. ATOR -- INITIALIZE CVAL TO EMPTY BEFORE CALLING UPC; +C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS +C THE SAME FOR ALL SUBSETS IN A MESSAGE; +C MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- PREVENT OVERFLOW OF CVAL AND CREF FOR +C STRINGS LONGER THAN 8 CHARACTERS +C 2012-03-02 J. ATOR -- USE FUNCTION UPS +C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN +C CORRESPONDING CHARACTER FIELD HAS ALL BITS +C SET TO 1 +C +C USAGE: CALL RDCMPS (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ICBFMS UPB UPC +C UPS USRTPL +C THIS ROUTINE IS CALLED BY: READSB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST) + + CHARACTER*128 BORT_STR + CHARACTER*10 TAG,CRTAG + CHARACTER*8 CREF,CVAL + CHARACTER*3 TYP + EQUIVALENCE (CVAL,RVAL) + REAL*8 VAL,RVAL,UPS + +C----------------------------------------------------------------------- +C Statement function to compute BUFR "missing value" for field +C of length LBIT bits (all bits "on"): + + LPS(LBIT) = MAX(2**(LBIT)-1,1) +C----------------------------------------------------------------------- + +C SETUP THE SUBSET TEMPLATE +C ------------------------- + + CALL USRTPL(LUN,1,1) + +C UNCOMPRESS A SUBSET INTO THE VAL ARRAY ACCORDING TO TABLE B +C ----------------------------------------------------------- + + NSBS = NSUB(LUN) + +C Note that we are going to unpack the (NSBS)th subset from within +C the current BUFR message. + + IBIT = MBYT(LUN) + NRST = 0 + +C Loop through each element of the subset. + + N = 0 + +1 DO N=N+1,NVAL(LUN) + NODE = INV(N,LUN) + NBIT = IBT(NODE) + ITYP = ITP(NODE) + +C In each of the following code blocks, the "local reference value" +C for the element is determined first, followed by the 6-bit value +C which indicates how many bits are used to store the increment +C (i.e. offset) from this "local reference value". Then, we jump +C ahead to where this increment is stored for this particular subset, +C unpack it, and add it to the "local reference value" to determine +C the final uncompressed value for this element from this subset. + +C Note that, if an element has the same final uncompressed value +C for each subset in the message, then the encoding rules for BUFR +C compression dictate that the "local reference value" will be equal +C to this value, the 6-bit increment length indicator will have +C a value of zero, and the actual increments themselves will be +C omitted from the message. + + IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN + +C This is a numeric element. + + CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) + CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) + JBIT = IBIT + LINC*(NSBS-1) + CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) + IF(NINC.EQ.LPS(LINC)) THEN + IVAL = LPS(NBIT) + ELSE + IVAL = LREF+NINC + ENDIF + IF(ITYP.EQ.1) THEN + CALL USRTPL(LUN,N,IVAL) + GOTO 1 + ENDIF + IF(IVAL.LT.LPS(NBIT)) VAL(N,LUN) = UPS(IVAL,NODE) + IBIT = IBIT + LINC*MSUB(LUN) + ELSEIF(ITYP.EQ.3) THEN + +C This is a character element. If there are more than 8 +C characters, then only the first 8 will be unpacked by this +C routine, and a separate subsequent call to BUFR archive library +C subroutine READLC will be required to unpack the remainder of +C the string. In this case, pointers will be saved within +C COMMON /RLCCMN/ for later use within READLC. + +C Unpack the local reference value. + + LELM = NBIT/8 + NCHR = MIN(8,LELM) + IBSV = IBIT + CREF = ' ' + CALL UPC(CREF,NCHR,MBAY(1,LUN),IBIT) + IF(LELM.GT.8) THEN + IBIT = IBIT + (LELM-8)*8 + NRST = NRST + 1 + IF(NRST.GT.MXRST) GOTO 900 + CRTAG(NRST) = TAG(NODE) + ENDIF + +C Unpack the increment length indicator. For character elements, +C this length is in bytes rather than bits. + + CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) + IF(LINC.EQ.0) THEN + IF(LELM.GT.8) THEN + IRNCH(NRST) = LELM + IRBIT(NRST) = IBSV + ENDIF + CVAL = CREF + ELSE + JBIT = IBIT + LINC*(NSBS-1)*8 + IF(LELM.GT.8) THEN + IRNCH(NRST) = LINC + IRBIT(NRST) = JBIT + ENDIF + NCHR = MIN(8,LINC) + CVAL = ' ' + CALL UPC(CVAL,NCHR,MBAY(1,LUN),JBIT) + ENDIF + IF (LELM.LE.8 .AND. ICBFMS(CVAL,NCHR).NE.0) THEN + VAL(N,LUN) = BMISS + ELSE + VAL(N,LUN) = RVAL + ENDIF + IBIT = IBIT + 8*LINC*MSUB(LUN) + ENDIF + ENDDO + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER ' // + . 'STRINGS EXCEEDS THE LIMIT (",I4,")")') MXRST + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdmemm.f b/src/bufr/rdmemm.f new file mode 100644 index 0000000000..216ac6612b --- /dev/null +++ b/src/bufr/rdmemm.f @@ -0,0 +1,227 @@ + SUBROUTINE RDMEMM(IMSG,SUBSET,JDATE,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMEMM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM +C INTERNAL MEMORY (ARRAY MSGS IN COMMON BLOCK /MSGMEM/) INTO A +C MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS +C IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMM EXCEPT IT DOES +C NOT ADVANCE THE VALUE OF IMSG PRIOR TO RETURNING TO CALLING +C PROGRAM. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI); THE MAXIMUM +C NUMBER OF BYTES REQUIRED TO STORE ALL +C MESSAGES INTERNALLY WAS INCREASED FROM 4 +C MBYTES TO 8 MBYTES +C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD +C BEEN REPLICATED IN THIS AND OTHER READ +C ROUTINES AND CONSOLIDATED IT INTO A NEW +C ROUTINE CKTABA, CALLED HERE, WHICH IS +C ENHANCED TO ALLOW COMPRESSED AND STANDARD +C BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE +C LENGTH INCREASED FROM 10,000 TO 20,000 +C BYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE +C (DICTIONARY) MESSAGES; USE ERRWRT +C +C +C USAGE: CALL RDMEMM (IMSG, SUBSET, JDATE, IRET) +C INPUT ARGUMENT LIST: +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C STORAGE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = IMSG is either zero or greater than the +C number of messages in memory +C +C REMARKS: +C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT CKTABA DXINIT ERRWRT +C MAKESTAB STATUS STBFDX WTSTAT +C THIS ROUTINE IS CALLED BY: READMM UFBMMS UFBRMS UFBTAM +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + COMMON /QUIET / IPRT + + DIMENSION MSGDX(MXMSGLD4) + + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*8 SUBSET + + LOGICAL KNOWN + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE MESSAGE REQUEST AND FILE STATUS +C ----------------------------------------- + + CALL STATUS(MUNIT,LUN,IL,IM) + CALL WTSTAT(MUNIT,LUN,IL, 1) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IRET = 0 + + IF(IMSG.EQ.0 .OR.IMSG.GT.MSGP(0)) THEN + CALL WTSTAT(MUNIT,LUN,IL,0) + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + IF(IMSG.EQ.0) THEN + ERRSTR = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE '// + . 'NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH '// + . 'IRET = -1' + ELSE + WRITE ( UNIT=ERRSTR, FMT='(A,I6,A,I6,A)' ) + . 'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', IMSG, + . ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (', + . MSGP(0), '), RETURN WITH IRET = -1' + ENDIF + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IRET = -1 + GOTO 100 + ENDIF + +C ENSURE THAT THE PROPER DICTIONARY TABLE IS IN SCOPE +C --------------------------------------------------- + +C Determine which table applies to this message. + + KNOWN = .FALSE. + JJ = NDXTS + DO WHILE ((.NOT.KNOWN).AND.(JJ.GE.1)) + IF (IPMSGS(JJ).LE.IMSG) THEN + KNOWN = .TRUE. + ELSE + JJ = JJ - 1 + ENDIF + ENDDO + IF (.NOT.KNOWN) GOTO 902 + +C Is this table the one that is currently in scope? + + IF (JJ.NE.LDXTS) THEN + +C No, so reset the software to use the proper table. + + IF(IPRT.GE.2) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A,I6)' ) + . 'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', JJ, + . ' INSTEAD OF DX TABLE #', LDXTS, + . ' FOR REQUESTED MESSAGE #', IMSG + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + CALL DXINIT(LUN,0) + +C Store each of the DX dictionary messages which constitute +C this table. + + DO II = IFDXTS(JJ), (IFDXTS(JJ)+ICDXTS(JJ)-1) + IF (II.EQ.NDXM) THEN + NWRD = LDXM - IPDXM(II) + 1 + ELSE + NWRD = IPDXM(II+1) - IPDXM(II) + ENDIF + DO KK = 1, NWRD + MSGDX(KK) = MDX(IPDXM(II)+KK-1) + ENDDO + CALL STBFDX(LUN,MSGDX) + ENDDO + +C Rebuild the internal jump/link table. + + CALL MAKESTAB + LDXTS = JJ + ENDIF + +C READ MEMORY MESSAGE NUMBER IMSG INTO A MESSAGE BUFFER +C ----------------------------------------------------- + + IPTR = MSGP(IMSG) + IF(IMSG.LT.MSGP(0)) LPTR = MSGP(IMSG+1)-IPTR + IF(IMSG.EQ.MSGP(0)) LPTR = MLAST-IPTR+1 + IPTR = IPTR-1 + + DO I=1,LPTR + MBAY(I,LUN) = MSGS(IPTR+I) + ENDDO + +C PARSE THE MESSAGE SECTION CONTENTS +C ---------------------------------- + + CALL CKTABA(LUN,SUBSET,JDATE,JRET) + NMSG(LUN) = IMSG + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 WRITE(BORT_STR,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR '// + . 'REQUESTED MESSAGE #",I5)') IMSG + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdmems.f b/src/bufr/rdmems.f new file mode 100644 index 0000000000..5acf7b96f7 --- /dev/null +++ b/src/bufr/rdmems.f @@ -0,0 +1,165 @@ + SUBROUTINE RDMEMS(ISUB,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMEMS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET FROM A BUFR +C MESSAGE IN INTERNAL MEMORY (ARRAY MBAY IN COMMON BLOCK /BITBUF/) +C INTO INTERNAL SUBSET ARRAYS BASED ON THE SUBSET NUMBER IN THE +C MESSAGE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL RDMEMS (ISUB, IRET) +C INPUT ARGUMENT LIST: +C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR +C MESSAGE +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = ISUB is greater than the number of subsets +C in memory +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT IUPB READSB +C STATUS +C THIS ROUTINE IS CALLED BY: UFBMMS UFBMNS UFBRMS +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + CHARACTER*128 BORT_STR,ERRSTR + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /UNPTYP/ MSGUNP(NFILES) + COMMON /QUIET / IPRT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE MESSAGE REQUEST AND FILE STATUS +C ----------------------------------------- + + CALL STATUS(MUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(NSUB(LUN).NE.0) GOTO 903 + + IF(ISUB.GT.MSUB(LUN)) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I5,A,A,I5,A)' ) + . 'BUFRLIB: RDMEMS - REQ. SUBSET #', ISUB, ' (= 1st INPUT ', + . 'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', MSUB(LUN), ')' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('RETURN WITH IRET = -1') + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IRET = -1 + GOTO 100 + ENDIF + + MBYM = MBYT(LUN) + NBYT = 0 + +C POSITION TO SUBSET NUMBER ISUB IN MEMORY MESSAGE +C ------------------------------------------------ + + IF(MSGUNP(LUN).EQ.0) THEN + NSUB(LUN) = ISUB-1 + DO I=1,ISUB-1 + MBYT(LUN) = MBYT(LUN) + IUPB(MBAY(1,LUN),MBYT(LUN)+1,16) + ENDDO + ELSEIF(MSGUNP(LUN).EQ.1) THEN +c .... message with "standard" Section 3 + DO I=1,ISUB-1 + CALL READSB(MUNIT,IRET) + ENDDO + ELSEIF(MSGUNP(LUN).EQ.2) THEN +c .... compressed message + NSUB(LUN) = ISUB-1 + ENDIF + +C NOW READ SUBSET NUMBER ISUB FROM MEMORY MESSAGE +C ----------------------------------------------- + + CALL READSB(MUNIT,IRET) +c .... This should have already been accounted for with stmt. 902 or +c IRET = -1 above + IF(IRET.NE.0) GOTO 904 + +C RESET SUBSET POINTER BACK TO ZERO (BEGINNING OF MESSAGE) AND RETURN +C ------------------------------------------------------------------- + + MBYT(LUN) = MBYM + NSUB(LUN) = 0 + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: RDMEMS - A MEMORY MESSAGE MUST BE OPEN IN '// + . 'INPUT BUFR FILE, NONE ARE') +903 WRITE(BORT_STR,'("BUFRLIB: RDMEMS - UPON ENTRY, SUBSET POINTER '// + . 'IN MEMORY MESSAGE IS NOT AT BEGINNING (",I3," SUBSETS HAVE '// + . 'BEEN READ, SHOULD BE 0)")') NSUB(LUN) + CALL BORT(BORT_STR) +904 CALL BORT('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED '// + . 'WITH IRET = -1 (EITHER MEMORY MESSAGE NOT OPEN OR ALL '// + . 'SUBSETS IN MESSAGE READ') + END diff --git a/src/bufr/rdmgsb.f b/src/bufr/rdmgsb.f new file mode 100644 index 0000000000..7d896edb9f --- /dev/null +++ b/src/bufr/rdmgsb.f @@ -0,0 +1,112 @@ + SUBROUTINE RDMGSB(LUNIT,IMSG,ISUB) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMGSB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE IN LOGICAL UNIT LUNIT FOR +C INPUT OPERATIONS, THEN READS A PARTICULAR SUBSET INTO INTERNAL +C SUBSET ARRAYS FROM A PARTICULAR BUFR MESSAGE IN A MESSAGE BUFFER. +C THIS IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE MESSAGE +C NUMBER IN THE BUFR FILE. THE MESSAGE NUMBER DOES NOT INCLUDE THE +C DICTIONARY MESSAGES AT THE BEGINNING OF THE FILE. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION +C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION +C VERSION AT ONE TIME AND THEN REMOVED) +C 2003-11-04 D. KEYSER -- INCORPORATED INTO "UNIFIED" BUFR ARCHIVE +C LIBRARY; UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- MODIFY LOGIC TO HANDLE BUFR TABLE MESSAGES +C ENCOUNTERED ANYWHERE IN THE FILE (AND NOT +C JUST AT THE BEGINNING!) +C +C USAGE: CALL RDMGSB (LUNIT, IMSG, ISUB) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER TO READ IN +C BUFR FILE +C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR +C MESSAGE +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT OPENBF READMG READSB +C STATUS UPB +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C OPEN THE FILE AND SKIP TO MESSAGE # IMSG +C ---------------------------------------- + + CALL OPENBF(LUNIT,'IN',LUNIT) + CALL STATUS(LUNIT,LUN,IL,IM) + +C Note that we need to use subroutine READMG to actually read in all +C of the messages (including the first (IMSG-1) messages!), just in +C case there are any embedded dictionary messages in the file. + + DO I=1,IMSG + CALL READMG(LUNIT,SUBSET,JDATE,IRET) + IF(IRET.LT.0) GOTO 901 + ENDDO + +C POSITION AT SUBSET # ISUB +C ------------------------- + + DO I=1,ISUB-1 + IF(NSUB(LUN).GT.MSUB(LUN)) GOTO 902 + IBIT = MBYT(LUN)*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + MBYT(LUN) = MBYT(LUN) + NBYT + NSUB(LUN) = NSUB(LUN) + 1 + ENDDO + + CALL READSB(LUNIT,IRET) + IF(IRET.NE.0) GOTO 902 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - ERROR READING MESSAGE '// + . '(RECORD) NUMBER",I5," IN INPUT BUFR FILE CONNECTED TO UNIT",'// + . 'I4)') I,LUNIT + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - HIT END OF FILE BEFORE '// + . 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO'// + . ' UNIT",I4)') IMSG,LUNIT + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - ALL SUBSETS READ BEFORE '// + . 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR '// + . 'FILE CONNECTED TO UNIT",I4)') ISUB,IMSG,LUNIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdmsgb.f b/src/bufr/rdmsgb.f new file mode 100644 index 0000000000..08207c157b --- /dev/null +++ b/src/bufr/rdmsgb.f @@ -0,0 +1,103 @@ + SUBROUTINE RDMSGB(LUNIT,MESG,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMSGB +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL +C UNIT LUNIT AS AN ARRAY OF BYTES, WHICH ARE THEN TRANSFERRED TO +C AN ARRAY OF INTEGER WORDS FOR OUTPUT. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2009-03-23 D. KEYSER -- CALLS BORT IN CASE OF MESG OVERFLOW +C +C USAGE: CALL RDMSGB (LUNIT, MESG, IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C MESG - *-WORD ARRAY CONTAINING BUFR MESSAGE READ FROM LUNIT +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = end-of-file encountered while reading +C from LUNIT +C -2 = I/O error encountered while reading +C from LUNIT +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ICHKSTR IUPBS01 LMSG +C THIS ROUTINE IS CALLED BY: None +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION MESG(*) + + CHARACTER*128 BORT_STR + CHARACTER*8 SEC0 + CHARACTER*1 CBAY(8*MXMSGLD4) + DIMENSION JBAY(MXMSGLD4) + + EQUIVALENCE (CBAY(1),JBAY(1),SEC0) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + SEC0 = ' ' + +C Read Section 0 from the next message in the file. + + READ(LUNIT,END=100,ERR=200) SEC0 + +C Confirm that the first 4 bytes contain 'BUFR' encoded in +C CCITT IA5 (i.e. ASCII). + + IF(ICHKSTR('BUFR',CBAY,4).NE.0) GOTO 200 + +C Check the length of the next message to make sure it will fit +C within the output array. + + LNMSG = LMSG(SEC0) + IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 900 + +C Read the rest of the message as an array of bytes. + + READ(LUNIT,END=100,ERR=200) (CBAY(I),I=9,IUPBS01(JBAY,'LENM')) + +C Transfer the message to the output array. + + DO I=1,LNMSG + MESG(I) = JBAY(I) + ENDDO + +C EXITS +C ----- + + IRET = 0 + RETURN + +100 IRET = -1 + RETURN + +200 IRET = -2 + RETURN + +900 WRITE(BORT_STR,'("BUFRLIB: RDMSGB - INPUT BUFR MESSAGE LENGTH (", + . I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")') + . LNMSG*NBYTW,MXMSGL + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdmsgw.f b/src/bufr/rdmsgw.f new file mode 100644 index 0000000000..01a168cdcb --- /dev/null +++ b/src/bufr/rdmsgw.f @@ -0,0 +1,68 @@ + SUBROUTINE RDMSGW(LUNIT,MESG,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMSGW +C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL +C UNIT LUNIT AS AN ARRAY OF INTEGER WORDS. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR +C 2009-03-23 D. KEYSER -- CALL BORT IN CASE OF MESG OVERFLOW +C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE; +C USE C ROUTINE CRDBUFR TO OBTAIN BUFR +C MESSAGE; REMOVE CODE WHICH CHECKS SEC0 +C AND MESSAGE LENGTH AS CRDBUFR DOES THAT +C +C USAGE: CALL RDMSGW (LUNIT, MESG, IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C MESG - *-WORD ARRAY CONTAINING BUFR MESSAGE READ FROM LUNIT +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = end-of-file encountered while reading +C from LUNIT +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: CRDBUFR ERRWRT STATUS +C THIS ROUTINE IS CALLED BY: COPYBF CPDXMM DATEBF DUMPBF +C MESGBC MESGBF POSAPX RDBFDX +C READMG UFBMEM UFBMEX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION MESG(*) + + CHARACTER*128 BORT_STR + integer crdbufr + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) +1 IRET=CRDBUFR(LUN,MESG,MXMSGL) + IF(IRET.eq.-3) + + CALL ERRWRT('BUFRLIB: RDMSGW - SKIPPING OVERLARGE MESSAGE') + IF(IRET.eq.-2) + + CALL ERRWRT('BUFRLIB: RDMSGW - SKIPPING CORRUPTED MESSAGE') + if(iret.lt.-1) goto 1 + RETURN + END + diff --git a/src/bufr/rdmtbb.f b/src/bufr/rdmtbb.f new file mode 100644 index 0000000000..66110140ca --- /dev/null +++ b/src/bufr/rdmtbb.f @@ -0,0 +1,130 @@ + SUBROUTINE RDMTBB ( LUNSTB, LUNLTB, MXMTBB, + . IMT, IMTV, IOGCE, ILTV, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMTBB +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE READS MASTER TABLE B INFORMATION FROM TWO +C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES AND THEN +C MERGES IT INTO A UNIFIED SET OF MASTER TABLE B ARRAYS FOR OUTPUT. +C EACH OF THE TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN +C ASCENDING ORDER WITH RESPECT TO THE FXY NUMBERS. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL RDMTBB ( LUNSTB, LUNLTB, MXMTBB, IMT, IMTV, IOGCE, +C ILTV, NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, +C CMUNIT, CMMNEM, CMDSC, CMELEM ) +C INPUT ARGUMENT LIST: +C LUNSTB - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING STANDARD TABLE B INFORMATION +C LUNLTB - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING LOCAL TABLE B INFORMATION +C MXMTBB - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN +C MERGED MASTER TABLE B ARRAYS; THIS SHOULD BE THE SAME +C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN +C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE +C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS +C +C OUTPUT ARGUMENT LIST: +C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE +C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) +C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM +C STANDARD ASCII FILE +C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE +C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM +C LOCAL ASCII FILE +C NMTBB - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE B +C ARRAYS +C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE +C REPRESENTATIONS OF FXY NUMBERS +C CMSCL(*) - CHARACTER*4: MERGED ARRAY CONTAINING SCALE FACTORS +C CMSREF(*)- CHARACTER*12: MERGED ARRAY CONTAINING REFERENCE VALUES +C CMBW(*) - CHARACTER*4: MERGED ARRAY CONTAINING BIT WIDTHS +C CMUNIT(*)- CHARACTER*14: MERGED ARRAY CONTAINING UNITS +C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS +C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES +C CMELEM(*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH +C SNTBBE WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*200 STLINE, LTLINE + CHARACTER*128 BORT_STR + CHARACTER*120 CMELEM(*) + CHARACTER*14 CMUNIT(*) + CHARACTER*12 CMSREF(*) + CHARACTER*8 CMMNEM(*) + CHARACTER*6 CMATCH, ADN30 + CHARACTER*4 CMSCL(*), CMBW(*), CMDSC(*) + + INTEGER IMFXYN(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Call WRDLEN to initialize some important information about the +C local machine, just in case it hasn't already been called. + + CALL WRDLEN + +C Read and parse the header lines of both files. + + CALL GETTBH ( LUNSTB, LUNLTB, 'B', IMT, IMTV, IOGCE, ILTV ) + +C Read through the remainder of both files, merging the +C contents into a unified set of master Table B arrays. + + NMTBB = 0 + CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) + CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) + DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) + IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN + IF ( ISFXYN .EQ. ILFXYN ) THEN + CMATCH = ADN30 ( ISFXYN, 6 ) + GOTO 900 + ELSE IF ( ISFXYN .LT. ILFXYN ) THEN + CALL SNTBBE ( ISFXYN, STLINE, MXMTBB, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) + ELSE + CALL SNTBBE ( ILFXYN, LTLINE, MXMTBB, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) + ENDIF + ELSE IF ( IERS .EQ. 0 ) THEN + CALL SNTBBE ( ISFXYN, STLINE, MXMTBB, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) + ELSE IF ( IERL .EQ. 0 ) THEN + CALL SNTBBE ( ILFXYN, LTLINE, MXMTBB, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) + ENDIF + ENDDO + + RETURN + 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBB - STANDARD AND LOCAL'// + . ' TABLE B FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') + . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdmtbd.f b/src/bufr/rdmtbd.f new file mode 100644 index 0000000000..db41c20f8e --- /dev/null +++ b/src/bufr/rdmtbd.f @@ -0,0 +1,138 @@ + SUBROUTINE RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, + . IMT, IMTV, IOGCE, ILTV, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDMTBD +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE READS MASTER TABLE D INFORMATION FROM TWO +C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES AND THEN +C MERGES IT INTO A UNIFIED SET OF MASTER TABLE D ARRAYS FOR OUTPUT. +C EACH OF THE TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN +C ASCENDING ORDER WITH RESPECT TO THE FXY NUMBERS. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, +C IMT, IMTV, IOGCE, ILTV, +C NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, +C NMELEM, IEFXYN, CEELEM ) +C INPUT ARGUMENT LIST: +C LUNSTD - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING STANDARD TABLE D INFORMATION +C LUNLTD - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING LOCAL TABLE D INFORMATION +C MXMTBD - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN +C MERGED MASTER TABLE D ARRAYS; THIS SHOULD BE THE SAME +C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN +C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE +C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS +C MXELEM - INTEGER: MAXIMUM NUMBER OF ELEMENTS TO BE STORED PER +C ENTRY WITHIN THE MERGED MASTER TABLE D ARRAYS; THIS +C SHOULD BE THE SAME NUMBER AS WAS USED TO DIMENSION THE +C OUTPUT ARRAYS IN THE CALLING PROGRAM, AND IT IS USED +C BY THIS SUBROUTINE TO ENSURE THAT IT DOESN'T OVERFLOW +C THESE ARRAYS +C +C OUTPUT ARGUMENT LIST: +C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE +C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) +C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM +C STANDARD ASCII FILE +C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE +C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM +C LOCAL ASCII FILE +C NMTBD - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE D +C ARRAYS +C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE +C REPRESENTATIONS OF FXY NUMBERS (I.E. SEQUENCE +C DESCRIPTORS) +C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS +C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES +C CMSEQ(*) - CHARACTER*120: MERGED ARRAY CONTAINING SEQUENCE NAMES +C NMELEM(*)- INTEGER: MERGED ARRAY CONTAINING NUMBER OF ELEMENTS +C STORED FOR EACH ENTRY +C IEFXYN(*,*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE +C REPRESENTATIONS OF ELEMENT FXY NUMBERS +C CEELEM(*,*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH +C SNTBDE WRDLEN +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*200 STLINE, LTLINE + CHARACTER*128 BORT_STR + CHARACTER*120 CMSEQ(*), CEELEM(MXMTBD,MXELEM) + CHARACTER*8 CMMNEM(*) + CHARACTER*6 CMATCH, ADN30 + CHARACTER*4 CMDSC(*) + + INTEGER IMFXYN(*), NMELEM(*), + . IEFXYN(MXMTBD,MXELEM) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Call WRDLEN to initialize some important information about the +C local machine, just in case it hasn't already been called. + + CALL WRDLEN + +C Read and parse the header lines of both files. + + CALL GETTBH ( LUNSTD, LUNLTD, 'D', IMT, IMTV, IOGCE, ILTV ) + +C Read through the remainder of both files, merging the +C contents into a unified set of master Table D arrays. + + NMTBD = 0 + CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) + CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) + DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) + IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN + IF ( ISFXYN .EQ. ILFXYN ) THEN + CMATCH = ADN30 ( ISFXYN, 6 ) + GOTO 900 + ELSE IF ( ISFXYN .LT. ILFXYN ) THEN + CALL SNTBDE ( LUNSTD, ISFXYN, STLINE, MXMTBD, MXELEM, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) + ELSE + CALL SNTBDE ( LUNLTD, ILFXYN, LTLINE, MXMTBD, MXELEM, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) + ENDIF + ELSE IF ( IERS .EQ. 0 ) THEN + CALL SNTBDE ( LUNSTD, ISFXYN, STLINE, MXMTBD, MXELEM, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) + ELSE IF ( IERL .EQ. 0 ) THEN + CALL SNTBDE ( LUNLTD, ILFXYN, LTLINE, MXMTBD, MXELEM, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) + ENDIF + ENDDO + + RETURN + 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBD - STANDARD AND LOCAL'// + . ' TABLE D FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') + . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rdtree.f b/src/bufr/rdtree.f new file mode 100644 index 0000000000..1747bb74fb --- /dev/null +++ b/src/bufr/rdtree.f @@ -0,0 +1,137 @@ + SUBROUTINE RDTREE(LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDTREE +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL +C UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/) +C AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL ARRAY VAL(*,LUN) +C IN COMMON BLOCK /USRINT/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 J. WOOLLEN -- FIXED A BUG WHICH COULD ONLY OCCUR WHEN +C THE LAST ELEMENT IN A SUBSET IS A CHARACTER +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER +C THAN 8 CHARACTERS +C 2012-03-02 J. ATOR -- USE FUNCTION UPS +C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN +C CORRESPONDING CHARACTER FIELD HAS ALL BITS +C SET TO 1 +C +C USAGE: CALL RDTREE (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: RCSTPL ICBFMS UPBB UPC +C UPS +C THIS ROUTINE IS CALLED BY: READSB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) + + CHARACTER*10 TAG + CHARACTER*8 CVAL + CHARACTER*3 TYP + DIMENSION IVAL(MAXSS) + EQUIVALENCE (CVAL,RVAL) + REAL*8 VAL,RVAL,UPS + +C----------------------------------------------------------------------- +C Statement function to compute BUFR "missing value" for field +C of length IBT(NODE)) bits (all bits "on"): + + MPS(NODE) = 2**(IBT(NODE))-1 +C----------------------------------------------------------------------- + +C CYCLE THROUGH A SUBSET SETTING UP THE TEMPLATE +C ---------------------------------------------- + + MBIT(1) = IBIT + NBIT(1) = 0 + CALL RCSTPL(LUN) + +C UNPACK A SUBSET INTO THE USER ARRAY IVAL +C ---------------------------------------- + + DO N=1,NVAL(LUN) + CALL UPBB(IVAL(N),NBIT(N),MBIT(N),MBAY(1,LUN)) + ENDDO + +C LOOP THROUGH EACH ELEMENT OF THE SUBSET, CONVERTING THE UNPACKED +C VALUES TO THE PROPER TYPES +C ---------------------------------------------------------------- + + DO N=1,NVAL(LUN) + NODE = INV(N,LUN) + IF(ITP(NODE).EQ.1) THEN + +C The unpacked value is a delayed descriptor replication factor. + + VAL(N,LUN) = IVAL(N) + ELSEIF(ITP(NODE).EQ.2) THEN + +C The unpacked value is a real. + + IF(IVAL(N).LT.MPS(NODE)) VAL(N,LUN) = UPS(IVAL(N),NODE) + ELSEIF(ITP(NODE).EQ.3) THEN + +C The value is a character string, so unpack it using an +C equivalenced REAL*8 value. Note that a maximum of 8 characters +C will be unpacked here, so a separate subsequent call to BUFR +C archive library subroutine READLC will be needed to fully +C unpack any string longer than 8 characters. + + CVAL = ' ' + KBIT = MBIT(N) + NBT = MIN(8,NBIT(N)/8) + CALL UPC(CVAL,NBT,MBAY(1,LUN),KBIT) + IF (NBIT(N).LE.64 .AND. ICBFMS(CVAL,NBT).NE.0) THEN + VAL(N,LUN) = BMISS + ELSE + VAL(N,LUN) = RVAL + ENDIF + ENDIF + ENDDO + + IBIT = NBIT(NVAL(LUN))+MBIT(NVAL(LUN)) + + RETURN + END diff --git a/src/bufr/rdusdx.f b/src/bufr/rdusdx.f new file mode 100644 index 0000000000..97ec31906e --- /dev/null +++ b/src/bufr/rdusdx.f @@ -0,0 +1,273 @@ + SUBROUTINE RDUSDX(LUNDX,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RDUSDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS AND PARSES A FILE CONTAINING A USER- +C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT, AND THEN STORES +C THIS INFORMATION INTO INTERNAL ARRAYS IN COMMON BLOCK /TABABD/ (SEE +C REMARKS FOR CONTENTS OF INTERNAL ARRAYS). THIS SUBROUTINE PERFORMS +C A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE RDBFDX, +C EXECPT THAT RDBFDX READS THE BUFR TABLE DIRECTLY FROM MESSAGES AT +C BEGINNING OF AN INPUT BUFR FILE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1996-12-17 J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF +C INTERNAL READS (INCREASES PORTABILITY) +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 +C 2006-04-14 D. KEYSER -- ABORTS IF A USER-DEFINED MESSAGE TYPE "011" +C IS READ (EITHER DIRECTLY FROM A TABLE A +C MNEMONIC OR FROM THE "Y" VALUE OF A TABLE A +C FXY SEQUENCE DESCRIPTOR), MESSAGE TYPE +C "011" IS RESERVED FOR DICTIONARY MESSAGES +C (PREVIOUSLY WOULD STORE DATA WITH MESSAGE +C TYPE "011" BUT SUCH MESSAGES WOULD BE +C SKIPPED OVER WHEN READ) +C 2007-01-19 J. ATOR -- MODIFIED IN RESPONSE TO NUMBCK CHANGES +C 2009-03-23 J. ATOR -- INCREASE SIZE OF BORT_STR2; USE STNTBIA +C 2013-01-08 J. WHITING -- ADD ERR= OPTION TO READ STATEMENT +C +C USAGE: CALL RDUSDX (LUNDX, LUN) +C INPUT ARGUMENT LIST: +C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER- +C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C INPUT FILES: +C UNIT "LUNDX" - USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER +C FORMAT +C +C REMARKS: +C CONTENTS OF INTERNAL ARRAYS WRITTEN INTO COMMON BLOCK /TABABD/: +C +C For Table A entries: +C NTBA(LUN) - INTEGER: Number of Table A entries (note that +C NTBA(0) contains the maximum number of such +C entries as set within subroutine BFRINI) +C TABA(N,LUN) - CHARACTER*128: Table A entries, where +C N=1,2,3,...,NTBA(LUN) +C IDNA(N,LUN,1) - INTEGER: Message type corresponding to +C TABA(N,LUN) +C IDNA(N,LUN,2) - INTEGER: Message subtype corresponding to +C TABA(N,LUN) +C +C For Table B entries: +C NTBB(LUN) - INTEGER: Number of Table B entries (note that +C NTBB(0) contains the maximum number of such +C entries as set within subroutine BFRINI) +C TABB(N,LUN) - CHARACTER*128: Table B entries, where +C N=1,2,3,...,NTBB(LUN) +C IDNB(N,LUN) - INTEGER: Bit-wise representation of the FXY +C value corresponding to TABB(N,LUN) +C +C For Table D entries: +C NTBD(LUN) - INTEGER: Number of Table D entries (note that +C NTBD(0) contains the maximum number of such +C entries as set within subroutine BFRINI) +C TABD(N,LUN) - CHARACTER*600: Table D entries, where +C N=1,2,3,...,NTBD(LUN) +C IDND(N,LUN) - INTEGER: Bit-wise representation of the FXY +C value corresponding to TABD(N,LUN) +C +C +C THIS ROUTINE CALLS: BORT2 DXINIT ELEMDX IGETNTBI +C MAKESTAB NEMOCK NUMBCK SEQSDX +C STNTBI STNTBIA +C THIS ROUTINE IS CALLED BY: CKTABA READDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR1 + CHARACTER*156 BORT_STR2 + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*80 CARD + CHARACTER*8 NEMO + CHARACTER*6 NUMB,NMB2 + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C INITIALIZE THE DICTIONARY TABLE CONTROL WORD PARTITION ARRAYS +C WITH APRIORI TABLE B AND D ENTRIES +C -------------------------------------------------------------- + + CALL DXINIT(LUN,1) + REWIND LUNDX + +C READ USER CARDS UNTIL THERE ARE NO MORE +C --------------------------------------- + +1 READ(LUNDX,'(A80)',END=200,ERR=200) CARD + +C REREAD IF NOT A DEFINITION CARD +C ------------------------------- + +c .... This is a comment line + IF(CARD(1: 1).EQ. '*') GOTO 1 +c .... This is a separation line + IF(CARD(3:10).EQ.'--------') GOTO 1 +c .... This is a blank line + IF(CARD(3:10).EQ.' ') GOTO 1 +c .... This is a header line + IF(CARD(3:10).EQ.'MNEMONIC') GOTO 1 +c .... This is a header line + IF(CARD(3:10).EQ.'TABLE D') GOTO 1 +c .... This is a header line + IF(CARD(3:10).EQ.'TABLE B') GOTO 1 + +C PARSE A DESCRIPTOR DEFINITION CARD +C ---------------------------------- + + IF(CARD(12:12).EQ.'|' .AND. CARD(21:21).EQ.'|') THEN + +c .... NEMO is the 8-character mnemonic name + NEMO = CARD(3:10) + IRET=NEMOCK(NEMO) + IF(IRET.EQ.-1) GOTO 900 + IF(IRET.EQ.-2) GOTO 901 + +c .... NUMB is the 6-character FXY value corresponding to NEMO + NUMB = CARD(14:19) + NMB2 = NUMB + IF(NMB2(1:1).EQ.'A') NMB2(1:1) = '3' + IRET=NUMBCK(NMB2) + IF(IRET.EQ.-1) GOTO 902 + IF(IRET.EQ.-2) GOTO 903 + IF(IRET.EQ.-3) GOTO 904 + IF(IRET.EQ.-4) GOTO 905 + +C TABLE A DESCRIPTOR FOUND +C ------------------------ + + IF(NUMB(1:1).EQ.'A') THEN + N = IGETNTBI ( LUN, 'A' ) + CALL STNTBIA ( N, LUN, NUMB, NEMO, CARD(23:) ) + IF ( IDNA(N,LUN,1) .EQ. 11 ) GOTO 906 +c .... Replace "A" with "3" so Table D descriptor will be found in +c .... card as well (see below) + NUMB(1:1) = '3' + ENDIF + +C TABLE B DESCRIPTOR FOUND +C ------------------------ + + IF(NUMB(1:1).EQ.'0') THEN + CALL STNTBI ( IGETNTBI(LUN,'B'), LUN, NUMB, NEMO, CARD(23:) ) + GOTO 1 + ENDIF + +C TABLE D DESCRIPTOR FOUND +C ------------------------ + + IF(NUMB(1:1).EQ.'3') THEN + CALL STNTBI ( IGETNTBI(LUN,'D'), LUN, NUMB, NEMO, CARD(23:) ) + GOTO 1 + ENDIF + +c .... First character of NUMB is not 'A', '0' or '3' + GOTO 902 + + ENDIF + +C PARSE A SEQUENCE DEFINITION CARD +C -------------------------------- + + IF(CARD(12:12).EQ.'|' .AND. CARD(19:19).NE.'|') THEN + CALL SEQSDX(CARD,LUN) + GOTO 1 + ENDIF + +C PARSE AN ELEMENT DEFINITION CARD +C -------------------------------- + + IF(CARD(12:12).EQ.'|' .AND. CARD(19:19).EQ.'|') THEN + CALL ELEMDX(CARD,LUN) + GOTO 1 + ENDIF + +C CAN'T FIGURE OUT WHAT KIND OF CARD IT IS +C ---------------------------------------- + + GOTO 907 + +C NORMAL ENDING +C ------------- + +200 CALL MAKESTAB + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY IS NOT'// + . ' BETWEEN 1 AND 8 CHARACTERS")') NEMO + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY HAS '// + . 'INVALID CHARACTERS")') NEMO + CALL BORT2(BORT_STR1,BORT_STR2) +902 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// + . 'DICTIONARY HAS AN INVALID FIRST CHARACTER (F VALUE) - MUST BE'// + . ' A, 0 OR 3")') NUMB + CALL BORT2(BORT_STR1,BORT_STR2) +903 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// + . 'DICTIONARY HAS NON-NUMERIC VALUES IN CHARACTERS 2-6 (X AND Y '// + . 'VALUES)")') NUMB + CALL BORT2(BORT_STR1,BORT_STR2) +904 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// + . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 2-3 (X VALUE) - '// + . 'MUST BE BETWEEN 00 AND 63")') NUMB + CALL BORT2(BORT_STR1,BORT_STR2) +905 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// + . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 4-6 (Y VALUE) - '// + . 'MUST BE BETWEEN 000 AND 255")') NUMB + CALL BORT2(BORT_STR1,BORT_STR2) +906 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"USER-DEFINED MESSAGE TYPE ""011"" IS '// + . 'RESERVED FOR DICTIONARY MESSAGES")') + CALL BORT2(BORT_STR1,BORT_STR2) +907 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"THIS CARD HAS A BAD FORMAT - IT IS NOT '// + . 'RECOGNIZED BY THIS SUBROUTINE")') + CALL BORT2(BORT_STR1,BORT_STR2) + + END diff --git a/src/bufr/readdx.f b/src/bufr/readdx.f new file mode 100644 index 0000000000..3cda41b506 --- /dev/null +++ b/src/bufr/readdx.f @@ -0,0 +1,147 @@ + SUBROUTINE READDX(LUNIT,LUN,LUNDX) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE GENERATES INTERNAL ARRAYS CONTAINING BUFR +C DICTIONARY TABLES WHICH ARE NEEDED TO READ, WRITE, INITIALIZE OR +C APPEND A BUFR FILE. THE INFORMATION USED TO CREATE THE INTERNAL +C DICTIONARY TABLE ARRAYS (IN COMMON BLOCK /TABABD/) AND THE +C DICTIONARY MESSAGE CONTROL WORD PARTITION ARRAYS (IN COMMON BLOCK +C /MSGCWD/) (WHICH ARE ALWAYS THEN ASSOCIATED WITH THE BUFR FILE IN +C LUNIT) MAY COME FROM AN EXTERNAL, USER-SUPPLIED, BUFR DICTIONARY +C TABLE FILE IN CHARACTER FORMAT (I.E., A BUFR MNEMONIC TABLE), FROM +C THE BUFR FILE BEING ACTED UPON (IN WHICH CASE THE FILE MUST BE +C OPENED FOR INPUT PROCESSING AND POSITIONED AT A DICTIONARY TABLE +C MESSAGE SOMEWHERE IN THE FILE), OR FROM ANOTHER CURRENTLY OPENED +C AND DEFINED BUFR FILE. IN THIS LATTER CASE, THE BUFR FILE WOULD +C MOST LIKELY BE OPENED FOR INPUT, HOWEVER THERE IS NOTHING +C PREVENTING THE USE OF A FILE OPEN FOR OUTPUT AS LONG AS IT IS +C ASSOCIATED WITH INTERNAL DICTIONARY ARRAYS THAT CAN BE USED. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR FOR INFORMATIONAL +C PURPOSES +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL READDX (LUNIT, LUN, LUNDX) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C BEING READ, WRITTEN, INITIALIZED OR APPENDED +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) +C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING +C DICTIONARY TABLE INFORMATION TO BE USED IN READING/ +C WRITING FROM/TO LUNIT (DEPENDING ON THE CASE); MAY BE +C SET EQUAL TO LUNIT IF DICTIONARY TABLE INFORMATION IS +C ALREADY EMBEDDED IN LUNIT (BUT ONLY IF LUNIT IS BEING +C READ) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CPBFDX ERRWRT MAKESTAB +C RDBFDX RDUSDX STATUS +C THIS ROUTINE IS CALLED BY: OPENBF WRITDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /QUIET/ IPRT + + CHARACTER*128 ERRSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C GET THE BUFR STATUS OF UNIT LUNDX +C --------------------------------- + + CALL STATUS(LUNDX,LUD,ILDX,IMDX) + +C READ A DICTIONARY TABLE FROM THE INDICATED SOURCE +C ------------------------------------------------- + + IF (LUNIT.EQ.LUNDX) THEN +c .... Source is input BUFR file in LUNIT + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A)' ) + . 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', + . 'INPUT BUFR FILE IN UNIT ', LUNDX, ' INTO INTERNAL ARRAYS' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + CALL ERRWRT(' ') + ENDIF + REWIND LUNIT + CALL RDBFDX(LUNIT,LUN) + ELSEIF(ILDX.EQ.-1) THEN +c .... Source is input BUFR file in LUNDX +c .... BUFR file in LUNIT may be input or output + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A,A,I3)' ) + . 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', + . 'ARRAYS ASSOC. W/ INPUT UNIT ', LUNDX, ' TO THOSE ASSOC. ', + . 'W/ UNIT ', LUNIT + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + CALL ERRWRT(' ') + ENDIF + CALL CPBFDX(LUD,LUN) + CALL MAKESTAB + ELSEIF(ILDX.EQ.1) THEN +c .... Source is output BUFR file in LUNDX +c .... BUFR file in LUNIT may be input or output + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A,A,I3)' ) + . 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', + . 'ARRAYS ASSOC. W/ OUTPUT UNIT ', LUNDX, ' TO THOSE ASSOC. ', + . 'W/ UNIT ', LUNIT + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + CALL ERRWRT(' ') + ENDIF + CALL CPBFDX(LUD,LUN) + CALL MAKESTAB + ELSEIF(ILDX.EQ.0) THEN +c .... Source is user-supplied character table in LUNDX +c .... BUFR file in LUNIT may be input or output + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A)' ) + . 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', + . 'USER-SUPPLIED TEXT FILE IN UNIT ', LUNDX, + . ' INTO INTERNAL ARRAYS' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') + CALL ERRWRT(' ') + ENDIF + REWIND LUNDX + CALL RDUSDX(LUNDX,LUN) + ELSE + GOTO 900 + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: READDX - CANNOT DETERMINE SOURCE OF '// + . 'INPUT DICTIONARY TABLE') + END diff --git a/src/bufr/readerme.f b/src/bufr/readerme.f new file mode 100644 index 0000000000..c9186394db --- /dev/null +++ b/src/bufr/readerme.f @@ -0,0 +1,230 @@ + SUBROUTINE READERME(MESG,LUNIT,SUBSET,JDATE,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READERME +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1995-06-28 +C +C ABSTRACT: THIS SUBROUTINE READS INFORMATION FROM A BUFR DATA MESSAGE +C ALREADY IN MEMORY, PASSED IN AS AN INPUT ARGUMENT. IT IS SIMILAR +C TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG EXCEPT, INSTEAD OF +C READING BUFR MESSAGES DIRECTLY FROM A BUFR FILE THAT IS PHYSICALLY +C STORED ON THE LOCAL SYSTEM AND INTERFACED TO THE SOFTWARE VIA A +C LOGICAL UNIT NUMBER, IT READS BUFR MESSAGES DIRECTLY FROM A MEMORY +C ARRAY WITHIN THE APPLICATION PROGRAM ITSELF. THIS PROVIDES USERS +C WITH GREATER FLEXIBILITY FROM AN INPUT/OUTPUT PERSPECTIVE. +C READERME CAN BE USED IN ANY CONTEXT IN WHICH READMG MIGHT OTHERWISE +C BE USED. IF THIS MESSAGE IS NOT A BUFR MESSAGE, THEN AN +C APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1995-06-28 J. WOOLLEN -- ORIGINAL AUTHOR (FOR ERS DATA) +C 1997-07-29 J. WOOLLEN -- MODIFIED TO PROCESS GOES SOUNDINGS FROM +C NESDIS +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT; IMPROVED MACHINE PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI); INCREASED THE +C MAXIMUM NUMBER OF POSSIBLE DESCRIPTORS IN A +C SUBSET FROM 1000 TO 3000 +C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD +C BEEN REPLICATED IN THIS AND OTHER READ +C ROUTINES AND CONSOLIDATED IT INTO A NEW +C ROUTINE CKTABA, CALLED HERE, WHICH IS +C ENHANCED TO ALLOW COMPRESSED AND STANDARD +C BUFR MESSAGES TO BE READ (ROUTINE UNCMPS, +C WHICH HAD BEEN CALLED BY THIS AND OTHER +C ROUTINES IS NOW OBSOLETE AND HAS BEEN +C REMOVED FROM THE BUFRLIB; MAXIMUM MESSAGE +C LENGTH INCREASED FROM 10,000 TO 20,000 +C BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY +C TO EBCDIC MACHINES; MAXIMUM MESSAGE LENGTH +C INCREASED FROM 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE ICHKSTR +C 2009-03-23 D. KEYSER -- CALL BORT IN CASE OF MBAY OVERFLOW +C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; +C ADD LOGIC TO PROCESS DICTIONARY MESSAGES +C 2012-06-07 J. ATOR -- DON'T RESPOND TO DX TABLE MESSAGES IF +C SECTION 3 DECODING IS BEING USED +C +C USAGE: CALL READERME (MESG, LUNIT, SUBSET, JDATE, IRET) +C INPUT ARGUMENT LIST: +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = unrecognized Table A message type +C 11 = this is a BUFR table (dictionary) message +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CKTABA DXINIT ERRWRT +C ICHKSTR IDXMSG IUPBS3 LMSG +C MAKESTAB READS3 STATUS STBFDX +C WTSTAT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /QUIET/ IPRT + + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*8 SUBSET,SEC0,TAMNEM + CHARACTER*1 CEC0(8) + + DIMENSION MESG(*),IEC0(2) + + DIMENSION IDRDM(NFILES) + + LOGICAL ENDTBL + + EQUIVALENCE (SEC0,IEC0,CEC0) + + DATA IDRDM/NFILES*0/ + SAVE IDRDM + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + CALL WTSTAT(LUNIT,LUN,IL, 1) + +C COPY THE INPUT MESSAGE INTO THE INTERNAL MESSAGE BUFFER +C ------------------------------------------------------- + + IEC0(1) = MESG(1) + IEC0(2) = MESG(2) + LNMSG = LMSG(SEC0) + IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 902 + DO I=1,LNMSG + MBAY(I,LUN) = MESG(I) + ENDDO + +C Confirm that the first 4 bytes of SEC0 contain 'BUFR' encoded in +C CCITT IA5 (i.e. ASCII). + + IF(ICHKSTR('BUFR',CEC0,4).NE.0) GOTO 903 + +C PARSE THE MESSAGE SECTION CONTENTS +C ---------------------------------- + + IF(ISC3(LUN).NE.0) CALL READS3(LUN) + + CALL CKTABA(LUN,SUBSET,JDATE,IRET) + + IF(ISC3(LUN).NE.0) RETURN + +C CHECK FOR A DX DICTIONARY MESSAGE +C --------------------------------- + +C A new DX dictionary table can be passed in as a consecutive set of +C DX dictionary messages. Each message should be passed in one at a +C time, via input argument MESG during consecutive calls to this +C subroutine, and will be processed as a single dictionary table up +C until the next message is passed in which either contains no data +C subsets or else is a non-DX dictionary message. + + ENDTBL = .FALSE. + + IF(IDXMSG(MBAY(1,LUN)).EQ.1) THEN + +C This is a DX dictionary message that was generated by the +C BUFRLIB archive library software. + + IF(IUPBS3(MBAY(1,LUN),'NSUB').EQ.0) THEN + +C But it doesn't contain any actual dictionary information, so +C assume we've reached the end of the dictionary table. + + IF(IDRDM(LUN).GT.0) THEN + ENDTBL = .TRUE. + ENDIF + ELSE + IF(IDRDM(LUN).EQ.0) THEN + +C This is the first DX dictionary message that is part of a +C new dictionary table. + + CALL DXINIT(LUN,0) + ENDIF + IDRDM(LUN) = IDRDM(LUN) + 1 + CALL STBFDX(LUN,MBAY(1,LUN)) + ENDIF + ELSE IF(IDRDM(LUN).GT.0) THEN + +C This is the first non-DX dictionary message received following a +C string of DX dictionary messages, so assume we've reached the +C end of the dictionary table. + + ENDTBL = .TRUE. + ENDIF + + IF(ENDTBL) THEN + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) + . 'BUFRLIB: READERME - STORED NEW DX TABLE CONSISTING OF (', + . IDRDM(LUN), ') MESSAGES;' + CALL ERRWRT(ERRSTR) + ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA '// + . 'MESSAGES UNTIL NEXT DX TABLE IS PASSED IN' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + IDRDM(LUN) = 0 + CALL MAKESTAB + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 WRITE(BORT_STR,'("BUFRLIB: READERME - INPUT BUFR MESSAGE LENGTH", + . 1X,I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")') + . LNMSG*NBYTW,MXMSGL + CALL BORT(BORT_STR) +903 CALL BORT('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD'// + . ' NOT "BUFR", DOES NOT CONTAIN BUFR DATA') + END diff --git a/src/bufr/readlc.f b/src/bufr/readlc.f new file mode 100644 index 0000000000..2799cce5ec --- /dev/null +++ b/src/bufr/readlc.f @@ -0,0 +1,193 @@ + SUBROUTINE READLC(LUNIT,CHR,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READLC +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER DATA ELEMENT ASSOCIATED +C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER +C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS DESIGNED TO BE USED +C TO RETURN CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT +C BYTES. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY OR UNUSUAL THINGS HAPPEN +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C 2009-03-23 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES; +C ADDED CHECK FOR OVERFLOW OF CHR; ADDED '#' +C OPTION FOR MORE THAN ONE OCCURRENCE OF STR +C 2009-04-21 J. ATOR -- USE ERRWRT +C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS +C WHEN USED WITH '#' OCCURRENCE CODE +C +C USAGE: CALL READLC (LUNIT, CHR, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C STR - CHARACTER*(*): STRING (I.E., MNEMONIC) +C +C OUTPUT ARGUMENT LIST: +C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., +C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT PARSTR PARUTG +C STATUS UPC +C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP WRTREE +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST) + COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) + COMMON /UNPTYP/ MSGUNP(NFILES) + COMMON /QUIET / IPRT + + CHARACTER*(*) CHR,STR + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*10 TAG,CTAG,CRTAG + CHARACTER*14 TGS(10) + CHARACTER*3 TYP + REAL*8 VAL + + DATA MAXTG /10/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CHR = ' ' + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE) +C ------------------------------------------------------------------ + + CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) + IF(NTG.GT.1) GOTO 903 + +C Check if a specific occurrence of the input string was requested; +C if not, then the default is to return the first occurrence. + + CALL PARUTG(LUN,0,TGS(1),NNOD,KON,ROID) + IF(KON.EQ.6) THEN + IOID=NINT(ROID) + IF(IOID.LE.0) IOID = 1 + CTAG = ' ' + II = 1 + DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#')) + CTAG(II:II)=TGS(1)(II:II) + II = II + 1 + ENDDO + ELSE + IOID = 1 + CTAG = TGS(1)(1:10) + ENDIF + +C LOCATE AND DECODE THE LONG CHARACTER STRING +C ------------------------------------------- + + IF(MSGUNP(LUN).EQ.0.OR.MSGUNP(LUN).EQ.1) THEN + +C The message is uncompressed + + ITAGCT = 0 + DO N=1,NVAL(LUN) + NOD = INV(N,LUN) + IF(CTAG.EQ.TAG(NOD)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.IOID) THEN + IF(ITP(NOD).NE.3) GOTO 904 + NCHR = NBIT(N)/8 + IF(NCHR.GT.LEN(CHR)) GOTO 905 + KBIT = MBIT(N) + CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT) + GOTO 100 + ENDIF + ENDIF + ENDDO + ELSEIF(MSGUNP(LUN).EQ.2) THEN + +C The message is compressed + + IF(NRST.GT.0) THEN + ITAGCT = 0 + DO II=1,NRST + IF(CTAG.EQ.CRTAG(II)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.IOID) THEN + NCHR = IRNCH(II) + IF(NCHR.GT.LEN(CHR)) GOTO 905 + KBIT = IRBIT(II) + CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT) + GOTO 100 + ENDIF + ENDIF + ENDDO + ENDIF + ELSE + GOTO 906 + ENDIF + +C If we made it here, then we couldn't find the requested string. + + IF(IPRT.GE.0) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + ERRSTR = 'BUFRLIB: READLC - MNEMONIC ' // TGS(1) // + . ' NOT LOCATED IN REPORT SUBSET - RETURN WITH BLANK' // + . ' STRING FOR CHARACTER DATA ELEMENT' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 WRITE(BORT_STR,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// + . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'// + . 'I3,")")') STR,NTG + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// + . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') TGS(1),ITP(NOD) + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// + . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '// + . 'FOR ONLY",I4, " CHARACTERS")') TGS(1),NCHR,LEN(CHR) + CALL BORT(BORT_STR) +906 WRITE(BORT_STR,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'// + . '" IS NOT RECOGNIZED")') MSGUNP + CALL BORT(BORT_STR) + END diff --git a/src/bufr/readmg.f b/src/bufr/readmg.f new file mode 100644 index 0000000000..db14ddf738 --- /dev/null +++ b/src/bufr/readmg.f @@ -0,0 +1,184 @@ + SUBROUTINE READMG(LUNXX,SUBSET,JDATE,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READMG +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL +C UNIT NUMBER ABS(LUNXX) INTO AN INTERNAL MESSAGE BUFFER (I.E. ARRAY +C MBAY IN COMMON BLOCK /BITBUF/). ABS(LUNXX) SHOULD ALREADY BE OPENED +C FOR INPUT OPERATIONS. IF LUNXX < 0, THEN A READ ERROR FROM +C ABS(LUNXX) IS TREATED THE SAME AS THE END-OF-FILE (EOF) CONDITION; +C OTHERWISE, BUFR ARCHIVE LIBRARY SUBROUTINE BORT IS NORMALLY CALLED +C IN SUCH SITUATIONS. ANY DX DICTIONARY MESSAGES ENCOUNTERED WITHIN +C ABS(LUNXX) ARE AUTOMATICALLY PROCESSED AND STORED INTERNALLY, SO A +C SUCCESSFUL RETURN FROM THIS SUBROUTINE WILL ALWAYS RESULT IN A BUFR +C MESSAGE CONTAINING ACTUAL DATA VALUES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-11-25 J. WOOLLEN -- MODIFIED TO EXIT GRACEFULLY WHEN THE BUFR +C FILE IS POSITIONED AFTER AN "END-OF-FILE" +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; MODIFIED TO MAKE Y2K +C COMPLIANT +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI); MODIFIED WITH +C SEMANTIC ADJUSTMENTS TO AMELIORATE COMPILER +C COMPLAINTS FROM LINUX BOXES (INCREASES +C PORTABILITY) +C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD +C BEEN REPLICATED IN THIS AND OTHER READ +C ROUTINES AND CONSOLIDATED IT INTO A NEW +C ROUTINE CKTABA, CALLED HERE, WHICH IS +C ENHANCED TO ALLOW COMPRESSED AND STANDARD +C BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE +C LENGTH INCREASED FROM 10,000 TO 20,000 +C BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT DATELEN (IT BECAME A +C SEPARATE ROUTINE IN THE BUFRLIB TO INCREASE +C PORTABILITY TO OTHER PLATFORMS) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- ADDED RDMSGW AND RDMSGB CALLS TO SIMULATE +C READIBM; ADDED LUNXX < 0 OPTION TO SIMULATE +C READFT +C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; +C ADD LOGIC TO PROCESS INTERNAL DICTIONARY +C MESSAGES +C 2012-06-07 J. ATOR -- DON'T RESPOND TO INTERNAL DICTIONARY +C MESSAGES IF SECTION 3 DECODING IS BEING USED +C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE; +C REMOVE CODE TO REREAD MESSAGE AS BYTES; +C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR +C +C USAGE: CALL READMG (LUNXX, SUBSET, JDATE, IRET) +C INPUT ARGUMENT LIST: +C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE (IF LUNXX IS LESS THAN ZERO, THEN READ +C ERRORS FROM ABS(LUNXX) ARE TREATED THE SAME AS EOF) +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more BUFR mesages in ABS(LUNXX) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CKTABA ERRWRT IDXMSG +C RDBFDX RDMSGW READS3 STATUS +C WTSTAT BACKBUFR +C THIS ROUTINE IS CALLED BY: IREADMG READNS RDMGSB REWNBF +C UFBINX UFBPOS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /QUIET / IPRT + + CHARACTER*128 ERRSTR + CHARACTER*8 SUBSET,TAMNEM + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + LUNIT = ABS(LUNXX) + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + CALL WTSTAT(LUNIT,LUN,IL,1) + +C READ A MESSAGE INTO THE INTERNAL MESSAGE BUFFER +C ----------------------------------------------- + +1 CALL RDMSGW(LUNIT,MBAY(1,LUN),IER) + IF(IER.EQ.-1) GOTO 200 + +C PARSE THE MESSAGE SECTION CONTENTS +C ---------------------------------- + + IF(ISC3(LUN).NE.0) CALL READS3(LUN) + CALL CKTABA(LUN,SUBSET,JDATE,IRET) + +C LOOK FOR A DICTIONARY MESSAGE +C ----------------------------- + + IF(IDXMSG(MBAY(1,LUN)).NE.1) RETURN + +C This is an internal dictionary message that was +C generated by the BUFRLIB archive library software. + + IF(ISC3(LUN).NE.0) RETURN + +C Section 3 decoding isn't being used, so backspace the +C file pointer and then use subroutine RDBFDX to read in +C all such dictionary messages (they should be stored +C consecutively!) and reset the internal tables. + + CALL BACKBUFR(LUN) + CALL RDBFDX(LUNIT,LUN) + + IF(IPRT.GE.1) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + ERRSTR = 'BUFRLIB: READMG - INTERNAL DICTIONARY MESSAGE READ;'// + .' ACCOUNT FOR IT THEN READ IN NEXT MESSAGE WITHOUT RETURNING' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C Now go read another message. + + GOTO 1 + +C EOF ON ATTEMPTED READ +C --------------------- + +200 CALL WTSTAT(LUNIT,LUN,IL,0) + INODE(LUN) = 0 + IDATE(LUN) = 0 + SUBSET = ' ' + JDATE = 0 + IRET = -1 + RETURN + +C EXITS +C ----- + +900 CALL BORT('BUFRLIB: READMG - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: READMG - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: READMG - ERROR READING A BUFR MESSAGE') + END diff --git a/src/bufr/readmm.f b/src/bufr/readmm.f new file mode 100644 index 0000000000..8755075233 --- /dev/null +++ b/src/bufr/readmm.f @@ -0,0 +1,83 @@ + SUBROUTINE READMM(IMSG,SUBSET,JDATE,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READMM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 +C +C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM +C INTERNAL MEMORY (ARRAY MSGS IN COMMON BLOCK /MSGMEM/) INTO A +C MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS +C IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE RDMEMM EXCEPT IT +C ADVANCES THE VALUE OF IMSG BY ONE PRIOR TO RETURNING TO CALLING +C PROGRAM. +C +C PROGRAM HISTORY LOG: +C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2009-03-23 J. ATOR -- REWROTE TO CALL RDMEMM +C +C USAGE: CALL READMM (IMSG, SUBSET, JDATE, IRET) +C INPUT ARGUMENT LIST: +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C STORAGE +C +C OUTPUT ARGUMENT LIST: +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C STORAGE +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = IMSG is either zero or greater than the +C number of messages in memory +C +C REMARKS: +C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: RDMEMM +C THIS ROUTINE IS CALLED BY: IREADMM +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*8 SUBSET + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) + + IMSG = IMSG+1 + + RETURN + END diff --git a/src/bufr/readmt.f b/src/bufr/readmt.f new file mode 100644 index 0000000000..708dfd79e1 --- /dev/null +++ b/src/bufr/readmt.f @@ -0,0 +1,256 @@ + SUBROUTINE READMT ( IMT, IMTV, IOGCE, IMTVL ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READMT +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE OPENS AND READS BUFR MASTER TABLES AS +C SPECIFIED BY THE INPUT ARGUMENTS AND USING ADDITIONAL INFORMATION +C AS WAS DEFINED IN THE MOST RECENT CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE MTINFO (OR AS WAS DEFINED WITHIN BUFR ARCHIVE LIBRARY +C SUBROUTINE BFRINI, IF SUBROUTINE MTINFO WAS NEVER CALLED). +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL READMT ( IMT, IMTV, IOGCE, IMTVL ) +C INPUT ARGUMENT LIST: +C IMT - INTEGER: MASTER TABLE NUMBER +C IMTV - INTEGER: MASTER TABLE VERSION NUMBER +C IOGCE - INTEGER: ORIGINATING CENTER +C IMTVL - INTEGER: LOCAL TABLE VERSION NUMBER +C +C INPUT FILES: +C UNITS 98,99 - IF SUBROUTINE MTINFO WAS NEVER CALLED, THEN THESE +C LOGICAL UNIT NUMBERS ARE USED BY THIS ROUTINE FOR +C OPENING AND READING THE BUFR MASTER TABLES. +C ALTERNATIVELY, IF SUBROUTINE MTINFO WAS CALLED, +C THEN THE LOGICAL UNIT NUMBERS SPECIFIED IN THE +C MOST RECENT CALL TO MTINFO (ARGUMENTS LUNMT1 AND +C LUNMT2) ARE USED INSTEAD. +C REMARKS: +C THIS ROUTINE CALLS: BORT2 ERRWRT ICVIDX IGETTDI +C RDMTBB RDMTBD +C THIS ROUTINE IS CALLED BY: READS3 +C Not normally called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET/ IPRT + COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR + COMMON /MSTABS/ NMTB, IBFXYN(MXMTBB), CBSCL(MXMTBB), + . CBSREF(MXMTBB), CBBW(MXMTBB), + . CBUNIT(MXMTBB), CBMNEM(MXMTBB), + . CBELEM(MXMTBB), + . NMTD, IDFXYN(MXMTBD), CDSEQ(MXMTBD), + . CDMNEM(MXMTBD), NDELEM(MXMTBD), + . IDEFXY(MXMTBD*MAXCD), + . CDELEM(MXMTBD*MAXCD) + + DIMENSION IMFXYB(MXMTBB), IMFXYD(MXMTBD), + . NMELEM(MXMTBD), IEFXYN(MXMTBD,MAXCD) + CHARACTER*4 CMDSCB(MXMTBB), CMDSCD(MXMTBD), + . CBSCL, CMSCL(MXMTBB), + . CBBW, CMBW(MXMTBB) + CHARACTER*8 CBMNEM, CMMNMB(MXMTBB), + . CDMNEM, CMMNMD(MXMTBD) + CHARACTER*12 CBSREF, CMSREF(MXMTBB) + CHARACTER*14 CBUNIT, CMUNIT(MXMTBB) + CHARACTER*20 FMTF + CHARACTER*100 MTDIR + CHARACTER*120 CBELEM, CMELEM(MXMTBB), + . CDSEQ, CMSEQ(MXMTBD), + . CDELEM, CEELEM(MXMTBD,MAXCD) + CHARACTER*128 BORT_STR + CHARACTER*132 TBLFIL,STDFIL,LOCFIL1,LOCFIL2 + LOGICAL FOUND + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C* Reset the scratch table D index for this master table. + + ITMP = IGETTDI ( 0 ) + + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT(' ') + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT('BUFRLIB: READMT - OPENING/READING MASTER TABLES') + ENDIF + +C* Locate and open the master Table B files. There should be one +C* file of standard descriptors and one file of local descriptors. + +C* First locate and open the file of standard Table B descriptors. + + IF ( ( IMT .EQ. 0 ) .AND. ( IMTV .LE. 13 ) ) THEN + +C* For master table 0, version 13 is a superset of all earlier +C* versions. + + STDFIL = MTDIR(1:LMTD) // '/' // 'bufrtab.TableB_STD_0_13' + ELSE + WRITE ( FMTF, '(A,I1,A,I1,A)' ) + . '(2A,I', ISIZE(IMT), ',A,I', ISIZE(IMTV), ')' + WRITE ( STDFIL, FMTF ) MTDIR(1:LMTD), '/bufrtab.TableB_STD_', + . IMT, '_', IMTV + ENDIF + TBLFIL = STDFIL + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('Standard Table B:') + CALL ERRWRT(TBLFIL) + ENDIF + INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) + IF ( .NOT. FOUND ) GOTO 900 + OPEN ( UNIT = LUN1, FILE = TBLFIL, IOSTAT = IER ) + IF ( IER .NE. 0 ) GOTO 901 + +C* Now locate and open the file of local Table B descriptors. + +C* Use the local table corresponding to the originating center +C* and local table version number of the current message, if such +C* a table exists. Otherwise use the NCEP local table B. + + LOCFIL2 = MTDIR(1:LMTD) // '/' // 'bufrtab.TableB_LOC_0_7_1' + WRITE ( FMTF, '(A,I1,A,I1,A,I1,A)' ) + . '(2A,I', ISIZE(IMT), ',A,I', ISIZE(IOGCE), + . ',A,I', ISIZE(IMTVL), ')' + WRITE ( LOCFIL1, FMTF ) MTDIR(1:LMTD), '/bufrtab.TableB_LOC_', + . IMT, '_', IOGCE, '_', IMTVL + TBLFIL = LOCFIL1 + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('Local Table B:') + CALL ERRWRT(TBLFIL) + ENDIF + INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) + IF ( .NOT. FOUND ) THEN + +C* Use the NCEP local table B. + + TBLFIL = LOCFIL2 + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('Local Table B not found, so using:') + CALL ERRWRT(TBLFIL) + ENDIF + INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) + IF ( .NOT. FOUND ) GOTO 900 + ENDIF + OPEN ( UNIT = LUN2, FILE = TBLFIL, IOSTAT = IER ) + IF ( IER .NE. 0 ) GOTO 901 + +C* Read the master Table B files. + + CALL RDMTBB ( LUN1, LUN2, MXMTBB, + . IBMT, IBMTV, IBOGCE, IBLTV, + . NMTBB, IMFXYB, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNMB, CMDSCB, CMELEM ) + +C* Save the output into COMMON /MSTABS/. + + NMTB = NMTBB + DO I = 1, NMTB + IBFXYN(I) = IMFXYB(I) + CBSCL(I) = CMSCL(I) + CBSREF(I) = CMSREF(I) + CBBW(I) = CMBW(I) + CBUNIT(I) = CMUNIT(I) + CBMNEM(I) = CMMNMB(I) + CBELEM(I) = CMELEM(I) + ENDDO + +C* Close the master Table B files. + + CLOSE ( UNIT = LUN1 ) + CLOSE ( UNIT = LUN2 ) + +C* Locate and open the master Table D files. There should be one +C* file of standard descriptors and one file of local descriptors. + +C* First locate and open the file of standard Table D descriptors. + + TBLFIL = STDFIL + TBLFIL(LMTD+15:LMTD+15) = 'D' + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('Standard Table D:') + CALL ERRWRT(TBLFIL) + ENDIF + INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) + IF ( .NOT. FOUND ) GOTO 900 + OPEN ( UNIT = LUN1, FILE = TBLFIL, IOSTAT = IER ) + IF ( IER .NE. 0 ) GOTO 901 + +C* Now locate and open the file of local Table D descriptors. + +C* Use the local table corresponding to the originating center +C* and local table version number of the current message, if such +C* a table exists. Otherwise use the NCEP local table D. + + TBLFIL = LOCFIL1 + TBLFIL(LMTD+15:LMTD+15) = 'D' + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('Local Table D:') + CALL ERRWRT(TBLFIL) + ENDIF + INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) + IF ( .NOT. FOUND ) THEN + +C* Use the NCEP local table D. + + TBLFIL = LOCFIL2 + TBLFIL(LMTD+15:LMTD+15) = 'D' + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('Local Table D not found, so using:') + CALL ERRWRT(TBLFIL) + ENDIF + INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) + IF ( .NOT. FOUND ) GOTO 900 + ENDIF + OPEN ( UNIT = LUN2, FILE = TBLFIL, IOSTAT = IER ) + IF ( IER .NE. 0 ) GOTO 901 + +C* Read the master Table D files. + + CALL RDMTBD ( LUN1, LUN2, MXMTBD, MAXCD, + . IDMT, IDMTV, IDOGCE, IDLTV, + . NMTBD, IMFXYD, CMMNMD, CMDSCD, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + +C* Save the output into COMMON /MSTABS/. + + NMTD = NMTBD + DO I = 1, NMTD + IDFXYN(I) = IMFXYD(I) + CDMNEM(I) = CMMNMD(I) + CDSEQ(I) = CMSEQ(I) + NDELEM(I) = NMELEM(I) + DO J = 1, NDELEM(I) + IDX = ICVIDX ( I-1, J-1, MAXCD ) + 1 + IDEFXY(IDX) = IEFXYN(I,J) + CDELEM(IDX) = CEELEM(I,J) + ENDDO + ENDDO + +C* Close the master Table D files. + + CLOSE ( UNIT = LUN1 ) + CLOSE ( UNIT = LUN2 ) + + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + RETURN +900 BORT_STR = 'BUFRLIB: READMT - COULD NOT FIND FILE:' + CALL BORT2(BORT_STR,TBLFIL) +901 BORT_STR = 'BUFRLIB: READMT - COULD NOT OPEN FILE:' + CALL BORT2(BORT_STR,TBLFIL) + END diff --git a/src/bufr/readns.f b/src/bufr/readns.f new file mode 100644 index 0000000000..58b9b92e6c --- /dev/null +++ b/src/bufr/readns.f @@ -0,0 +1,102 @@ + SUBROUTINE READNS(LUNIT,SUBSET,JDATE,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READNS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT READS THE NEXT +C SUBSET FROM LOGICAL UNIT NUMBER LUNIT INTO INTERNAL SUBSET ARRAYS. +C BUFR MESSAGES IN LUNIT MAY BE EITHER COMPRESSED OR UNCOMPRESSED. +C THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY +C SUBROUTINES READMG AND READSB. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C +C USAGE: CALL READNS (LUNIT, SUBSET, JDATE, IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE +C CONTAINING SUBSET BEING READ +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE CONTAINING SUBSET BEING READ, IN FORMAT OF +C EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON DATELEN() +C VALUE +C IREADNS - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the BUFR file +C +C REMARKS: +C THIS ROUTINE CALLS: BORT READMG READSB STATUS +C THIS ROUTINE IS CALLED BY: IREADNS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + CHARACTER*10 TAG + CHARACTER*8 SUBSET + CHARACTER*3 TYP + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C REFRESH THE SUBSET AND JDATE PARAMETERS +C --------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + SUBSET = TAG(INODE(LUN)) + JDATE = IDATE(LUN) + +C READ THE NEXT SUBSET IN THE BUFR FILE +C ------------------------------------- + +1 CALL READSB(LUNIT,IRET) + IF(IRET.NE.0) THEN + CALL READMG(LUNIT,SUBSET,JDATE,IRET) + IF(IRET.EQ.0) GOTO 1 + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: READNS - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: READNS - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') + END diff --git a/src/bufr/reads3.f b/src/bufr/reads3.f new file mode 100644 index 0000000000..760d4c75d7 --- /dev/null +++ b/src/bufr/reads3.f @@ -0,0 +1,243 @@ + SUBROUTINE READS3 ( LUN ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READS3 +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE READS THE SECTION 3 DESCRIPTORS FROM THE +C BUFR MESSAGE IN MBAY(1,LUN). IT THEN USES THE BUFR MASTER TABLES +C TO GENERATE THE NECESSARY INFORMATION FOR THESE DESCRIPTORS WITHIN +C THE INTERNAL BUFR TABLE ARRAYS. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL READS3 (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT DXINIT ERRWRT +C IGETNTBI IGETTDI ISTDESC IUPBS01 +C MAKESTAB READMT STNTBIA STSEQ +C UPDS3 +C THIS ROUTINE IS CALLED BY: READERME READMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /QUIET/ IPRT + COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES),IRDMT + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM), + . IDCACH(MXCNEM,MAXNC) + + DIMENSION IDS3(MAXNC) + CHARACTER*6 CDS3(MAXNC),NUMB,ADN30 + + CHARACTER*8 CNEM,TAMNEM + CHARACTER*55 CSEQ + + CHARACTER*128 ERRSTR + + LOGICAL INCACH, ALLSTD + +C* Initializing the following value ensures that new master tables +C* are read during the first call to this subroutine. + + DATA LMT /-99/ + + SAVE LMT, LMTV, LOGCE, LMTVL, IREPCT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C* Unpack some Section 1 information from the message. + + IMT = IUPBS01 ( MBAY(1,LUN), 'BMT' ) + IMTV = IUPBS01 ( MBAY(1,LUN), 'MTV' ) + IOGCE = IUPBS01 ( MBAY(1,LUN), 'OGCE' ) + IMTVL = IUPBS01 ( MBAY(1,LUN), 'MTVL' ) + +C* Unpack the list of Section 3 descriptors from the message. + + CALL UPDS3 ( MBAY(1,LUN), MAXNC, CDS3, NCDS3 ) + DO II = 1, NCDS3 + IDS3(II) = IFXY( CDS3(II) ) + ENDDO + +C* Compare the master table and master table version numbers from +C* this message to those from the message that was processed during +C* the previous call to this subroutine. + + IF ( ( IMT .NE. LMT ) + . .OR. + . ( ( IMT .NE. 0 ) .AND. ( IMTV .NE. LMTV ) ) + . .OR. + . ( ( IMT .EQ. 0 ) .AND. ( IMTV .NE. LMTV ) .AND. + . ( ( IMTV .GT. 13 ) .OR. ( LMTV .GT. 13 ) ) ) ) + . THEN + +C* Either the master table number has changed +C* .OR. +C* The master table number hasn't changed, but it isn't 0, and +C* the table version number has changed +C* .OR. +C* The master table number hasn't changed and is 0, but the table +C* version number has changed, and at least one of the table +C* version numbers (i.e. the current or the previous) is greater +C* than 13 (which is the last version that was a superset of all +C* earlier versions of master table 0!) + +C* In any of these cases, we need to read in new tables and reset +C* the internal tables and local descriptor cache, since the +C* meanings of one or more Section 3 descriptors may have changed. + + CALL READMT ( IMT, IMTV, IOGCE, IMTVL ) + LMT = IMT + LMTV = IMTV + LOGCE = IOGCE + LMTVL = IMTVL + CALL DXINIT ( LUN, 0 ) + IREPCT = 0 + NCNEM = 0 + ELSE + +C* Check whether all of the Section 3 descriptors are standard. +C* If so, then the originating center and local table version +C* numbers are irrelevant as far as Section 3 is concerned. + + II = 1 + ALLSTD = .TRUE. + DO WHILE ( (ALLSTD) .AND. (II.LE.NCDS3) ) + IF ( ISTDESC(IDS3(II)) .EQ. 0 ) THEN + ALLSTD = .FALSE. + ELSE + II = II + 1 + ENDIF + ENDDO + IF ( .NOT. ALLSTD ) THEN + +C* There was at least one local (i.e. non-standard) descriptor, +C* so check whether the originating center and/or local table +C* version number are different than those from the message +C* that was processed during the previous call to this +C* subroutine. If so, then read in new tables and reset the +C* internal tables and local descriptor cache, since the +C* meanings of one or more local descriptors in Section 3 may +C* have changed. + + IF ( ( IOGCE .NE. LOGCE ) .OR. ( IMTVL .NE. LMTVL ) ) THEN + CALL READMT ( IMT, IMTV, IOGCE, IMTVL ) + LMT = IMT + LMTV = IMTV + LOGCE = IOGCE + LMTVL = IMTVL + CALL DXINIT ( LUN, 0 ) + IREPCT = 0 + NCNEM = 0 + ENDIF + ENDIF + ENDIF + +C* Is the list of Section 3 descriptors already in the cache? + +C* The cache is a performance-enhancing device which saves +C* time when the same descriptor sequences are encountered +C* over and over within the calling program. Time is saved +C* because the below calls to subroutines STSEQ and MAKESTAB +C* are bypassed whenever a list is already in the cache. + + INCACH = .FALSE. + IF ( NCNEM .GT. 0 ) THEN + II = 1 + DO WHILE ( (.NOT.INCACH) .AND. (II.LE.NCNEM) ) + IF ( NCDS3 .EQ. NDC(II) ) THEN + JJ = 1 + INCACH = .TRUE. + DO WHILE ( (INCACH) .AND. (JJ.LE.NCDS3) ) + IF ( IDS3(JJ) .EQ. IDCACH(II,JJ) ) THEN + JJ = JJ + 1 + ELSE + INCACH = .FALSE. + ENDIF + ENDDO + IF (INCACH) THEN + +C* The list is already in the cache, so store the +C* corresponding Table A mnemonic into COMMON /SC3BFR/ +C* and return. + + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // CNEM(II) + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + TAMNEM(LUN) = CNEM(II) + RETURN + ENDIF + ENDIF + II = II + 1 + ENDDO + ENDIF + +C* Get the next available index within the internal Table A. + + N = IGETNTBI ( LUN, 'A' ) + +C* Generate a Table A mnemonic and sequence description. + + WRITE ( TAMNEM(LUN), '(A5,I3.3)') 'MSTTB', N + CSEQ = 'TABLE A MNEMONIC ' // TAMNEM(LUN) + +C* Store the Table A mnemonic and sequence into the cache. + + NCNEM = NCNEM + 1 + IF ( NCNEM .GT. MXCNEM ) GOTO 900 + CNEM(NCNEM) = TAMNEM(LUN) + NDC(NCNEM) = NCDS3 + DO JJ = 1, NCDS3 + IDCACH(NCNEM,JJ) = IDS3(JJ) + ENDDO + IF ( IPRT .GE. 2 ) THEN + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' // + . CNEM(NCNEM) + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C* Get an FXY value to use with this Table A mnemonic. + + IDN = IGETTDI ( LUN ) + NUMB = ADN30 ( IDN, 6 ) + +C* Store all of the information for this mnemonic within the +C* internal Table A. + + CALL STNTBIA ( N, LUN, NUMB, TAMNEM(LUN), CSEQ ) + +C* Store all of the information for this sequence within the +C* internal Tables B and D. + + CALL STSEQ ( LUN, IREPCT, IDN, TAMNEM(LUN), CSEQ, IDS3, NCDS3 ) + +C* Update the jump/link table. + + CALL MAKESTAB + + RETURN +900 CALL BORT('BUFRLIB: READS3 - MXCNEM OVERFLOW') + END diff --git a/src/bufr/readsb.f b/src/bufr/readsb.f new file mode 100644 index 0000000000..421ea781a4 --- /dev/null +++ b/src/bufr/readsb.f @@ -0,0 +1,130 @@ + SUBROUTINE READSB(LUNIT,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: READSB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT READS A SUBSET FROM +C A BUFR MESSAGE INTO INTERNAL SUBSET ARRAYS. THE BUFR MESSAGE MUST +C HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE +C LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED +C OR UNCOMPRESSED. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- ADDED CALL TO NEW ROUTINE RDCMPS ALLOWING +C SUBSETS TO NOW BE DECODED FROM COMPRESSED +C BUFR MESSAGES; MAXIMUM MESSAGE LENGTH +C INCREASED FROM 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- CORRECTED ERROR RELATING TO CERTAIN +C FOREIGN FILE TYPES; REMOVED OLD CRAY +C COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C +C USAGE: CALL READSB (LUNIT, IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the BUFR +C message +C +C REMARKS: +C THIS ROUTINE CALLS: BORT RDCMPS RDTREE STATUS +C UPB +C THIS ROUTINE IS CALLED BY: COPYSB IREADSB RDMEMS READNS +C RDMSGB UFBINX UFBPOS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /UNPTYP/ MSGUNP(NFILES) + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) THEN + IRET = -1 + GOTO 100 + ENDIF + +C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE +C --------------------------------------------- + + IF(NSUB(LUN).EQ.MSUB(LUN)) THEN + IRET = -1 + GOTO 100 + ELSE + NSUB(LUN) = NSUB(LUN) + 1 + ENDIF + +C READ THE NEXT SUBSET AND RESET THE POINTERS +C ------------------------------------------- + + IF(MSGUNP(LUN).EQ.0) THEN + IBIT = MBYT(LUN)*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + CALL RDTREE(LUN) + MBYT(LUN) = MBYT(LUN) + NBYT + ELSEIF(MSGUNP(LUN).EQ.1) THEN +c .... message with "standard" Section 3 + IBIT = MBYT(LUN) + CALL RDTREE(LUN) + MBYT(LUN) = IBIT + ELSEIF(MSGUNP(LUN).EQ.2) THEN +c .... compressed message + CALL RDCMPS(LUN) + ELSE + GOTO 902 + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') +902 WRITE(BORT_STR,'("BUFRLIB: READSB - MESSAGE UNPACK TYPE",I3,"IS'// + . ' NOT RECOGNIZED")') MSGUNP + CALL BORT(BORT_STR) + END diff --git a/src/bufr/restd.c b/src/bufr/restd.c new file mode 100644 index 0000000000..300ea8c340 --- /dev/null +++ b/src/bufr/restd.c @@ -0,0 +1,139 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RESTD +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF A LOCAL +C (I.E. NON-STANDARD) TABLE D DESCRIPTOR, THIS ROUTINE RETURNS +C AN EQUIVALENT LIST OF STANDARDIZED CHILD DESCRIPTORS. ANY CHILD +C DESCRIPTORS WHICH ARE THEMSELVES LOCAL TABLE D DESCRIPTORS ARE +C AUTOMATICALLY RESOLVED VIA A RECURSIVE CALL TO THIS SAME ROUTINE. +C THE RECURSIVE PROCESS CONTINUES UNTIL ALL CHILD DESCRIPTORS ARE +C EITHER WMO-STANDARD DESCRIPTORS (I.E. FROM TABLE B, TABLE C, OR +C TABLE D, OR REPLICATION DESCRIPTORS) OR ELSE ARE LOCAL TABLE B +C DESCRIPTORS, IN WHICH CASE THEY ARE PRECEDED WITH AN APPROPRIATE +C 206YYY TABLE C OPERATOR IN THE OUTPUT LIST. IN ANY EVENT, THE +C FINAL OUTPUT LIST OF EQUIVALENT CHILD DESCRIPTORS IS USABLE BY +C ANY STANDARD BUFR DECODER PROGRAM IN ORDER TO INTERPRET THE SAME +C DATA VALUES AS WERE REPRESENTED BY THE INITIAL LOCAL TABLE D +C DESCRIPTOR THAT WAS INPUT. +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C 2012-04-30 J. ATOR -- USE LONG CAST FOR IBIT IN SPRINTF STMT +C +C USAGE: CALL RESTD( LUN, TDDESC, NCTDDESC, CTDDESC ) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C TDDESC - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE FOR +C LOCAL TABLE D DESCRIPTOR +C +C OUTPUT ARGUMENT LIST: +C NCTDDESC - INTEGER: NUMBER OF STANDARDIZED CHILD DESCRIPTORS +C RETURNED IN CTDDESC +C CTDDESC - INTEGER: ARRAY OF STANDARDIZED CHILD DESCRIPTORS +C +C REMARKS: +C THIS ROUTINE CALLS: RESTD NUMTBD NEMTBB IFXY +C CADN30 ISTDESC WRDESC UPTDD +C THIS ROUTINE IS CALLED BY: RESTD STNDRD +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +void restd( f77int *lun, f77int *tddesc, f77int *nctddesc, f77int ctddesc[] ) +{ + f77int i0 = 0; + + f77int desc, ncdesc, cdesc[MAXNC]; + f77int i, j, inum, itbd, ictbd; + f77int iscl, iref, ibit; + + char tab, nemo[9], adn[7], cunit[25]; + +/* +** How many child descriptors does *tddesc have? +*/ + numtbd( lun, tddesc, nemo, &tab, &itbd, 9, 1 ); + uptdd( &itbd, lun, &i0, &inum ); + + *nctddesc = 0; +/* +** Examine each child descriptor one at a time. +*/ + for ( i = 1; i <= inum; i++ ) { + uptdd( &itbd, lun, &i, &desc ); + if (! istdesc( &desc ) ) { +/* +** desc is a local descriptor. +*/ + numtbd( lun, &desc, nemo, &tab, &ictbd, 9, 1 ); + if ( tab == 'D' ) { +/* +** desc is itself a local Table D descriptor, so resolve +** it now via a recursive call to this same routine. +*/ + restd( lun, &desc, &ncdesc, cdesc ); + + if ( ( *nctddesc > 0 ) && + ( ctddesc[(*nctddesc)-1] > ifxy( "101000", 6 ) ) && + ( ctddesc[(*nctddesc)-1] <= ifxy( "101255", 6 ) ) ) { +/* +** desc is replicated using fixed replication, so write +** the number of child descriptors into the X value of +** the replication descriptor ctddesc[(*nctddesc)-1] +*/ + cadn30( &ctddesc[(*nctddesc)-1], adn, 7 ); + sprintf( adn, "%c%02ld%c%c%c", + adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); + ctddesc[(*nctddesc)-1] = ifxy( adn, 7 ); + } + else if ( ( *nctddesc > 1 ) && + ( ctddesc[(*nctddesc)-2] == ifxy( "101000", 6 ) ) ) { +/* +** desc is replicated using delayed replication, so write +** the number of child descriptors into the X value of +** the replication descriptor ctddesc[(*nctddesc)-2] +*/ + cadn30( &ctddesc[(*nctddesc)-2], adn, 7 ); + sprintf( adn, "%c%02ld%c%c%c", + adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); + ctddesc[(*nctddesc)-2] = ifxy( adn, 7 ); + } +/* +** Add the child descriptors to the output list. +*/ + for ( j = 0; j < ncdesc; j++ ) { + wrdesc( cdesc[j], ctddesc, nctddesc ); + } + + } + else if ( tab == 'B' ) { +/* +** desc is a local Table B descriptor, so precede it with +** a 206YYY operator in the output list. +*/ + nemtbb( lun, &ictbd, cunit, &iscl, &iref, &ibit, 25 ); + sprintf( adn, "%c%c%c%03ld", '2', '0', '6', (long) ibit ); + wrdesc( ifxy( adn, 7 ), ctddesc, nctddesc ); + wrdesc( desc, ctddesc, nctddesc ); + } + } + else { +/* +** desc is a standard Table B, Table D, operator or replicator +** descriptor, so append it "as is" to the output list. +*/ + wrdesc( desc, ctddesc, nctddesc ); + } + } + + return; +} diff --git a/src/bufr/rewnbf.f b/src/bufr/rewnbf.f new file mode 100644 index 0000000000..69cb463582 --- /dev/null +++ b/src/bufr/rewnbf.f @@ -0,0 +1,180 @@ + SUBROUTINE REWNBF(LUNIT,ISR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: REWNBF +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE, DEPENDING ON THE VALUE OF ISR, WILL +C EITHER: +C 1) STORE THE CURRENT PARAMETERS ASSOCIATED WITH A BUFR FILE +C CONNECTED TO LUNIT (READ/WRITE POINTERS, ETC.), SET THE FILE STATUS +C TO READ, THEN REWIND THE BUFR FILE AND POSITION IT SUCH THAT THE +C NEXT BUFR MESSAGE READ WILL BE THE FIRST MESSAGE IN THE FILE +C CONTAINING ACTUAL SUBSETS WITH DATA; OR +C 2) RESTORE THE BUFR FILE CONNECTED TO LUNIT TO THE PARAMETERS +C IT HAD PRIOR TO 1) ABOVE USING THE INFORMATION SAVED IN 1) ABOVE. +C +C THIS ALLOWS INFORMATION TO BE EXTRACTED FROM A PARTICULAR SUBSET IN +C A BUFR FILE WHICH IS IN THE MIDST OF BEING READ FROM OR WRITTEN TO +C BY AN APPLICATION PROGRAM. NOTE THAT FOR A PARTICULAR BUFR FILE 1) +C ABOVE MUST PRECEDE 2) ABOVE. AN APPLICATION PROGRAM MIGHT FIRST +C CALL THIS SUBROUTINE WITH ISR = 0, THEN CALL EITHER BUFR ARCHIVE +C LIBRARY SUBROUTINE RDMGSB OR UFBINX TO GET INFO FROM A SUBSET, THEN +C CALL THIS ROUTINE AGAIN WITH ISR = 1 TO RESTORE THE POINTERS IN THE +C BUFR FILE TO THEIR ORIGINAL LOCATION. ALSO, BUFR ARCHIVE LIBRARY +C SUBROUTINE UFBTAB WILL CALL THIS ROUTINE IF THE BUFR FILE IT IS +C ACTING UPON IS ALREADY OPEN FOR INPUT OR OUTPUT. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION +C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION +C VERSION AT ONE TIME AND THEN REMOVED) +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE +C (DICTIONARY) MESSAGES +C 2011-09-26 J. WOOLLEN -- FIXED BUG TO PREVENT SKIP OF FIRST DATA +C MESSAGE AFTER REWIND +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C REPLACE FORTRAN REWIND WITH C CEWIND +C +C USAGE: CALL REWNBF (LUNIT, ISR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C ISR - INTEGER: SWITCH: +C 0 = store current parameters associated with +C BUFR file, set file status to read, rewind +C file such that next message read is first +C message containing subset data +C 1 = restore BUFR file with parameters saved +C from the previous call to this routine with +C ISR=0 +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT I4DY READMG STATUS +C WTSTAT CEWIND +C THIS ROUTINE IS CALLED BY: UFBINX UFBTAB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /BUFRSR/ JUNN,JILL,JIMM,JBIT,JBYT,JMSG,JSUB,KSUB,JNOD,JDAT, + . JSR(NFILES),JBAY(MXMSGLD4) + + CHARACTER*128 BORT_STR + + CHARACTER*8 SUBSET + + DIMENSION MESG(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C TRY TO TRAP BAD CALL PROBLEMS +C ----------------------------- + + IF(ISR.EQ.0) THEN + CALL STATUS(LUNIT,LUN,IL,IM) + IF(JSR(LUN).NE.0) GOTO 900 + IF(IL.EQ.0) GOTO 901 + ELSEIF(ISR.EQ.1) THEN + LUN = JUNN + IF(JSR(JUNN).NE.1) GOTO 902 + ELSE + GOTO 903 + ENDIF + +C STORE FILE PARAMETERS AND SET FOR READING +C ----------------------------------------- + + IF(ISR.EQ.0) THEN + JUNN = LUN + JILL = IL + JIMM = IM + JBIT = IBIT + JBYT = MBYT(LUN) + JMSG = NMSG(LUN) + JSUB = NSUB(LUN) + KSUB = MSUB(LUN) + JNOD = INODE(LUN) + JDAT = IDATE(LUN) + DO I=1,JBYT + JBAY(I) = MBAY(I,LUN) + ENDDO + CALL WTSTAT(LUNIT,LUN,-1,0) + ENDIF + +C REWIND THE FILE +C --------------- + + call cewind(lun) + +C RESTORE FILE PARAMETERS AND POSITION IT TO WHERE IT WAS SAVED +C ------------------------------------------------------------- + + IF(ISR.EQ.1) THEN + LUN = JUNN + IL = JILL + IM = JIMM + IBIT = JBIT + MBYT(LUN) = JBYT + NMSG(LUN) = JMSG + NSUB(LUN) = JSUB + MSUB(LUN) = KSUB + INODE(LUN) = JNOD + IDATE(LUN) = I4DY(JDAT) + DO I=1,JBYT + MBAY(I,LUN) = JBAY(I) + ENDDO + DO IMSG=1,JMSG + CALL READMG(LUNIT,SUBSET,KDATE,IER) + IF(IER.LT.0) GOTO 905 + ENDDO + CALL WTSTAT(LUNIT,LUN,IL,IM) + ENDIF + + JSR(LUN) = MOD(JSR(LUN)+1,2) + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// + . 'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED '// + . '(AND NOT YET RESTORED) (UNIT",I3,")")') LUNIT + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// + . 'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT'// + . ' OR OUTPUT) (UNIT",I3,")")') LUNIT + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// + . 'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') + . LUNIT + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '// + . 'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")') + . ISR,LUNIT + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// + . 'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE '// + . 'NO.",I5)') LUNIT,JMSG + CALL BORT(BORT_STR) + END diff --git a/src/bufr/rjust.f b/src/bufr/rjust.f new file mode 100644 index 0000000000..003d166fa8 --- /dev/null +++ b/src/bufr/rjust.f @@ -0,0 +1,54 @@ + FUNCTION RJUST(STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RJUST +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION RIGHT JUSTIFIES A CHARACTER STRING. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: RJUST (STR) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING TO BE RIGHT-JUSTIFED +C +C OUTPUT ARGUMENT LIST: +C STR - CHARACTER*(*): RIGHT-JUSTIFIED STRING +C RJUST - REAL: ALWAYS RETURNED AS 0 (DUMMY) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: SNTBBE UFBDMP UFDUMP VALX +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + RJUST = 0. + IF(STR.EQ.' ') GOTO 100 + LSTR = LEN(STR) + DO WHILE(STR(LSTR:LSTR).EQ.' ') + DO I=LSTR,2,-1 + STR(I:I) = STR(I-1:I-1) + ENDDO + STR(1:1) = ' ' + ENDDO + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/rsvfvm.f b/src/bufr/rsvfvm.f new file mode 100644 index 0000000000..bbb40d6aec --- /dev/null +++ b/src/bufr/rsvfvm.f @@ -0,0 +1,67 @@ + SUBROUTINE RSVFVM(NEM1,NEM2) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RSVFVM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE STEPS THROUGH THE "FOLLOWING VALUE" +C MNEMONIC NEM1 AND, FOR EACH "." CHARACTER ENCOUNTERED (EXCEPT FOR +C THE INITIAL ONE), OVERWRITES IT WITH THE NEXT CORRESPONDING +C CHARACTER FROM NEM2 (SEE REMARKS). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C +C USAGE: CALL RSVFVM (NEM1, NEM2) +C INPUT ARGUMENT LIST: +C NEM1 - CHARACTER*8: "FOLLOWING VALUE" MNEMONIC +C NEM2 - CHARACTER*8: MNEMONIC IMMEDIATELY FOLLOWING NEM1 +C WITHIN USER DICTIONARY TABLE +C +C OUTPUT ARGUMENT LIST: +C NEM1 - CHARACTER*8: COPY OF INPUT NEM1 WITH ALL "." +C CHARACTERS (EXCEPT INITIAL ONE) OVERWRITTEN WITH +C CORRESPONDING CHARACTERS FROM NEM2 +C +C REMARKS: +C FOR EXAMPLE: +C if, on input: NEM1 = ".DTH...." +C NEM2 = "MXTM " +C then, on output: NEM1 = ".DTHMXTM" +C +C +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: NEMTBD SEQSDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*8 NEM1,NEM2 + + DO I=1,LEN(NEM1) + IF(I.EQ.1) THEN + +C Skip initial "." and initialize J. + + J = 1 + ELSE + IF(NEM1(I:I).EQ.'.') THEN + NEM1(I:I) = NEM2(J:J) + J = J+1 + ENDIF + ENDIF + ENDDO + + RETURN + END diff --git a/src/bufr/rtrcpt.f b/src/bufr/rtrcpt.f new file mode 100644 index 0000000000..507f5dfe5c --- /dev/null +++ b/src/bufr/rtrcpt.f @@ -0,0 +1,95 @@ + SUBROUTINE RTRCPT(LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: RTRCPT +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE RETURNS THE TANK RECEIPT TIME STORED WITHIN +C SECTION 1 OF THE BUFR MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO +C BUFR ARCHIVE LIBRARY SUBROUTINE READMG, READMM OR EQUIVALENT. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL RTRCPT (LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C IYR - INTEGER: TANK RECEIPT YEAR +C IMO - INTEGER: TANK RECEIPT MONTH +C IDY - INTEGER: TANK RECEIPT DAY +C IHR - INTEGER: TANK RECEIPT HOUR +C IMI - INTEGER: TANK RECEIPT MINUTE +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = no tank receipt time was present within the +C BUFR message currently open for input +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IUPB IUPBS01 STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = -1 + +C Check the file status. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C Check whether the message contains a tank receipt time. + + IF(IUPBS01(MBAY(1,LUN),'BEN').EQ.4) THEN + IS1BYT = 23 + ELSE + IS1BYT = 19 + ENDIF + IF( (IS1BYT+5) .GT. IUPBS01(MBAY(1,LUN),'LEN1') ) RETURN + +C Unpack the tank receipt time. + +C Note that IS1BYT is a starting byte number relative to the +C beginning of Section 1, so we still need to account for +C Section 0 when specifying the actual byte numbers to unpack +C within the overall message. + + IMGBYT = IS1BYT + IUPBS01(MBAY(1,LUN),'LEN0') + + IYR = IUPB(MBAY(1,LUN),IMGBYT,16) + IMO = IUPB(MBAY(1,LUN),IMGBYT+2,8) + IDY = IUPB(MBAY(1,LUN),IMGBYT+3,8) + IHR = IUPB(MBAY(1,LUN),IMGBYT+4,8) + IMI = IUPB(MBAY(1,LUN),IMGBYT+5,8) + + IRET = 0 + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT; IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE; NONE ARE') + END diff --git a/src/bufr/seqsdx.f b/src/bufr/seqsdx.f new file mode 100644 index 0000000000..e95e5af09b --- /dev/null +++ b/src/bufr/seqsdx.f @@ -0,0 +1,253 @@ + SUBROUTINE SEQSDX(CARD,LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: SEQSDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION +C FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A +C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY +C BUFR ARCHIVE LIBRARY SUBROUTINE RDUSDX. THESE ARE THEN ADDED TO +C THE ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX) +C WITHIN THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN COMMON BLOCK +C /TABABD/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C +C USAGE: CALL SEQSDX (CARD, LUN) +C INPUT ARGUMENT LIST: +C CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ +C FROM A USER-SUPPLIED BUFR DICTIONARY TABLE +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT2 NEMOCK NEMTAB +C PARSTR PKTDD RSVFVM STRNUM +C THIS ROUTINE IS CALLED BY: RDUSDX +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) + + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*80 CARD,SEQS + CHARACTER*12 ATAG,TAGS(250) + CHARACTER*8 NEMO,NEMA,NEMB + CHARACTER*6 ADN30,CLEMON + CHARACTER*3 TYPS + CHARACTER*1 REPS,TAB + + DATA MAXTGS /250/ + DATA MAXTAG /12/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING +C -------------------------------------------------------------- + + NEMO = CARD( 3:10) + SEQS = CARD(14:78) + +C Note that an entry for this mnemonic should already exist within +C the internal BUFR Table D array TABD(*,LUN); this entry should +C have been created by subroutine RDUSDX when the mnemonic and its +C associated FXY value and description were initially defined +C within a card read from the "Descriptor Definition" section at +C the top of the user-supplied BUFR dictionary table in character +C format. Now, we need to retrieve the positional index for that +C entry within TABD(*,LUN) so that we can access the entry and then +C add the decoded sequence information to it. + + CALL NEMTAB(LUN,NEMO,IDN,TAB,ISEQ) + IF(TAB.NE.'D') GOTO 900 + CALL PARSTR(SEQS,TAGS,MAXTGS,NTAG,' ',.TRUE.) + IF(NTAG.EQ.0 ) GOTO 901 + + DO N=1,NTAG + ATAG = TAGS(N) + IREP = 0 + +C CHECK FOR REPLICATOR +C -------------------- + + DO I=1,5 + IF(ATAG(1:1).EQ.REPS(I,1)) THEN + +C Note that REPS(*,*), which contains all of the symbols used to +C denote all of the various replication schemes that are +C possible within a user-supplied BUFR dictionary table in +C character format, was previously defined within subroutine +C BFRINI. + + DO J=2,MAXTAG + IF(ATAG(J:J).EQ.REPS(I,2)) THEN + IF(J.EQ.MAXTAG) GOTO 902 + +C Note that subroutine STRNUM will return NUMR = 0 if the +C string passed to it contains all blanks (as *should* be the +C case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or +C 5 '<' '>'). + +C However, when I = 1 '"' '"', then subroutine STRNUM will +C return NUMR = (the number of replications for the mnemonic +C using F=1 "regular" (i.e. non-delayed) replication). + + CALL STRNUM(ATAG(J+1:MAXTAG),NUMR) + IF(I.EQ.1 .AND. NUMR.LE.0 ) GOTO 903 + IF(I.EQ.1 .AND. NUMR.GT.255) GOTO 904 + IF(I.NE.1 .AND. NUMR.NE.0 ) GOTO 905 + ATAG = ATAG(2:J-1) + IREP = I + GOTO 1 + ENDIF + ENDDO + GOTO 902 + ENDIF + ENDDO + +C CHECK FOR VALID TAG +C ------------------- + +1 IRET=NEMOCK(ATAG) + IF(IRET.EQ.-1) GOTO 906 + IF(IRET.EQ.-2) GOTO 907 + CALL NEMTAB(LUN,ATAG,IDN,TAB,IRET) + IF(IRET.GT.0) THEN + +C Note that the next code line checks that we are not trying to +C replicate a Table B mnemonic (which is currently not allowed). +C The logic works because, for replicated mnemonics, IREP = I = +C (the index within REPS(*,*) of the symbol associated with the +C type of replication in question (e.g. "{, "<", etc.)) + + IF(TAB.EQ.'B' .AND. IREP.NE.0) GOTO 908 + IF(ATAG(1:1).EQ.'.') THEN + +C This mnemonic is a "following value" mnemonic +C (i.e. it relates to the mnemonic that immediately +C follows it within the user-supplied character-format BUFR +C dictionary table sequence), so confirm that it contains, as +C a substring, this mnemonic that immediately follows it. + + NEMB = TAGS(N+1) +c .... get NEMA from IDN + CALL NUMTAB(LUN,IDN,NEMA,TAB,ITAB) + CALL NEMTAB(LUN,NEMB,JDN,TAB,IRET) + CALL RSVFVM(NEMA,NEMB) + IF(NEMA.NE.ATAG) GOTO 909 +c .... DK: I don't think the next test can ever be satisfied +c .... should probably be IF(N.EQ.NTAG ) GOTO 910 + IF(N.GT.NTAG ) GOTO 910 + IF(TAB.NE.'B') GOTO 911 + ENDIF + ELSE + GOTO 912 + ENDIF + +C WRITE THE DESCRIPTOR STRING INTO TABD ARRAY +C ------------------------------------------- +c .... first look for a replication descriptor + IF(IREP.GT.0) CALL PKTDD(ISEQ,LUN,IDNR(IREP,1)+NUMR,IRET) + IF(IRET.LT.0) GOTO 913 + CALL PKTDD(ISEQ,LUN,IDN,IRET) + IF(IRET.LT.0) GOTO 914 + + ENDDO + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '// + . '(UNDEFINED, TAB=",A,")")') NEMO,TAB + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// + . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') NEMO + CALL BORT2(BORT_STR1,BORT_STR2) +902 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// + . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') NEMO,TAGS(N) + CALL BORT2(BORT_STR1,BORT_STR2) +903 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// + . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'// + . ' 2ND QUOTE")') NEMO,TAGS(N),NUMR + CALL BORT2(BORT_STR1,BORT_STR2) +904 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// + . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '// + . '255")') NEMO,TAGS(N),NUMR + CALL BORT2(BORT_STR1,BORT_STR2) +905 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'// + . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'// + . 'NO")') NEMO,TAGS(N),NUMR + CALL BORT2(BORT_STR1,BORT_STR2) +906 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// + .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")') + . NEMO,TAGS(N) + CALL BORT2(BORT_STR1,BORT_STR2) +907 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// + . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') NEMO,TAGS(N) + CALL BORT2(BORT_STR1,BORT_STR2) +908 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// + . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")') + . NEMO,TAGS(N) + CALL BORT2(BORT_STR1,BORT_STR2) +909 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '// + . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")') + . NEMO,TAGS(N),NEMA + CALL BORT2(BORT_STR1,BORT_STR2) +910 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '// + . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '// + . 'STRING")') NEMO,NEMA + CALL BORT2(BORT_STR1,BORT_STR2) +911 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'// + . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '// + . 'ENTRY")') NEMO,NEMB + CALL BORT2(BORT_STR1,BORT_STR2) +912 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// + . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")') + . NEMO,TAGS(N) + CALL BORT2(BORT_STR1,BORT_STR2) +913 CLEMON = ADN30(IDNR(IREP,1)+NUMR,6) + WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// + . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '// + . 'WARNING MSG")') NEMO,CLEMON + CALL BORT2(BORT_STR1,BORT_STR2) +914 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD + WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// + . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '// + . 'WARNING MSG")') NEMO,TAGS(N) + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/setblock.f b/src/bufr/setblock.f new file mode 100644 index 0000000000..ac5ede8900 --- /dev/null +++ b/src/bufr/setblock.f @@ -0,0 +1,47 @@ + SUBROUTINE SETBLOCK(IBLK) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: SETBLOCK +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 +C +C ABSTRACT: SUBROUTINE SETBLOCK ALLOWS APPLICATIONS TO DEFINE WHAT +C SORT OF OUTPUT FILE BLOCKING (IEEE RECORD CONTROL WORDS) +C ARE APPLIED TO BUFR RECORDS WRITTEN FROM THE BUFRLIB +C ROUTINES. THE DEFAULT IS NONE (PURE BUFR). OTHER OPTIONS +C ARE BIG OR LITTLE ENDIAN. +C +C PROGRAM HISTORY LOG: +C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR +C +C USAGE: CALL SETBLOCK(IBLK) +C +C INPUT ARGUMENTS: +C IBLK - INTEGER BLOCK TYPE INDICATOR +C -1 LITTLE ENDIAN RECORD CONTROL WORDS +C 0 NO RECORD CONTROL WORDS (PURE BUFR) +C 1 BIG ENDIAN RECORD CONTROL WORDS +C +C OUTPUT ARGUMENTS: +C +C REMARKS: +C THIS ROUTINE CALLS: OPENBF +C +C THIS ROUTINE IS CALLED BY: USER +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) + +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + + CALL OPENBF(0,'FIRST',0) + IBLOCK=IBLK + + RETURN + END diff --git a/src/bufr/setbmiss.f b/src/bufr/setbmiss.f new file mode 100644 index 0000000000..5000f84f7b --- /dev/null +++ b/src/bufr/setbmiss.f @@ -0,0 +1,48 @@ + SUBROUTINE SETBMISS(XMISS) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: SETBMISS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 +C +C ABSTRACT: SETBMISS WILL ALLOW AN APPLICATION TO DEFINE THE SPECIAL +C VALUE "BMISS" WHICH DENOTES MISSING VALUES BOTH FOR READING +C FROM BUFR FILES AND FOR WRITING TO BUFR FILES. THE DEFAULT +C BUFRLIB MISSING VALUE IS SET TO 10E10 IN SUBROUTINE BFRINI. +C +C PROGRAM HISTORY LOG: +C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR +C +C USAGE: CALL SETBMISS(XMISS) +C +C INPUT ARGUMENTS: +C XMISS - REAL*8 MISSING VALUE TO BE USED +C +C OUTPUT ARGUMENTS: +C +C REMARKS: +C THIS ROUTINE CALLS: OPENBF +C +C THIS ROUTINE IS CALLED BY: None +C (Normally called only by application +C programs) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + REAL*8 XMISS + +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + + CALL OPENBF(0,'FIRST',0) + + BMISS = XMISS + + RETURN + END diff --git a/src/bufr/sntbbe.f b/src/bufr/sntbbe.f new file mode 100644 index 0000000000..c274ea092e --- /dev/null +++ b/src/bufr/sntbbe.f @@ -0,0 +1,161 @@ + SUBROUTINE SNTBBE ( IFXYN, LINE, MXMTBB, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: SNTBBE +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE PARSES AN ENTRY THAT WAS PREVIOUSLY READ +C FROM AN ASCII MASTER TABLE B FILE AND THEN STORES THE OUTPUT INTO +C THE MERGED ARRAYS. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL SNTBBE ( IFXYN, LINE, MXMTBB, +C NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, +C CMUNIT, CMMNEM, CMDSC, CMELEM ) +C INPUT ARGUMENT LIST: +C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR +C TABLE ENTRY; THIS FXY NUMBER IS THE ELEMENT DESCRIPTOR +C LINE - CHARACTER*(*): TABLE ENTRY +C MXMTBB - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN +C MERGED MASTER TABLE B ARRAYS; THIS SHOULD BE THE SAME +C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN +C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE +C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS +C +C OUTPUT ARGUMENT LIST: +C NMTBB - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE B +C ARRAYS +C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE +C REPRESENTATIONS OF FXY NUMBERS (I.E. ELEMENT +C DESCRIPTORS) +C CMSCL(*) - CHARACTER*4: MERGED ARRAY CONTAINING SCALE FACTORS +C CMSREF(*)- CHARACTER*12: MERGED ARRAY CONTAINING REFERENCE VALUES +C CMBW(*) - CHARACTER*4: MERGED ARRAY CONTAINING BIT WIDTHS +C CMUNIT(*)- CHARACTER*14: MERGED ARRAY CONTAINING UNITS +C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS +C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES +C CMELEM(*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES +C +C REMARKS: +C THIS ROUTINE CALLS: BORT BORT2 JSTCHR NEMOCK +C PARSTR RJUST +C THIS ROUTINE IS CALLED BY: RDMTBB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) LINE + CHARACTER*200 TAGS(10), WKTAG + CHARACTER*128 BORT_STR1, BORT_STR2 + CHARACTER*120 CMELEM(*) + CHARACTER*14 CMUNIT(*) + CHARACTER*12 CMSREF(*) + CHARACTER*8 CMMNEM(*) + CHARACTER*4 CMSCL(*), CMBW(*), CMDSC(*) + + INTEGER IMFXYN(*) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF ( NMTBB .GE. MXMTBB ) GOTO 900 + NMTBB = NMTBB + 1 + +C Store the FXY number. This is the element descriptor. + + IMFXYN ( NMTBB ) = IFXYN + +C Parse the table entry. + + CALL PARSTR ( LINE, TAGS, 10, NTAG, '|', .FALSE. ) + IF ( NTAG .LT. 4 ) THEN + BORT_STR2 = ' HAS TOO FEW FIELDS' + GOTO 901 + ENDIF + +C Scale factor. + + CALL JSTCHR ( TAGS(2), IRET ) + IF ( IRET .NE. 0 ) THEN + BORT_STR2 = ' HAS MISSING SCALE FACTOR' + GOTO 901 + ENDIF + CMSCL ( NMTBB ) = TAGS(2)(1:4) + RJ = RJUST ( CMSCL ( NMTBB ) ) + +C Reference value. + + CALL JSTCHR ( TAGS(3), IRET ) + IF ( IRET .NE. 0 ) THEN + BORT_STR2 = ' HAS MISSING REFERENCE VALUE' + GOTO 901 + ENDIF + CMSREF ( NMTBB ) = TAGS(3)(1:12) + RJ = RJUST ( CMSREF ( NMTBB ) ) + +C Bit width. + + CALL JSTCHR ( TAGS(4), IRET ) + IF ( IRET .NE. 0 ) THEN + BORT_STR2 = ' HAS MISSING BIT WIDTH' + GOTO 901 + ENDIF + CMBW ( NMTBB ) = TAGS(4)(1:4) + RJ = RJUST ( CMBW ( NMTBB ) ) + +C Units. Note that this field is allowed to be blank. + + IF ( NTAG .GT. 4 ) THEN + CALL JSTCHR ( TAGS(5), IRET ) + CMUNIT ( NMTBB ) = TAGS(5)(1:14) + ELSE + CMUNIT ( NMTBB ) = ' ' + ENDIF + +C Comment (additional) fields. Any of these fields may be blank. + + CMMNEM ( NMTBB ) = ' ' + CMDSC ( NMTBB ) = ' ' + CMELEM ( NMTBB ) = ' ' + IF ( NTAG .GT. 5 ) THEN + WKTAG = TAGS(6) + CALL PARSTR ( WKTAG, TAGS, 10, NTAG, ';', .FALSE. ) + IF ( NTAG .GT. 0 ) THEN +C The first additional field contains the mnemonic. + CALL JSTCHR ( TAGS(1), IRET ) +C If there is a mnemonic, then make sure it's legal. + IF ( ( IRET .EQ. 0 ) .AND. + . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN + BORT_STR2 = ' HAS ILLEGAL MNEMONIC' + GOTO 901 + ENDIF + CMMNEM ( NMTBB ) = TAGS(1)(1:8) + ENDIF + IF ( NTAG .GT. 1 ) THEN +C The second additional field contains descriptor codes. + CALL JSTCHR ( TAGS(2), IRET ) + CMDSC ( NMTBB ) = TAGS(2)(1:4) + ENDIF + IF ( NTAG .GT. 2 ) THEN +C The third additional field contains the element name. + CALL JSTCHR ( TAGS(3), IRET ) + CMELEM ( NMTBB ) = TAGS(3)(1:120) + ENDIF + ENDIF + + RETURN + 900 CALL BORT('BUFRLIB: SNTBBE - OVERFLOW OF MERGED ARRAYS') + 901 BORT_STR1 = 'BUFRLIB: SNTBBE - CARD BEGINNING WITH: ' // + . LINE(1:20) + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/sntbde.f b/src/bufr/sntbde.f new file mode 100644 index 0000000000..4ecc12027f --- /dev/null +++ b/src/bufr/sntbde.f @@ -0,0 +1,180 @@ + SUBROUTINE SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: SNTBDE +C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 +C +C ABSTRACT: THIS SUBROUTINE PARSES THE FIRST LINE OF AN ENTRY THAT WAS +C PREVIOUSLY READ FROM AN ASCII MASTER TABLE D FILE AND STORES THE +C OUTPUT INTO THE MERGED ARRAYS. IT THEN READS AND PARSES ALL +C REMAINING LINES FOR THAT SAME ENTRY AND THEN LIKEWISE STORES THAT +C OUTPUT INTO THE MERGED ARRAYS. THE RESULT IS THAT, UPON OUTPUT, +C THE MERGED ARRAYS NOW CONTAIN ALL OF THE INFORMATION FOR THE +C CURRENT TABLE ENTRY. +C +C PROGRAM HISTORY LOG: +C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, +C NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, +C NMELEM, IEFXYN, CEELEM ) +C INPUT ARGUMENT LIST: +C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE +C CONTAINING MASTER TABLE D INFORMATION +C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR +C TABLE ENTRY; THIS FXY NUMBER IS THE SEQUENCE DESCRIPTOR +C LINE - CHARACTER*(*): FIRST LINE OF TABLE ENTRY +C MXMTBD - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN +C MERGED MASTER TABLE D ARRAYS; THIS SHOULD BE THE SAME +C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN +C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE +C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS +C MXELEM - INTEGER: MAXIMUM NUMBER OF ELEMENTS TO BE STORED PER +C ENTRY WITHIN THE MERGED MASTER TABLE D ARRAYS; THIS +C SHOULD BE THE SAME NUMBER AS WAS USED TO DIMENSION THE +C OUTPUT ARRAYS IN THE CALLING PROGRAM, AND IT IS USED +C BY THIS SUBROUTINE TO ENSURE THAT IT DOESN'T OVERFLOW +C THESE ARRAYS +C +C OUTPUT ARGUMENT LIST: +C NMTBD - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE D +C ARRAYS +C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE +C REPRESENTATIONS OF FXY NUMBERS (I.E. SEQUENCE +C DESCRIPTORS) +C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS +C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES +C CMSEQ(*) - CHARACTER*120: MERGED ARRAY CONTAINING SEQUENCE NAMES +C NMELEM(*)- INTEGER: MERGED ARRAY CONTAINING NUMBER OF ELEMENTS +C STORED FOR EACH ENTRY +C IEFXYN(*,*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE +C REPRESENTATIONS OF ELEMENT FXY NUMBERS +C CEELEM(*,*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT BORT2 IFXY +C IGETFXY IGETNTBL JSTCHR NEMOCK +C PARSTR +C THIS ROUTINE IS CALLED BY: RDMTBD +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) LINE + CHARACTER*200 TAGS(10), CLINE + CHARACTER*128 BORT_STR1, BORT_STR2 + CHARACTER*120 CMSEQ(*), CEELEM(MXMTBD,MXELEM) + CHARACTER*8 CMMNEM(*) + CHARACTER*6 ADN30, ADSC, CLEMON + CHARACTER*4 CMDSC(*) + + INTEGER IMFXYN(*), NMELEM(*), + . IEFXYN(MXMTBD,MXELEM) + + LOGICAL DONE + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF ( NMTBD .GE. MXMTBD ) GOTO 900 + NMTBD = NMTBD + 1 + +C Store the FXY number. This is the sequence descriptor. + + IMFXYN ( NMTBD ) = IFXYN + +C Is there any other information within the first line of the +C table entry? If so, it follows a "|" separator. + + CMMNEM ( NMTBD ) = ' ' + CMDSC ( NMTBD ) = ' ' + CMSEQ ( NMTBD ) = ' ' + IPT = INDEX ( LINE, '|' ) + IF ( IPT .NE. 0 ) THEN + +C Parse the rest of the line. Any of the fields may be blank. + + CALL PARSTR ( LINE(IPT+1:), TAGS, 10, NTAG, ';', .FALSE. ) + IF ( NTAG .GT. 0 ) THEN +C The first additional field contains the mnemonic. + CALL JSTCHR ( TAGS(1), IRET ) +C If there is a mnemonic, then make sure it's legal. + IF ( ( IRET .EQ. 0 ) .AND. + . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN + BORT_STR2 = ' HAS ILLEGAL MNEMONIC' + GOTO 901 + ENDIF + CMMNEM ( NMTBD ) = TAGS(1)(1:8) + ENDIF + IF ( NTAG .GT. 1 ) THEN +C The second additional field contains descriptor codes. + CALL JSTCHR ( TAGS(2), IRET ) + CMDSC ( NMTBD ) = TAGS(2)(1:4) + ENDIF + IF ( NTAG .GT. 2 ) THEN +C The third additional field contains the sequence name. + CALL JSTCHR ( TAGS(3), IRET ) + CMSEQ ( NMTBD ) = TAGS(3)(1:120) + ENDIF + ENDIF + +C Now, read and parse all remaining lines from this table entry. +C Each line should contain an element descriptor for the sequence +C represented by the current sequence descriptor. + + NELEM = 0 + DONE = .FALSE. + DO WHILE ( .NOT. DONE ) + IF ( IGETNTBL ( LUNT, CLINE ) .NE. 0 ) THEN + BORT_STR2 = ' IS INCOMPLETE' + GOTO 901 + ENDIF + CALL PARSTR ( CLINE, TAGS, 10, NTAG, '|', .FALSE. ) + IF ( NTAG .LT. 2 ) THEN + BORT_STR2 = ' HAS BAD ELEMENT CARD' + GOTO 901 + ENDIF + +C The second field contains the FXY number for this element. + + IF ( IGETFXY ( TAGS(2), ADSC ) .NE. 0 ) THEN + BORT_STR2 = ' HAS BAD OR MISSING' // + . ' ELEMENT FXY NUMBER' + GOTO 901 + ENDIF + IF ( NELEM .GE. MXELEM ) GOTO 900 + NELEM = NELEM + 1 + IEFXYN ( NMTBD, NELEM ) = IFXY ( ADSC ) + +C The third field (if it exists) contains the element name. + + IF ( NTAG .GT. 2 ) THEN + CALL JSTCHR ( TAGS(3), IRET ) + CEELEM ( NMTBD, NELEM ) = TAGS(3)(1:120) + ELSE + CEELEM ( NMTBD, NELEM ) = ' ' + ENDIF + +C Is this the last line for this table entry? + + IF ( INDEX ( TAGS(2), ' >' ) .EQ. 0 ) DONE = .TRUE. + ENDDO + NMELEM ( NMTBD ) = NELEM + + RETURN + + 900 CALL BORT('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') + 901 CLEMON = ADN30 ( IFXYN, 6 ) + WRITE(BORT_STR1,'("BUFRLIB: SNTBDE - TABLE D ENTRY FOR' // + . ' SEQUENCE DESCRIPTOR: ",5A)') + . CLEMON(1:1), '-', CLEMON(2:3), '-', CLEMON(4:6) + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/status.f b/src/bufr/status.f new file mode 100644 index 0000000000..35d61cd6bb --- /dev/null +++ b/src/bufr/status.f @@ -0,0 +1,155 @@ + SUBROUTINE STATUS(LUNIT,LUN,IL,IM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STATUS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CHECKS WHETHER LOGICAL UNIT NUMBER LUNIT +C (AND ITS ASSOCIATED BUFR FILE) IS CURRENTLY CONNECTED TO THE +C BUFR ARCHIVE LIBRARY SOFTWARE. IF SO, IT RETURNS THE I/O STREAM +C INDEX (LUN) ASSOCIATED WITH THE LOGICAL UNIT NUMBER, THE LOGICAL +C UNIT STATUS INDICATOR (IL), AND THE BUFR MESSAGE STATUS INDICATOR +C (IM) FOR THAT I/O STREAM INDEX. OTHERWISE, IT CHECKS WHETHER THERE +C IS SPACE FOR A NEW I/O STREAM INDEX AND, IF SO, RETURNS THE NEXT +C AVAILABLE I/O STREAM INDEX IN LUN IN ORDER TO DEFINE LUNIT (IL AND +C IM ARE RETURNED AS ZERO, THEY ARE LATER DEFINED VIA CALLS TO BUFR +C ARCHIVE LIBRARY SUBROUTINE WTSTAT IN THIS CASE). IF THERE IS NO +C SPACE FOR A NEW I/O STREAM INDEX, LUN IS RETURNED AS ZERO (AS WELL +C AS IL AND IM) MEANING LUNIT COULD NOT BE CONNECTED TO THE BUFR +C ARCHIVE LIBRARY SOFTWARE. LUN IS USED TO IDENTIFY UP TO "NFILES" +C UNIQUE BUFR FILES IN THE VARIOUS INTERNAL ARRAYS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-12-11 J. WOOLLEN -- FIXED A LONG STANDING BUG WHICH OCCURS IN +C UNUSUAL SITUATIONS, VERY LOW IMPACT +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL STATUS ( LUNIT, LUN, IL, IM ) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX ASSOCIATED WITH LOGICAL UNIT +C LUNIT +C 0 = LUNIT is not currently connected to the +C BUFR Archive Library software and there is +C no space for a new I/O stream index +C IL - INTEGER: LOGICAL UNIT STATUS INDICATOR: +C 0 = LUNIT is not currently connected to the +C BUFR Archive Library software or it was +C just connected in this call to STATUS +C 1 = LUNIT is connected to the BUFR Archive +C Library software as an output file +C -1 = LUNIT is connected to the BUFR Archive +C Library software as an input file +C IM - INTEGER: INDICATOR AS TO WHETHER THERE IS A BUFR +C MESSAGE CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT: +C 0 = no or LUNIT was just connected to the +C BUFR Archive Library software in this call +C to STATUS +C 1 = yes +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: CLOSBF CLOSMG COPYBF COPYMG +C COPYSB CPYMEM DATEBF DRFINI +C DUMPBF DXDUMP GETABDB GETTAGPR +C GETVALNB IFBGET IGETSC INVMRG +C IUPVS01 LCMGDF MESGBC MINIMG +C MSGWRT NMSUB OPENBF OPENMB +C OPENMG POSAPX RDMEMM RDMEMS +C RDMGSB READDX READERME READLC +C READMG READNS READSB REWNBF +C RTRCPT STNDRD UFBCNT UFBCPY +C UFBCUP UFBDMP UFBEVN UFBGET +C UFBIN3 UFBINT UFBINX UFBMMS +C UFBOVR UFBPOS UFBQCD UFBQCP +C UFBREP UFBRMS UFBSEQ UFBSTP +C UFBTAB UFBTAM UFDUMP UPFTBV +C WRCMPS WRDXTB WRITLC WRITSA +C WRITSB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /STBFR/ IOLUN(NFILES),IOMSG(NFILES) + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(LUNIT.LE.0 .OR. LUNIT.GT.99) GOTO 900 + +C CLEAR THE STATUS INDICATORS +C --------------------------- + + LUN = 0 + IL = 0 + IM = 0 + +C SEE IF UNIT IS ALREADY CONNECTED TO BUFR ARCHIVE LIBRARY SOFTWARE +C ----------------------------------------------------------------- + + DO I=1,NFILES + IF(ABS(IOLUN(I)).EQ.LUNIT) LUN = I + ENDDO + +C IF NOT, TRY TO DEFINE IT SO AS TO CONNECT IT TO BUFR ARCHIVE LIBRARY +C SOFTWARE +C -------------------------------------------------------------------- + + IF(LUN.EQ.0) THEN + DO I=1,NFILES + IF(IOLUN(I).EQ.0) THEN + +C File space is available, return with LUN > 0, IL and IM remain 0 +C ---------------------------------------------------------------- + + LUN = I + GOTO 100 + ENDIF + ENDDO + +C File space is NOT available, return with LUN, IL and IM all 0 +C ------------------------------------------------------------- + + GOTO 100 + ENDIF + +C IF THE UNIT WAS ALREADY CONNECTED TO THE BUFR ARCHIVE LIBRARY +C SOFTWARE PRIOR TO THIS CALL, RETURN STATUSES +C ------------------------------------------------------------- + + IL = SIGN(1,IOLUN(LUN)) + IM = IOMSG(LUN) + +C EXITS +C ---- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") '// + . 'OUTSIDE LEGAL RANGE OF 1-99")') LUNIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/stbfdx.f b/src/bufr/stbfdx.f new file mode 100644 index 0000000000..5bbcc9d05d --- /dev/null +++ b/src/bufr/stbfdx.f @@ -0,0 +1,180 @@ + SUBROUTINE STBFDX(LUN,MESG) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STBFDX +C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE +C FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN +C COMMON BLOCK /TABABD/. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC COPIED +C FROM PREVIOUS VERSION OF RDBFDX +C +C USAGE: CALL STBFDX (LUN,MESG) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING +C BUFR TABLE (DICTIONARY) MESSAGE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CAPIT CHRTRN CHRTRNA +C GETLENS IGETNTBI IDN30 IFXY +C IUPBS01 IUPM NENUBD NMWRD +C PKTDD STNTBIA +C THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM READERME +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR + CHARACTER*128 TABB,TABB1,TABB2 + CHARACTER*128 TABA + CHARACTER*56 DXSTR + CHARACTER*55 CSEQ + CHARACTER*50 DXCMP + CHARACTER*24 UNIT + CHARACTER*8 NEMO + CHARACTER*6 NUMB,CIDN + CHARACTER*1 MOCT(MXMSGL) + DIMENSION MBAY(MXMSGLD4),LDXBD(10),LDXBE(10) + + DIMENSION MESG(*) + + EQUIVALENCE (MBAY(1),MOCT(1)) + + DATA LDXBD /38,70,8*0/ + DATA LDXBE /42,42,8*0/ + +C----------------------------------------------------------------------- + JA(I) = IA+1+LDA*(I-1) + JB(I) = IB+1+LDB*(I-1) +C----------------------------------------------------------------------- + +C MAKE A LOCAL COPY OF THE MESSAGE (SO IT CAN BE EQUIVALENCED!) +C ------------------------------------------------------------- + + DO II = 1,NMWRD(MESG) + MBAY(II) = MESG(II) + ENDDO + +C GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE +C ------------------------------------------------- + + IDXS = IUPBS01(MBAY,'MSBT')+1 + IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MBAY,'MTVL')+1 + IF(LDXA(IDXS).EQ.0) GOTO 901 + IF(LDXB(IDXS).EQ.0) GOTO 901 + IF(LDXD(IDXS).EQ.0) GOTO 901 + + CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) + I3 = LEN0+LEN1+LEN2 + DXCMP = ' ' + CALL CHRTRN(DXCMP,MOCT(I3+8),NXSTR(IDXS)) + IF(DXCMP.NE.DXSTR(IDXS)) GOTO 902 + +C SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D +C -------------------------------------------------- + + LDA = LDXA (IDXS) + LDB = LDXB (IDXS) + LDD = LDXD (IDXS) + LDBD = LDXBD(IDXS) + LDBE = LDXBE(IDXS) + L30 = LD30 (IDXS) + + IA = I3+LEN3+5 + LA = IUPM(MOCT(IA),8) + IB = JA(LA+1) + LB = IUPM(MOCT(IB),8) + ID = JB(LB+1) + LD = IUPM(MOCT(ID),8) + +C TABLE A +C ------- + + DO I=1,LA + N = IGETNTBI(LUN,'A') + CALL CHRTRNA(TABA(N,LUN),MOCT(JA(I)),LDA) + NUMB = ' '//TABA(N,LUN)(1:3) + NEMO = TABA(N,LUN)(4:11) + CSEQ = TABA(N,LUN)(13:67) + CALL STNTBIA(N,LUN,NUMB,NEMO,CSEQ) + ENDDO + +C TABLE B +C ------- + + DO I=1,LB + N = IGETNTBI(LUN,'B') + CALL CHRTRNA(TABB1,MOCT(JB(I) ),LDBD) + CALL CHRTRNA(TABB2,MOCT(JB(I)+LDBD),LDBE) + TABB(N,LUN) = TABB1(1:LDXBD(IDXV+1))//TABB2(1:LDXBE(IDXV+1)) + NUMB = TABB(N,LUN)(1:6) + NEMO = TABB(N,LUN)(7:14) + CALL NENUBD(NEMO,NUMB,LUN) + IDNB(N,LUN) = IFXY(NUMB) + UNIT = TABB(N,LUN)(71:94) + CALL CAPIT(UNIT) + TABB(N,LUN)(71:94) = UNIT + NTBB(LUN) = N + ENDDO + +C TABLE D +C ------- + + DO I=1,LD + N = IGETNTBI(LUN,'D') + CALL CHRTRNA(TABD(N,LUN),MOCT(ID+1),LDD) + NUMB = TABD(N,LUN)(1:6) + NEMO = TABD(N,LUN)(7:14) + CALL NENUBD(NEMO,NUMB,LUN) + IDND(N,LUN) = IFXY(NUMB) + ND = IUPM(MOCT(ID+LDD+1),8) + IF(ND.GT.MAXCD) GOTO 903 + DO J=1,ND + NDD = ID+LDD+2 + (J-1)*L30 + CALL CHRTRNA(CIDN,MOCT(NDD),L30) + IDN = IDN30(CIDN,L30) + CALL PKTDD(N,LUN,IDN,IRET) + IF(IRET.LT.0) GOTO 904 + ENDDO + ID = ID+LDD+1 + ND*L30 + IF(IUPM(MOCT(ID+1),8).EQ.0) ID = ID+1 + NTBD(LUN) = N + ENDDO + +C EXITS +C ----- + + RETURN +901 CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '// + . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '// + . 'KNOWN)') +902 CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '// + . 'CONTENTS') +903 WRITE(BORT_STR,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '// + . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '// + . ' (",I4,")")') NEMO,ND,MAXCD + CALL BORT(BORT_STR) +904 CALL BORT('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '// + . 'PKTDD, SEE PREVIOUS WARNING MESSAGE') + END diff --git a/src/bufr/stdmsg.f b/src/bufr/stdmsg.f new file mode 100644 index 0000000000..444a2963bb --- /dev/null +++ b/src/bufr/stdmsg.f @@ -0,0 +1,60 @@ + SUBROUTINE STDMSG(CF) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STDMSG +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT BUFR +C MESSAGES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR +C ARCHIVE LIBRARY SUBROUTINES WHICH CREATE SUCH MESSAGES (E.G. WRITCP, +C WRITSB, COPYMG, WRITSA, ETC.) ARE TO BE "STANDARDIZED". SEE THE +C DOCUMENTATION BLOCK WITHIN BUFR ARCHIVE LIBRARY SUBROUTINE STNDRD +C FOR AN EXPLANATION OF WHAT "STANDARDIZATION" MEANS. THIS SUBROUTINE +C CAN BE CALLED AT ANY TIME AFTER THE FIRST CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF, AND THE POSSIBLE VALUES FOR CF ARE 'N' +C (= 'NO', WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL STDMSG (CF) +C INPUT ARGUMENT LIST: +C CF - CHARACTER*1: FLAG INDICATING WHETHER BUFR MESSAGES +C OUTPUT BY FUTURE CALLS TO WRITCP, WRITSB, COPYMG, ETC. +C SHOULD BE "STANDARDIZED": +C 'N' = 'NO' (THE DEFAULT) +C 'Y' = 'YES' +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CAPIT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /MSGSTD/ CSMF + + CHARACTER*128 BORT_STR + CHARACTER*1 CSMF, CF + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL CAPIT(CF) + IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 + CSMF = CF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,'// + . '", IT MUST BE EITHER Y OR N")') CF + CALL BORT(BORT_STR) + END diff --git a/src/bufr/stndrd.f b/src/bufr/stndrd.f new file mode 100644 index 0000000000..73d6b95450 --- /dev/null +++ b/src/bufr/stndrd.f @@ -0,0 +1,293 @@ + SUBROUTINE STNDRD(LUNIT,MSGIN,LMSGOT,MSGOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STNDRD +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: THIS SUBROUTINE READS AN INPUT NCEP BUFR MESSAGE CONTAINED +C WITHIN ARRAY MSGIN AND, USING THE BUFR TABLES INFORMATION ASSOCIATED +C WITH LOGICAL UNIT LUNIT, OUTPUTS A "STANDARDIZED" VERSION OF THIS +C SAME MESSAGE WITHIN ARRAY MSGOT. THIS "STANDARDIZATION" INVOLVES +C REMOVING ALL OCCURRENCES OF NCEP BUFRLIB-SPECIFIC BYTE COUNTERS AND +C BIT PADS IN SECTION 4 AS WELL AS REPLACING THE TOP-LEVEL TABLE A FXY +C NUMBER IN SECTION 3 WITH AN EQUIVALENT SEQUENCE OF LOWER-LEVEL +C TABLE B, TABLE C, TABLE D AND/OR REPLICATION FXY NUMBERS WHICH +C DIRECTLY CONSTITUTE THAT TABLE A FXY NUMBER AND WHICH THEMSELVES ARE +C ALL WMO-STANDARD. THE RESULT IS THAT THE OUTPUT MESSAGE IN MSGOT IS +C NOW ENTIRELY COMPLIANT WITH WMO FM-94 BUFR REGULATIONS (I.E. IT IS +C NOW "STANDARD"). IT IS IMPORTANT TO NOTE THAT THE SEQUENCE EXPANSION +C WITHIN SECTION 3 MAY CAUSE THE FINAL "STANDARDIZED" BUFR MESSAGE TO +C BE LONGER THAN THE ORIGINAL INPUT NCEP BUFR MESSAGE BY AS MANY AS +C (MAXNC*2) BYTES (SEE 'bufrlib.prm' FOR AN EXPLANATION OF MAXNC), SO +C THE USER MUST ALLOW FOR ENOUGH SPACE TO ACCOMODATE SUCH AN EXPANSION +C WITHIN THE MSGOT ARRAY. +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C THIS SUBROUTINE IS MODELED AFTER SUBROUTINE +C STANDARD; HOWEVER, IT USES SUBROUTINE RESTD +C TO EXPAND SECTION 3 AS MANY LEVELS AS +C NECESSARY IN ORDER TO ATTAIN TRUE WMO +C STANDARDIZATION (WHEREAS STANDARD ONLY +C EXPANDED THE TOP-LEVEL TABLE A FXY NUMBER +C ONE LEVEL DEEP), AND IT ALSO CONTAINS AN +C EXTRA INPUT ARGUMENT LMSGOT WHICH PREVENTS +C OVERFLOW OF THE MSGOT ARRAY +C 2005-11-29 J. ATOR -- USE GETLENS AND IUPBS01; ENSURE THAT BYTE 4 +C OF SECTION 4 IS ZEROED OUT IN MSGOT; CHECK +C EDITION NUMBER OF BUFR MESSAGE BEFORE +C PADDING TO AN EVEN BYTE COUNT +C 2009-03-23 J. ATOR -- USE IUPBS3 AND NEMTBAX; DON'T ASSUME THAT +C COMPRESSED MESSAGES ARE ALREADY FULLY +C STANDARDIZED WITHIN SECTION 3 +C +C USAGE: CALL STNDRD (LUNIT, MSGIN, LMSGOT, MSGOT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE IN NCEP +C BUFR +C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; +C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT +C OVERFLOW THE MSGOT ARRAY +C +C OUTPUT ARGUMENT LIST: +C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE +C NOW IN STANDARDIZED BUFR +C +C REMARKS: +C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. +C +C THIS ROUTINE CALLS: BORT GETLENS ISTDESC IUPB +C IUPBS01 IUPBS3 MVB NEMTBAX +C NUMTAB PKB PKC RESTD +C STATUS UPB UPC +C THIS ROUTINE IS CALLED BY: MSGWRT +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + DIMENSION ICD(MAXNC) + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION MSGIN(*),MSGOT(*) + + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + CHARACTER*4 SEVN + CHARACTER*1 TAB + + LOGICAL FOUND + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C LUNIT MUST POINT TO AN OPEN BUFR FILE +C ------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + +C IDENTIFY THE SECTION LENGTHS AND ADDRESSES IN MSGIN +C --------------------------------------------------- + + CALL GETLENS(MSGIN,5,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) + + IAD3 = LEN0+LEN1+LEN2 + IAD4 = IAD3+LEN3 + + LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5 + + LENM = IUPBS01(MSGIN,'LENM') + + IF(LENN.NE.LENM) GOTO 901 + + MBIT = (LENN-4)*8 + CALL UPC(SEVN,4,MSGIN,MBIT) + IF(SEVN.NE.'7777') GOTO 902 + +C COPY SECTIONS 0 THROUGH PART OF SECTION 3 INTO MSGOT +C ---------------------------------------------------- + + MXBYTO = (LMSGOT*NBYTW) - 8 + + LBYTO = IAD3+7 + IF(LBYTO.GT.MXBYTO) GOTO 905 + CALL MVB(MSGIN,1,MSGOT,1,LBYTO) + +C REWRITE NEW SECTION 3 IN A "STANDARD" FORM +C ------------------------------------------ + +C LOCATE THE TOP-LEVEL TABLE A DESCRIPTOR + + FOUND = .FALSE. + II = 10 + DO WHILE ((.NOT.FOUND).AND.(II.GE.8)) + ISUB = IUPB(MSGIN,IAD3+II,16) + CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) + IF((ITAB.NE.0).AND.(TAB.EQ.'D')) THEN + CALL NEMTBAX(LUN,SUBSET,MTYP,MSBT,INOD) + IF(INOD.NE.0) FOUND = .TRUE. + ENDIF + II = II - 2 + ENDDO + IF(.NOT.FOUND) GOTO 903 + + IF (ISTDESC(ISUB).EQ.0) THEN + +C ISUB IS A NON-STANDARD TABLE A DESCRIPTOR AND NEEDS +C TO BE EXPANDED INTO AN EQUIVALENT STANDARD SEQUENCE + + CALL RESTD(LUN,ISUB,NCD,ICD) + ELSE + +C ISUB IS ALREADY A STANDARD DESCRIPTOR, SO JUST COPY +C IT "AS IS" INTO THE NEW SECTION 3 (I.E. NO EXPANSION +C IS NECESSARY!) + + NCD = 1 + ICD(NCD) = ISUB + ENDIF + +C USE THE EDITION NUMBER TO DETERMINE THE LENGTH OF THE +C NEW SECTION 3 + + LEN3 = 7+(NCD*2) + IBEN = IUPBS01(MSGIN,'BEN') + IF(IBEN.LT.4) THEN + LEN3 = LEN3+1 + ENDIF + LBYTO = LBYTO + LEN3 - 7 + IF(LBYTO.GT.MXBYTO) GOTO 905 + +C STORE THE DESCRIPTORS INTO THE NEW SECTION 3 + + IBIT = (IAD3+7)*8 + DO N=1,NCD + CALL PKB(ICD(N),16,MSGOT,IBIT) + ENDDO + +C DEPENDING ON THE EDITION NUMBER, PAD OUT THE NEW SECTION 3 WITH AN +C ADDITIONAL ZEROED-OUT BYTE IN ORDER TO ENSURE AN EVEN BYTE COUNT + + IF(IBEN.LT.4) THEN + CALL PKB(0,8,MSGOT,IBIT) + ENDIF + +C STORE THE LENGTH OF THE NEW SECTION 3 + + IBIT = IAD3*8 + CALL PKB(LEN3,24,MSGOT,IBIT) + +C NOW THE TRICKY PART - NEW SECTION 4 +C ----------------------------------- + + IF(IUPBS3(MSGIN,'ICMP').EQ.1) THEN + +C THE DATA IN SECTION 4 IS COMPRESSED AND IS THEREFORE ALREADY +C STANDARDIZED, SO COPY IT "AS IS" INTO THE NEW SECTION 4 + + IF((LBYTO+LEN4+4).GT.MXBYTO) GOTO 905 + + CALL MVB(MSGIN,IAD4+1,MSGOT,LBYTO+1,LEN4) + + JBIT = (LBYTO+LEN4)*8 + + ELSE + + NAD4 = IAD3+LEN3 + + IBIT = (IAD4+4)*8 + JBIT = (NAD4+4)*8 + + LBYTO = LBYTO + 4 + +C COPY THE SUBSETS, MINUS THE BYTE COUNTERS AND BIT PADS, INTO +C THE NEW SECTION 4 + + NSUB = IUPBS3(MSGIN,'NSUB') + + DO 10 I=1,NSUB + CALL UPB(LSUB,16,MSGIN,IBIT) + DO L=1,LSUB-2 + CALL UPB(NVAL,8,MSGIN,IBIT) + LBYTO = LBYTO + 1 + IF(LBYTO.GT.MXBYTO) GOTO 905 + CALL PKB(NVAL,8,MSGOT,JBIT) + ENDDO + DO K=1,8 + KBIT = IBIT-K-8 + CALL UPB(KVAL,8,MSGIN,KBIT) + IF(KVAL.EQ.K) THEN + JBIT = JBIT-K-8 + GOTO 10 + ENDIF + ENDDO + GOTO 904 +10 ENDDO + +C FROM THIS POINT ON, WE WILL NEED (AT MOST) 6 MORE BYTES OF +C SPACE WITHIN MSGOT IN ORDER TO BE ABLE TO STORE THE ENTIRE +C STANDARDIZED MESSAGE (I.E. WE WILL NEED (AT MOST) 2 MORE +C ZEROED-OUT BYTES IN SECTION 4 PLUS THE 4 BYTES '7777' IN +C SECTION 5), SO DO A FINAL MSGOT OVERFLOW CHECK NOW. + + IF(LBYTO+6.GT.MXBYTO) GOTO 905 + +C PAD THE NEW SECTION 4 WITH ZEROES UP TO THE NEXT WHOLE BYTE +C BOUNDARY. + + DO WHILE(.NOT.(MOD(JBIT,8).EQ.0)) + CALL PKB(0,1,MSGOT,JBIT) + ENDDO + +C DEPENDING ON THE EDITION NUMBER, WE MAY NEED TO FURTHER PAD +C THE NEW SECTION 4 WITH AN ADDITIONAL ZEROED-OUT BYTE IN ORDER +C TO ENSURE THAT THE PADDING IS UP TO AN EVEN BYTE BOUNDARY. + + IF( (IBEN.LT.4) .AND. (MOD(JBIT/8,2).NE.0) ) THEN + CALL PKB(0,8,MSGOT,JBIT) + ENDIF + + IBIT = NAD4*8 + LEN4 = JBIT/8 - NAD4 + CALL PKB(LEN4,24,MSGOT,IBIT) + CALL PKB(0,8,MSGOT,IBIT) + ENDIF + +C FINISH THE NEW MESSAGE WITH AN UPDATED SECTION 0 BYTE COUNT +C ----------------------------------------------------------- + + IBIT = 32 + LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5 + CALL PKB(LENN,24,MSGOT,IBIT) + + CALL PKC('7777',4,MSGOT,JBIT) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') +901 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM'// + . ' SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL SECTION'// + . ' LENGTHS (",I6,")")') LENM,LENN + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT '// + . 'END WITH ""7777"" (ENDS WITH ",A)') SEVN + CALL BORT(BORT_STR) +903 CALL BORT('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR '// + . 'NOT FOUND') +904 CALL BORT('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 '// + . 'FROM INPUT TO OUTPUT (STANDARD) MESSAGE') +905 CALL BORT('BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) '// + . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + END diff --git a/src/bufr/stntbi.f b/src/bufr/stntbi.f new file mode 100644 index 0000000000..f525b12562 --- /dev/null +++ b/src/bufr/stntbi.f @@ -0,0 +1,69 @@ + SUBROUTINE STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STNTBI +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR +C TABLE B OR D, DEPENDING ON THE VALUE OF NUMB. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) +C INPUT ARGUMENT LIST: +C N - INTEGER: STORAGE INDEX INTO INTERNAL TABLE B OR D +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL TABLE B OR D +C NUMB - CHARACTER*6: FXY NUMBER FOR NEW TABLE B OR D ENTRY +C (IN FORMAT FXXYYY) +C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO NUMB +C CELSQ - CHARACTER*55: ELEMENT OR SEQUENCE DESCRIPTION +C CORRESPONDING TO NUMB +C +C REMARKS: +C THIS ROUTINE CALLS: IFXY NENUBD +C THIS ROUTINE IS CALLED BY: RDUSDX STSEQ +C Not normally called by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABA, TABB + + CHARACTER*(*) NUMB, NEMO, CELSQ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL NENUBD ( NEMO, NUMB, LUN ) + + IF ( NUMB(1:1) .EQ. '0') THEN + IDNB(N,LUN) = IFXY(NUMB) + TABB(N,LUN)( 1: 6) = NUMB(1:6) + TABB(N,LUN)( 7:14) = NEMO(1:8) + TABB(N,LUN)(16:70) = CELSQ(1:55) + NTBB(LUN) = N + ELSE IF ( NUMB(1:1) .EQ. '3') THEN + IDND(N,LUN) = IFXY(NUMB) + TABD(N,LUN)( 1: 6) = NUMB(1:6) + TABD(N,LUN)( 7:14) = NEMO(1:8) + TABD(N,LUN)(16:70) = CELSQ(1:55) + NTBD(LUN) = N + ENDIF + + RETURN + END diff --git a/src/bufr/stntbia.f b/src/bufr/stntbia.f new file mode 100644 index 0000000000..710a8d3f56 --- /dev/null +++ b/src/bufr/stntbia.f @@ -0,0 +1,95 @@ + SUBROUTINE STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STNTBIA +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR +C TABLE A. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) +C INPUT ARGUMENT LIST: +C N - INTEGER: STORAGE INDEX INTO INTERNAL TABLE A +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL TABLE A +C NUMB - CHARACTER*6: FXY NUMBER FOR NEW TABLE A ENTRY (IN +C FORMAT FXXYYY) +C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO NUMB +C CELSQ - CHARACTER*55: SEQUENCE DESCRIPTION CORRESPONDING +C TO NUMB +C +C REMARKS: +C THIS ROUTINE CALLS: BORT DIGIT +C THIS ROUTINE IS CALLED BY: RDUSDX READS3 STBFDX +C Not normally called by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABA, TABB + CHARACTER*128 BORT_STR + + CHARACTER*(*) NUMB, NEMO, CELSQ + + LOGICAL DIGIT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Confirm that neither NEMO nor NUMB has already been defined +C within the internal BUFR Table A (in COMMON /TABABD/) for +C the given LUN. + + DO N=1,NTBA(LUN) + IF(NUMB(4:6).EQ.TABA(N,LUN)(1: 3)) GOTO 900 + IF(NEMO(1:8).EQ.TABA(N,LUN)(4:11)) GOTO 901 + ENDDO + +C Store the values within the internal BUFR Table A. + + TABA(N,LUN)( 1: 3) = NUMB(4:6) + TABA(N,LUN)( 4:11) = NEMO(1:8) + TABA(N,LUN)(13:67) = CELSQ(1:55) + +C Decode and store the message type and subtype. + + IF ( DIGIT ( NEMO(3:8) ) ) THEN +c .... Message type & subtype obtained directly from Table A mnemonic + READ ( NEMO,'(2X,2I3)') MTYP, MSBT + IDNA(N,LUN,1) = MTYP + IDNA(N,LUN,2) = MSBT + ELSE +c .... Message type obtained from Y value of Table A seq. descriptor + READ ( NUMB(4:6),'(I3)') IDNA(N,LUN,1) +c .... Message subtype hardwired to ZERO + IDNA(N,LUN,2) = 0 + ENDIF + +C Update the count of internal Table A entries. + + NTBA(LUN) = N + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A FXY VALUE (",A,") ' + . //'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A MNEMONIC (",A,") ' + . //'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/strcln.f b/src/bufr/strcln.f new file mode 100644 index 0000000000..3c4f198e25 --- /dev/null +++ b/src/bufr/strcln.f @@ -0,0 +1,47 @@ + SUBROUTINE STRCLN + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STRCLN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE RESETS THE MNEMONIC STRING CACHE IN THE +C BUFR INTERFACE (ARRAYS IN COMMON BLOCK /STCACH/). THE MNEMONIC +C STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES TIME +C WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A PROGRAM, OVER +C AND OVER AGAIN (THE TYPICAL SCENARIO). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-04-02 J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50 +C ELEMENTS TO 1000, MAXIMUM +C 1998-07-08 J. WOOLLEN -- CORRECTED SOME MINOR ERRORS +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: CALL STRCLN +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: MAKESTAB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /STCACH/ MSTR,NSTR,LSTR,LUNS(MXS,2),USRS(MXS),ICON(52,MXS) + CHARACTER*80 USRS + + MSTR = MXS + NSTR = 0 + LSTR = 0 + RETURN + END diff --git a/src/bufr/strcpt.f b/src/bufr/strcpt.f new file mode 100644 index 0000000000..84a0a4ee29 --- /dev/null +++ b/src/bufr/strcpt.f @@ -0,0 +1,76 @@ + SUBROUTINE STRCPT(CF,IYR,IMO,IDY,IHR,IMI) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STRCPT +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE CAN BE CALLED AT ANY TIME AFTER THE FIRST +C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. WHEN CF IS SET TO +C 'Y' (= 'YES'), THIS SUBROUTINE IS USED TO SPECIFY A TANK RECEIPT +C TIME THAT WILL BE APPENDED TO SECTION 1 OF ALL FUTURE BUFR MESSAGES +C OUTPUT BY ANY OF THE BUFR ARCHIVE LIBRARY SUBROUTINES WHICH WRITE +C SUCH MESSAGES (E.G. WRITSB, COPYMG, WRITSA, ETC.). WHEN CF IS SET +C TO 'N' (= 'NO', WHICH IS THE DEFAULT), THIS CAPABILITY IS TURNED OFF +C (IF IT WAS PREVIOUSLY TURNED ON) AND THE VALUES IN ALL OF THE OTHER +C INPUT ARGUMENTS ARE IGNORED. THE TANK RECEIPT TIME IS A LOCAL +C EXTENSION TO SECTION 1; HOWEVER, ITS INCLUSION IN A MESSAGE IS +C STILL FULLY COMPLIANT WITH THE WMO FM-94 BUFR REGULATIONS. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL STRCPT (CF,IYR,IMO,IDY,IHR,IMI) +C INPUT ARGUMENT LIST: +C CF - CHARACTER*1: FLAG INDICATING WHETHER FUTURE CALLS TO +C BUFRLIB MESSAGE WRITING ROUTINES (E.G. WRITSB, COPYMG, +C WRITSA, ETC.) SHOULD APPEND THE GIVEN TANK RECEIPT +C TIME TO SECTION 1 OF SUCH MESSAGES: +C 'N' = 'NO' (THE DEFAULT) +C 'Y' = 'YES' +C IYR - INTEGER: TANK RECEIPT YEAR TO BE STORED +C IMO - INTEGER: TANK RECEIPT MONTH TO BE STORED +C IDY - INTEGER: TANK RECEIPT DAY TO BE STORED +C IHR - INTEGER: TANK RECEIPT HOUR TO BE STORED +C IMI - INTEGER: TANK RECEIPT MINUTE TO BE STORED +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CAPIT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT + + CHARACTER*128 BORT_STR + CHARACTER*1 CTRT, CF + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL CAPIT(CF) + IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 + + CTRT = CF + IF(CTRT.EQ.'Y') THEN + ITRYR = IYR + ITRMO = IMO + ITRDY = IDY + ITRHR = IHR + ITRMI = IMI + ENDIF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: STRCPT - INPUT ARGUMENT IS ",A1,'// + . '", IT MUST BE EITHER Y OR N")') CF + CALL BORT(BORT_STR) + END diff --git a/src/bufr/string.f b/src/bufr/string.f new file mode 100644 index 0000000000..6280a680b4 --- /dev/null +++ b/src/bufr/string.f @@ -0,0 +1,152 @@ + SUBROUTINE STRING(STR,LUN,I1,IO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STRING +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CHECKS TO SEE IF A USER-SPECIFIED CHARACTER +C STRING IS IN THE STRING CACHE (ARRAYS IN COMMON BLOCKS /STCACH/ AND +C /STORDS/). IF IT IS NOT IN THE CACHE, IT MUST CALL THE BUFR +C ARCHIVE LIBRARY PARSING SUBROUTINE PARUSR TO PERFORM THE TASK OF +C SEPARATING AND CHECKING THE INDIVIDUAL "PIECES" (I.E., MNEMONICS) +C SO THAT IT CAN THEN BE ADDED TO THE CACHE. IF IT IS ALREADY IN THE +C CACHE, THEN THIS EXTRA WORK DOES NOT NEED TO BE PERFORMED. THE +C MNEMONIC STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES +C TIME WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A USER +C PROGRAM, OVER AND OVER AGAIN (THE TYPICAL SCENARIO). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-04-02 J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50 +C ELEMENTS TO 1000, MAXIMUM; OPTIMIZATION OF +C THE CACHE SEARCH ALGORITHM IN SUPPORT OF A +C BIGGER CACHE +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY; CHANGED CALL FROM +C BORT TO BORT2 +C +C USAGE: CALL STRING (STR, LUN, I1, IO) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C OUTPUT ARGUMENT LIST: +C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER +C OF BLANK-SEPARATED MNEMONICS IN STR +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUN: +C 0 = input file +C 1 = output file +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 PARUSR +C THIS ROUTINE IS CALLED BY: UFBEVN UFBGET UFBIN3 UFBINT +C UFBOVR UFBREP UFBSTP UFBTAB +C UFBTAM +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + PARAMETER (JCONS=52) + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /STCACH/ MSTR,NSTR,LSTR,LUX(MXS,2),USR(MXS),ICON(JCONS,MXS) + COMMON /USRSTR/ JCON(JCONS) + COMMON /STORDS/ IORD(MXS),IORX(MXS) + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*80 USR,UST + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + NXT = 0 + UST = STR + IND = INODE(LUN) + IF(LEN(STR).GT.80) GOTO 900 + +C Note that LSTR, MSTR and NSTR were initialized via a prior call to +C subroutine STRCLN, which itself was called by subroutine MAKESTAB. + +C SEE IF STRING IS IN THE CACHE +C ----------------------------- + + DO N=1,NSTR + IF(LUX(IORD(N),2).EQ.IND) THEN + IORX(NXT+1) = IORD(N) + NXT = NXT+1 + ENDIF + ENDDO + DO N=1,NXT + IF(UST.EQ.USR(IORX(N)))GOTO1 + ENDDO + GOTO2 + +C IF IT IS IN THE CACHE, COPY PARAMETERS FROM THE CACHE +C ----------------------------------------------------- + +1 DO J=1,JCONS + JCON(J) = ICON(J,IORX(N)) + ENDDO + GOTO 100 + +C IF IT IS NOT IN THE CACHE, PARSE IT AND PUT IT THERE +C ---------------------------------------------------- + +2 CALL PARUSR(STR,LUN,I1,IO) + LSTR = MAX(MOD(LSTR+1,MSTR+1),1) + NSTR = MIN(NSTR+1,MSTR) +c .... File + LUX(LSTR,1) = LUN +c .... Table A entry + LUX(LSTR,2) = IND + USR(LSTR) = STR + DO J=1,JCONS + ICON(J,LSTR) = JCON(J) + ENDDO + +C REARRANGE THE CACHE ORDER AFTER AN UPDATE +C ----------------------------------------- + + DO N=NSTR,2,-1 + IORD(N) = IORD(N-1) + ENDDO + IORD(1) = LSTR + +100 IF(JCON(1).GT.I1) GOTO 901 + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR1,'("BUFRLIB: STRING - INPUT STRING (",A,") HAS")') + . STR + WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') + . LEN(STR) + CALL BORT2(BORT_STR1,BORT_STR2) +901 WRITE(BORT_STR1,'("BUFRLIB: STRING - INPUT STRING (",A,")")') STR + WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// + . 'LIMIT (THIRD INPUT ARGUMENT) IS",I5)') JCON(1),I1 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/strnum.f b/src/bufr/strnum.f new file mode 100644 index 0000000000..127739f155 --- /dev/null +++ b/src/bufr/strnum.f @@ -0,0 +1,88 @@ + SUBROUTINE STRNUM(STR,NUM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STRNUM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE DECODES AN INTEGER FROM A CHARACTER STRING. +C THE INPUT STRING SHOULD CONTAIN ONLY DIGITS AND (OPTIONAL) TRAILING +C BLANKS AND SHOULD NOT CONTAIN ANY SIGN CHARACTERS (E.G. '+', '-') +C NOR LEADING BLANKS NOR EMBEDDED BLANKS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL STRNUM (STR, NUM) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE +C +C OUTPUT ARGUMENT LIST: +C NUM - INTEGER: DECODED VALUE +C -1 = decode was unsuccessful +C +C REMARKS: +C THIS ROUTINE CALLS: ERRWRT STRSUC +C THIS ROUTINE IS CALLED BY: JSTNUM PARUTG SEQSDX STSEQ +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR + CHARACTER*20 STR2 + + COMMON /QUIET / IPRT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + NUM = 0 + K = 0 + +C Note that, in the following call to subroutine STRSUC, the output +C string STR2 is not used anywhere else in this routine. In fact, +C the only reason that subroutine STRSUC is being called here is to +C determine NUM, which, owing to the fact that the input string STR +C cannot contain any leading blanks, is equal to the number of +C digits to be decoded from the beginning of STR. + + CALL STRSUC(STR,STR2,NUM) + IF(NUM.EQ.-1) GOTO 100 + + DO I=1,NUM + READ(STR(I:I),'(I1)',ERR=99) J + IF(J.EQ.0 .AND. STR(I:I).NE.'0') GOTO 99 + K = K*10+J + ENDDO + + NUM = K + GOTO 100 + +C Note that NUM = -1 unambiguously indicates a bad decode since +C the input string cannot contain sign characters; thus, NUM is +C always positive if the decode is successful. + +99 NUM = -1 + IF(IPRT.GE.0) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT('BUFRLIB: STRNUM - BAD DECODE; RETURN WITH NUM = -1') + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/strsuc.f b/src/bufr/strsuc.f new file mode 100644 index 0000000000..ead6e1f486 --- /dev/null +++ b/src/bufr/strsuc.f @@ -0,0 +1,95 @@ + SUBROUTINE STRSUC(STR1,STR2,LENS) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STRSUC +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A +C STRING. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; ADDED MORE COMPLETE +C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL STRSUC (STR1, STR2, LENS) +C INPUT ARGUMENT LIST: +C STR1 - CHARACTER*(*): STRING +C +C OUTPUT ARGUMENT LIST: +C STR2 - CHARACTER*(*): COPY OF STR1 WITH LEADING AND TRAILING +C BLANKS REMOVED +C LENS - INTEGER: LENGTH OF STR2: +C -1 = STR1 contained embedded blanks +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: DXDUMP ERRWRT MTINFO STRNUM +C UFDUMP +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) STR1,STR2 + + COMMON /QUIET / IPRT + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LENS = 0 + LSTR = LEN(STR1) + +C FIND THE FIRST NON-BLANK IN THE INPUT STRING +C -------------------------------------------- + + DO I=1,LSTR + IF(STR1(I:I).NE.' ') GOTO 2 + ENDDO + GOTO 100 + +C Now, starting with the first non-blank in the input string, +C copy characters from the input string into the output string +C until reaching the next blank in the input string. + +2 DO J=I,LSTR + IF(STR1(J:J).EQ.' ') GOTO 3 + LENS = LENS+1 + STR2(LENS:LENS) = STR1(J:J) + ENDDO + GOTO 100 + +C Now, continuing on within the input string, make sure that +C there are no more non-blank characters. If there are, then +C the blank at which we stopped copying from the input string +C into the output string was an embedded blank. + +3 DO I=J,LSTR + IF(STR1(I:I).NE.' ') LENS = -1 + ENDDO + + IF(LENS.EQ.-1 .AND. IPRT.GE.0) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT('BUFRLIB: STRSUC - INPUT STRING:') + CALL ERRWRT(STR1) + CALL ERRWRT('CONTAINS ONE OR MORE EMBEDDED BLANKS') + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/stseq.c b/src/bufr/stseq.c new file mode 100644 index 0000000000..931f10c9e4 --- /dev/null +++ b/src/bufr/stseq.c @@ -0,0 +1,407 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: STSEQ +C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: USING THE BUFR MASTER TABLES, THIS ROUTINE STORES ALL +C OF THE INFORMATION FOR SEQUENCE IDN WITHIN THE INTERNAL BUFR +C TABLES B AND D. ANY DESCRIPTORS IN IDN WHICH ARE THEMSELVES +C SEQUENCES ARE IMMEDIATELY RESOLVED VIA A RECURSIVE CALL TO THIS +C SAME ROUTINE. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR +C 2010-03-19 J. ATOR -- ADDED PROCESSING FOR 2-04 ASSOCIATED FIELDS +C 2010-04-05 J. ATOR -- ADDED PROCESSING FOR 2-2X, 2-3X AND 2-4X +C NON-MARKER OPERATORS +C +C USAGE: CALL STSEQ( LUN, IREPCT, IDN, NEMO, CSEQ, CDESC, NCDESC ) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IREPCT - INTEGER: REPLICATION SEQUENCE COUNTER FOR THE CURRENT +C MASTER TABLE; USED INTERNALLY TO KEEP TRACK OF WHICH +C SEQUENCE NAMES HAVE ALREADY BEEN DEFINED AND THEREBY +C AVOID CONTENTION WITHIN THE INTERNAL BUFR TABLE D +C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE FOR +C SEQUENCE TO BE STORED +C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO IDN +C CSEQ - CHARACTER*55: DESCRIPTION CORRESPONDING TO IDN +C CDESC - INTEGER: ARRAY OF BIT-WISE REPRESENTATIONS OF FXY +C VALUES CORRESPONDING TO DESCRIPTORS WHICH CONSTITUTE +C THE IDN SEQUENCE +C NCDESC - INTEGER: NUMBER OF VALUES IN CDESC +C +C OUTPUT ARGUMENT LIST: +C IREPCT - INTEGER: REPLICATION SEQUENCE COUNTER FOR THE CURRENT +C MASTER TABLE; USED INTERNALLY TO KEEP TRACK OF WHICH +C SEQUENCE NAMES HAVE ALREADY BEEN DEFINED AND THEREBY +C AVOID CONTENTION WITHIN THE INTERNAL BUFR TABLE D +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CADN30 ELEMDX ICVIDX +C IFXY IGETNTBI IGETTDI NEMTAB +C NUMMTB NUMTBD PKTDD STNTBI +C STRNUM STSEQ +C THIS ROUTINE IS CALLED BY: READS3 STSEQ +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#define COMMON_MSTABS +#include "bufrlib.h" + +void stseq( f77int *lun, f77int *irepct, f77int *idn, char nemo[8], + char cseq[55], f77int cdesc[], f77int *ncdesc ) +{ + f77int i, j, nb, nd, ipt, ix, iy, iret, nbits; + f77int i0 = 0, imxcd = MAXCD; + f77int rpdesc[MAXCD], rpidn, pkint; + + char tab, adn[7], adn2[7], nemo2[9], units[10], errstr[129]; + char rpseq[56], card[80], cblk = ' '; + +/* +** The following variables are declared as static so that they +** automatically initialize to zero and remain unchanged between +** recursive calls to this subroutine. +*/ + static f77int naf, iafpk[MXNAF]; + +/* +** Is *idn already listed as an entry in the internal Table D? +** If so, then there's no need to proceed any further. +*/ + numtbd( lun, idn, nemo2, &tab, &iret, sizeof( nemo2 ), sizeof( tab ) ); + if ( ( iret > 0 ) && ( tab == 'D' ) ) return; + +/* +** Start a new Table D entry for *idn. +*/ + tab = 'D'; + nd = igetntbi( lun, &tab, sizeof ( tab ) ); + cadn30( idn, adn, sizeof( adn ) ); + stntbi( &nd, lun, adn, nemo, cseq, sizeof( adn ), 8, 55 ); + +/* +** Now, go through the list of child descriptors corresponding to *idn. +*/ + for ( i = 0; i < *ncdesc; i++ ) { + cadn30( &cdesc[i], adn, sizeof( adn ) ); + if ( adn[0] == '3' ) { +/* +** cdesc[i] is itself a Table D descriptor, so search for it within the +** master table D and then, if found, immediately store it within the +** internal Table D via a recursive call to this same routine. +*/ + nummtb( &cdesc[i], &tab, &ipt ); + stseq( lun, irepct, &cdesc[i], &mstabs.cdmnem[ipt][0], + &mstabs.cdseq[ipt][0], + &mstabs.idefxy[icvidx(&ipt,&i0,&imxcd)], + &mstabs.ndelem[ipt] ); + pkint = cdesc[i]; + } + else if ( adn[0] == '2' ) { +/* +** cdesc[i] is an operator descriptor. +*/ + strnum( &adn[3], &iy, 3 ); + + if ( ( adn[1] == '0' ) && + ( ( adn[2] >= '4' ) && ( adn[2] <= '6' ) ) ) { +/* +** This is a 204YYY, 205YYY or 206YYY operator. Using the YYY +** value, generate a Table B mnemonic to hold the corresponding +** data. +*/ + strncpy( nemo2, "20", 2 ); + strncpy( &nemo2[2], &adn[2], 1 ); + strncpy( &nemo2[3], &adn[3], 3 ); + memset( &nemo2[6], (int) cblk, 2 ); + + if ( ( adn[2] == '4' ) && ( iy == 0 ) ) { +/* +** Cancel the most-recently added associated field. +*/ + if ( naf-- <= 0 ) { + sprintf( errstr, "BUFRLIB: STSEQ - TOO MANY ASSOCIATED" + " FIELD CANCELLATION OPERATORS" ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + } + else { +/* +** Is nemo2 already listed as an entry within the internal +** Table B? +*/ + nemtab( lun, nemo2, &pkint, &tab, &iret, 8, sizeof( tab ) ); + if ( ( iret == 0 ) || ( tab != 'B' ) ) { +/* +** No, so create and store a new Table B entry for nemo2. +*/ + tab = 'B'; + nb = igetntbi( lun, &tab, sizeof( tab ) ); + + if ( adn[2] == '4' ) { + sprintf( rpseq, "ASSOCIATED FIELD OF %3lu BITS", + ( unsigned long ) iy ); + memset( &rpseq[28], (int) cblk, 27 ); + nbits = iy; + strcpy( units, "NUMERIC" ); + } + else if ( adn[2] == '5' ) { + sprintf( rpseq, "TEXT STRING OF %3lu BYTES", + ( unsigned long ) iy ); + memset( &rpseq[24], (int) cblk, 31 ); + nbits = iy*8; + strcpy( units, "CCITT IA5" ); + } + else { + sprintf( rpseq, "LOCAL DESCRIPTOR OF %3lu BITS", + ( unsigned long ) iy ); + memset( &rpseq[28], (int) cblk, 27 ); + nbits = iy; + if ( nbits > 32 ) { + strcpy( units, "CCITT IA5" ); + } + else { + strcpy( units, "NUMERIC" ); + } + } +/* +** Note that 49152 = 3*(2**14), so subtracting 49152 in the +** following statement changes a Table D bitwise FXY value into +** a Table B bitwise FXY value. +*/ + pkint = ( igettdi( lun ) - 49152 ); + cadn30( &pkint, adn2, sizeof( adn2 ) ); + + stntbi( &nb, lun, adn2, nemo2, rpseq, + sizeof( adn2 ), 8, 55 ); + + /* Initialize card to all blanks. */ + memset( card, (int) cblk, sizeof( card ) ); + + strncpy( &card[2], nemo2, 8 ); + strncpy( &card[16], "0", 1 ); + strncpy( &card[30], "0", 1 ); + sprintf( &card[33], "%4lu", ( unsigned long ) nbits ); + strncpy( &card[40], units, strlen( units ) ); + elemdx( card, lun, sizeof( card ) ); + } + if ( adn[2] == '4' ) { +/* +** Add an associated field. +*/ + if ( naf >= MXNAF ) { + sprintf( errstr, "BUFRLIB: STSEQ - TOO MANY ASSOCIATED" + " FIELDS ARE IN EFFECT AT THE SAME TIME" ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + iafpk[naf++] = pkint; + } + } + if ( adn[2] == '6' ) { +/* +** Skip over the local descriptor placeholder. +*/ + if ( ++i >= *ncdesc ) { + sprintf( errstr, "BUFRLIB: STSEQ - COULD NOT FIND LOCAL" + " DESCRIPTOR PLACEHOLDER FOR %s", adn ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + } + } + else if ( ( adn[1] >= '2' ) && ( adn[1] <= '4' ) ) { +/* +** This is a 22XYYY, 23XYYY or 24XYYY operator. +*/ + strnum( &adn[1], &ix, 2 ); + if ( ( iy == 255 ) && + ( ( ix == 23 ) || ( ix == 24 ) || + ( ix == 25 ) || ( ix == 32 ) ) ) { + sprintf( errstr, "BUFRLIB: STSEQ - UNKNOWN OPERATOR" + " DESCRIPTOR %s", adn ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + else { + continue; /* skip to next child descriptor for *idn */ + } + } + else { /* for any operator descriptor other than 204YYY, 205YYY, + 206YYY, 22XYYY, 23XYYY or 24XYYY */ + pkint = cdesc[i]; + } + } + else if ( adn[0] == '1' ) { +/* +** cdesc[i] is a replication descriptor, so create a sequence +** consisting of the set of replicated descriptors and then immediately +** store that sequence within the internal Table D via a recursive call +** to this same routine. +*/ + adn[6] = '\0'; + + strnum( &adn[3], &iy, 3 ); +/* +** See subroutine BFRINI and COMMON /REPTAB/ for the source of the FXY +** values referenced in the following block. Note we are guaranteed +** that 0 <= iy <= 255 since adn was generated using subroutine CADN30. +*/ + if ( iy == 0 ) { /* delayed replication */ + if ( ( i+1 ) >= *ncdesc ) { + sprintf( errstr, "BUFRLIB: STSEQ - COULD NOT FIND DELAYED " + "DESCRIPTOR REPLICATION FACTOR FOR %s", adn ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + else if ( cdesc[i+1] == ifxy( "031002", 6 ) ) { + pkint = ifxy( "360001", 6 ); + } + else if ( cdesc[i+1] == ifxy( "031001", 6 ) ) { + pkint = ifxy( "360002", 6 ); + } + else if ( cdesc[i+1] == ifxy( "031000", 6 ) ) { + pkint = ifxy( "360004", 6 ); + } + else { + sprintf( errstr, "BUFRLIB: STSEQ - UNKNOWN DELAYED " + "DESCRIPTOR REPLICATION FACTOR FOR %s", adn ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + i += 2; + } + else { /* regular replication */ + pkint = ifxy( "101000", 6 ) + iy; + i++; + } +/* +** Store this replication descriptor within the table D entry for +** this parent. +*/ + pktdd( &nd, lun, &pkint, &iret ); + if ( iret < 0 ) { + strncpy( nemo2, nemo, 8 ); + nemo2[8] = '\0'; + sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD WHEN " + "STORING REPLICATOR FOR PARENT MNEMONIC %s", nemo2 ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + + strnum( &adn[1], &ix, 2 ); +/* +** Note we are guaranteed that 0 < ix <= 63 since adn was generated +** using subroutine CADN30. +*/ + if ( ix > ( *ncdesc - i ) ) { + sprintf( errstr, "BUFRLIB: STSEQ - NOT ENOUGH REMAINING CHILD " + "DESCRIPTORS TO COMPLETE REPLICATION FOR %s", adn ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + else if ( ( ix == 1 ) && ( cdesc[i] >= ifxy ( "300000", 6 ) ) ) { +/* +** The only thing being replicated is a single Table D descriptor, +** so there's no need to invent a new sequence for this replication +** (this is a special case!) +*/ + nummtb( &cdesc[i], &tab, &ipt ); + stseq( lun, irepct, &cdesc[i], &mstabs.cdmnem[ipt][0], + &mstabs.cdseq[ipt][0], + &mstabs.idefxy[icvidx(&ipt,&i0,&imxcd)], + &mstabs.ndelem[ipt] ); + pkint = cdesc[i]; + } + else { +/* +** Store the ix descriptors to be replicated in a local list, then +** get an FXY value to use with this list and generate a unique +** mnemonic and description as well. +*/ + for ( j = 0; j < ix; j++ ) { + rpdesc[j] = cdesc[i+j]; + } + + rpidn = igettdi( lun ); + + sprintf( rpseq, "REPLICATION SEQUENCE %.3lu", + ( unsigned long ) ++(*irepct) ); + memset( &rpseq[24], (int) cblk, 31 ); + sprintf( nemo2, "RPSEQ%.3lu", ( unsigned long ) *irepct ); + + stseq( lun, irepct, &rpidn, nemo2, rpseq, rpdesc, &ix ); + + pkint = rpidn; + i += ix - 1; + } + } + else { +/* +** cdesc[i] is a Table B descriptor. +** +** Is cdesc[i] already listed as an entry in the internal Table B? +*/ + numtbd( lun, &cdesc[i], nemo2, &tab, &iret, sizeof( nemo2 ), + sizeof( tab ) ); + if ( ( iret == 0 ) || ( tab != 'B' ) ) { +/* +** No, so search for it within the master table B. +*/ + nummtb( &cdesc[i], &tab, &ipt ); +/* +** Start a new Table B entry for cdesc[i]. +*/ + nb = igetntbi( lun, &tab, sizeof( tab ) ); + cadn30( &cdesc[i], adn2, sizeof( adn2 ) ); + stntbi( &nb, lun, adn2, &mstabs.cbmnem[ipt][0], + &mstabs.cbelem[ipt][0], sizeof( adn2 ), 8, 55 ); + + /* Initialize card to all blanks. */ + memset( card, (int) cblk, sizeof( card ) ); + + strncpy( &card[2], &mstabs.cbmnem[ipt][0], 8 ); + strncpy( &card[13], &mstabs.cbscl[ipt][0], 4 ); + strncpy( &card[19], &mstabs.cbsref[ipt][0], 12 ); + strncpy( &card[33], &mstabs.cbbw[ipt][0], 4 ); + strncpy( &card[40], &mstabs.cbunit[ipt][0], 14 ); + elemdx( card, lun, sizeof( card ) ); + } + pkint = cdesc[i]; + } + if ( strncmp( adn, "204", 3 ) != 0 ) { +/* +** Store this child descriptor within the table D entry for this +** parent, preceding it with any associated fields that are currently +** in effect. +** +** Note that associated fields are only applied to Table B descriptors, +** except for those in Class 31. +*/ + if ( ( naf > 0 ) && ( pkint < ifxy( "100000", 6 ) ) && + ( ( pkint < ifxy( "031000", 6 ) ) || + ( pkint > ifxy( "031255", 6 ) ) ) ) { + for ( j = 0; j < naf; j++ ) { + pktdd( &nd, lun, &iafpk[j], &iret ); + if ( iret < 0 ) { + sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD " + "WHEN STORING ASSOCIATED FIELDS" ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + } + } +/* +** Store the child descriptor. +*/ + pktdd( &nd, lun, &pkint, &iret ); + if ( iret < 0 ) { + strncpy( nemo2, nemo, 8 ); + nemo2[8] = '\0'; + sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD WHEN " + "STORING CHILD FOR PARENT MNEMONIC %s", nemo2 ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + } + } +} diff --git a/src/bufr/tabent.f b/src/bufr/tabent.f new file mode 100644 index 0000000000..cf8d90e065 --- /dev/null +++ b/src/bufr/tabent.f @@ -0,0 +1,184 @@ + SUBROUTINE TABENT(LUN,NEMO,TAB,ITAB,IREP,IKNT,JUM0) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: TABENT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE BUILDS AND STORES AN ENTRY FOR A TABLE B OR +C TABLE D MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS +C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 OPERATOR +C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR +C +C USAGE: CALL TABENT (LUN, NEMO, TAB, ITAB, IREP, IKNT, JUM0) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C NEMO - CHARACTER*8: TABLE B OR D MNEMONIC TO STORE IN JUMP/ +C LINK TABLE +C TAB - CHARACTER*1: INTERNAL BUFR TABLE ARRAY ('B' OR 'D') IN +C WHICH NEMO IS DEFINED +C ITAB - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB +C IREP - INTEGER: POSITIONAL INDEX WITHIN COMMON /REPTAB/ +C ARRAYS, FOR USE WHEN NEMO IS REPLICATED: +C 0 = NEMO is not replicated +C IKNT - INTEGER: NUMBER OF REPLICATIONS, FOR USE WHEN NEMO IS +C REPLICATED USING F=1 REGULAR (I.E., NON-DELAYED) +C REPLICATION: +C 0 = NEMO is not replicated using F=1 regular +C (i.e., non-delayed) replication +C JUM0 - INTEGER: INDEX VALUE TO BE STORED FOR NEMO WITHIN +C INTERNAL JUMP/LINK TABLE ARRAY JMPB(*) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT INCTAB NEMTBB +C THIS ROUTINE IS CALLED BY: TABSUB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + +C Note that the values within the COMMON /REPTAB/ arrays were +C initialized within subroutine BFRINI. + + COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW + COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), + . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV + + CHARACTER*128 BORT_STR + CHARACTER*24 UNIT + CHARACTER*10 TAG,RTAG + CHARACTER*8 NEMO,TAGNRV + CHARACTER*3 TYP,TYPS,TYPT + CHARACTER*1 REPS,TAB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C MAKE A JUMP/LINK TABLE ENTRY FOR A REPLICATOR +C --------------------------------------------- + + IF(IREP.NE.0) THEN + RTAG = REPS(IREP,1)//NEMO + DO I=1,10 + IF(RTAG(I:I).EQ.' ') THEN + RTAG(I:I) = REPS(IREP,2) + CALL INCTAB(RTAG,TYPS(IREP,1),NODE) + JUMP(NODE) = NODE+1 + JMPB(NODE) = JUM0 + LINK(NODE) = 0 + IBT (NODE) = LENS(IREP) + IRF (NODE) = 0 + ISC (NODE) = 0 + IF(IREP.EQ.1) IRF(NODE) = IKNT + JUM0 = NODE + GOTO 1 + ENDIF + ENDDO + GOTO 900 + ENDIF + +C MAKE AN JUMP/LINK ENTRY FOR AN ELEMENT OR A SEQUENCE +C ---------------------------------------------------- + +1 IF(TAB.EQ.'B') THEN + + CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) + IF(UNIT(1:5).EQ.'CCITT') THEN + TYPT = 'CHR' + ELSE + TYPT = 'NUM' + ENDIF + CALL INCTAB(NEMO,TYPT,NODE) + JUMP(NODE) = 0 + JMPB(NODE) = JUM0 + LINK(NODE) = 0 + IBT (NODE) = IBIT + IRF (NODE) = IREF + ISC (NODE) = ISCL + IF(UNIT(1:4).EQ.'CODE') THEN + TYPT = 'COD' + ELSEIF(UNIT(1:4).EQ.'FLAG') THEN + TYPT = 'FLG' + ENDIF + + IF( (TYPT.EQ.'NUM') .AND. (IBTNRV.NE.0) ) THEN + +C This node contains a new (redefined) reference value. + + IF(NNRV+1.GT.MXNRV) GOTO 902 + NNRV = NNRV+1 + TAGNRV(NNRV) = NEMO + INODNRV(NNRV) = NODE + ISNRV(NNRV) = NODE+1 + IBT(NODE) = IBTNRV + IF(IPFNRV.EQ.0) IPFNRV = NNRV + ELSEIF( (TYPT.EQ.'NUM') .AND. (NEMO(1:3).NE.'204') ) THEN + IBT(NODE) = IBT(NODE) + ICDW + ISC(NODE) = ISC(NODE) + ICSC + IRF(NODE) = IRF(NODE) * ICRV + ELSEIF( (TYPT.EQ.'CHR') .AND. (INCW.GT.0) ) THEN + IBT(NODE) = INCW * 8 + ENDIF + + ELSEIF(TAB.EQ.'D') THEN + + IF(IREP.EQ.0) THEN + TYPT = 'SEQ' + ELSE + TYPT = TYPS(IREP,2) + ENDIF + CALL INCTAB(NEMO,TYPT,NODE) + JUMP(NODE) = NODE+1 + JMPB(NODE) = JUM0 + LINK(NODE) = 0 + IBT (NODE) = 0 + IRF (NODE) = 0 + ISC (NODE) = 0 + + ELSE + + GOTO 901 + + ENDIF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: TABENT - REPLICATOR ERROR FOR INPUT '// + . 'MNEMONIC ",A,", RTAG IS ",A)') NEMO,RTAG + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: TABENT - UNDEFINED TAG (",A,") FOR '// + . 'INPUT MNEMONIC ",A)') TAB,NEMO + CALL BORT(BORT_STR) +902 CALL BORT('BUFRLIB: TABENT - MXNRV OVERFLOW') + END diff --git a/src/bufr/tabsub.f b/src/bufr/tabsub.f new file mode 100644 index 0000000000..a181daa9e3 --- /dev/null +++ b/src/bufr/tabsub.f @@ -0,0 +1,460 @@ + SUBROUTINE TABSUB(LUN,NEMO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: TABSUB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E., +C INCLUDING RECURSIVELY RESOLVING ALL "CHILD" MNEMONICS) FOR A TABLE +C A MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA +C USING THE OPERATOR DESCRIPTORS (BUFR TABLE +C C) FOR CHANGING WIDTH AND CHANGING SCALE +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS +C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR +C 2012-04-19 J. ATOR -- FIXED BUG FOR CASES WHERE A TABLE C OPERATOR +C IMMEDIATELY FOLLOWS A TABLE D SEQUENCE +C +C USAGE: CALL TABSUB (LUN, NEMO) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C NEMO - CHARACTER*8: TABLE A MNEMONIC +C +C REMARKS: +C ----------------------------------------------------------------- +C EXAMPLE SHOWING CONTENTS OF INTERNAL JUMP/LINK TABLE (WITHIN +C COMMON /TABLES/): +C +C INTEGER MAXTAB = maximum number of jump/link table entries +C +C INTEGER NTAB = actual number of jump/link table entries +C currently in use +C +C For I = 1, NTAB: +C +C CHARACTER*10 TAG(I) = mnemonic +C +C CHARACTER*3 TYP(I) = mnemonic type indicator: +C "SUB" if TAG(I) is a Table A mnemonic +C "SEQ" if TAG(I) is a Table D mnemonic using either short +C (i.e. 1-bit) delayed replication, F=1 regular (i.e. +C non-delayed) replication, or no replication at all +C "RPC" if TAG(I) is a Table D mnemonic using either medium +C (i.e. 8-bit) delayed replication or long (i.e. 16-bit) +C delayed replication +C "RPS" if TAG(I) is a Table D mnemonic using medium +C (i.e. 8-bit) delayed replication in a stack context +C "DRB" if TAG(I) denotes the short (i.e. 1-bit) delayed +C replication of a Table D mnemonic (which would then +C itself have its own separate entry in the jump/link +C table with a corresponding TAG value of "SEQ") +C "DRP" if TAG(I) denotes either the medium (i.e. 8-bit) or +C long (i.e. 16-bit) delayed replication of a Table D +C mnemonic (which would then itself have its own separate +C entry in the jump/link table with a corresponding TAG +C value of "RPC") +C "DRS" if TAG(I) denotes the medium (i.e. 8-bit) delayed +C replication, in a stack context, of a Table D mnemonic +C (which would then itself have its own separate entry +C in the jump/link table with a corresponding TAG value +C of "RPS") +C "REP" if TAG(I) denotes the F=1 regular (i.e. non-delayed) +C replication of a Table D mnemonic (which would then +C itself have its own separate entry in the jump/link +C table with a corresponding TAG value of "SEQ") +C "CHR" if TAG(I) is a Table B mnemonic with units "CCITT IA5" +C "NUM" if TAG(I) is a Table B mnemonic with any units other +C than "CCITT IA5" +C +C INTEGER JMPB(I): +C +C IF ( TYP(I) = "SUB" ) THEN +C JMPB(I) = 0 +C ELSE IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. +C 1-bit) delayed replication or F=1 regular (i.e. +C non-delayed) replication ) +C OR +C ( TYP(I) = "RPC" ) ) THEN +C JMPB(I) = the index of the jump/link table entry denoting +C the replication of TAG(I) +C ELSE +C JMPB(I) = the index of the jump/link table entry for the +C Table A or Table D mnemonic of which TAG(I) is a +C child +C END IF +C +C INTEGER JUMP(I): +C +C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN +C JUMP(I) = 0 +C ELSE IF ( ( TYP(I) = "DRB" ) OR +C ( TYP(I) = "DRP" ) OR +C ( TYP(I) = "REP" ) ) THEN +C JUMP(I) = the index of the jump/link table entry for the +C Table D mnemonic whose replication is denoted by +C TAG(I) +C ELSE +C JUMP(I) = the index of the jump/link table entry for the +C Table B or Table D mnemonic which, sequentially, +C is the first child of TAG(I) +C END IF +C +C INTEGER LINK(I): +C +C IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. +C 1-bit) delayed replication or F=1 regular (i.e. non- +C delayed) replication ) +C OR +C ( TYP(I) = "SUB" ) +C OR +C ( TYP(I) = "RPC" ) ) THEN +C LINK(I) = 0 +C ELSE IF ( TAG(I) is, sequentially, the last child Table B or +C Table D mnemonic of the parent Table A or Table D +C mnemonic indexed by JMPB(I) ) THEN +C LINK(I) = 0 +C ELSE +C LINK(I) = the index of the jump/link table entry for the +C Table B or Table D mnemonic which, sequentially, +C is the next (i.e. following TAG(I)) child mnemonic +C of the parent Table A or Table D mnemonic indexed +C by JMPB(I) +C END IF +C +C INTEGER IBT(I): +C +C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN +C IBT(I) = bit width of Table B mnemonic TAG(I) +C ELSE IF ( ( TYP(I) = "DRB" ) OR ( TYP(I) = "DRP" ) ) THEN +C IBT(I) = bit width of delayed descriptor replication factor +C (i.e. 1, 8, or 16, depending on the replication +C scheme denoted by TAG(I)) +C ELSE +C IBT(I) = 0 +C END IF +C +C INTEGER IRF(I): +C +C IF ( TYP(I) = "NUM" ) THEN +C IRF(I) = reference value of Table B mnemonic TAG(I) +C ELSE IF ( TYP(I) = "REP" ) THEN +C IRF(I) = number of F=1 regular (i.e. non-delayed) +C replications of Table D mnemonic TAG(JUMP(I)) +C ELSE +C IRF(I) = 0 +C END IF +C +C INTEGER ISC(I): +C +C IF ( TYP(I) = "NUM" ) THEN +C ISC(I) = scale factor of Table B mnemonic TAG(I) +C ELSE IF ( TYP(I) = "SUB" ) THEN +C ISC(I) = the index of the jump/link table entry which, +C sequentially, constitutes the last element of the +C jump/link tree for Table A mnemonic TAG(I) +C ELSE +C ISC(I) = 0 +C END IF +C +C ----------------------------------------------------------------- +C +C THE FOLLOWING VALUES ARE STORED WITHIN COMMON /NRV203/ BY THIS +C SUBROUTINE, FOR USE WITH ANY 2-03-YYY (CHANGE REFERENCE VALUE) +C OPERATORS PRESENT WITHIN THE ENTIRE JUMP/LINK TABLE: +C +C NNRV = number of nodes in the jump/link table which contain new +C reference values (as defined using the 2-03 operator) +C +C INODNRV(I=1,NNRV) = nodes within jump/link table which contain +C new reference values +C +C NRV(I=1,NNRV) = new reference value corresponding to INODNRV(I) +C +C TAGNRV(I=1,NNRV) = Table B mnemonic to which the new reference +C value in NRV(I) applies +C +C ISNRV(I=1,NNRV) = start of node range in jump/link table, +C within which the new reference value defined +C by NRV(I) will be applied to all occurrences +C of TAGNRV(I) +C +C IENRV(I=1,NNRV) = end of node range in jump/link table, +C within which the new reference value defined +C by NRV(I) will be applied to all occurrences +C of TAGNRV(I) +C +C IBTNRV = number of bits in Section 4 occupied by each new +C reference value for the current 2-03 operator +C (if IBTNRV = 0, then no 2-03 operator is currently +C in scope) +C +C IPFNRV = a number between 1 and NNRV, denoting the first entry +C within the above arrays which applies to the current +C Table A mnemonic NEMO (if IPFNRV = 0, then no 2-03 +C operators have been applied to NEMO) +C +C ----------------------------------------------------------------- +C +C THIS ROUTINE CALLS: BORT INCTAB NEMTAB NEMTBD +C TABENT +C THIS ROUTINE IS CALLED BY: MAKESTAB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW + COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), + . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV + + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*8 NEMO,NEMS,NEM,TAGNRV + CHARACTER*3 TYP + CHARACTER*1 TAB + DIMENSION NEM(MAXCD,10),IRP(MAXCD,10),KRP(MAXCD,10) + DIMENSION DROP(10),JMP0(10),NODL(10),NTAG(10,2) + LOGICAL DROP + + DATA MAXLIM /10/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE MNEMONIC +C ------------------ + +C Note that Table A mnemonics, in addition to being stored within +C internal BUFR Table A array TABA(*,LUN), are also stored as +C Table D mnemonics within internal BUFR Table D array TABD(*,LUN). +C Thus, the following test is valid. + + CALL NEMTAB(LUN,NEMO,IDN,TAB,ITAB) + IF(TAB.NE.'D') GOTO 900 + +C STORE A SUBSET NODE AND JUMP/LINK THE TREE +C ------------------------------------------ + + CALL INCTAB(NEMO,'SUB',NODE) + JUMP(NODE) = NODE+1 + JMPB(NODE) = 0 + LINK(NODE) = 0 + IBT (NODE) = 0 + IRF (NODE) = 0 + ISC (NODE) = 0 + + CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) + NTAG(1,1) = 1 + NTAG(1,2) = NSEQ + JMP0(1) = NODE + NODL(1) = NODE + LIMB = 1 + + ICDW = 0 + ICSC = 0 + ICRV = 1 + INCW = 0 + + IBTNRV = 0 + IPFNRV = 0 + +C THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION +C -------------------------------------------------------------- + +1 DO N=NTAG(LIMB,1),NTAG(LIMB,2) + + NTAG(LIMB,1) = N+1 + DROP(LIMB) = N.EQ.NTAG(LIMB,2) + + CALL NEMTAB(LUN,NEM(N,LIMB),IDN,TAB,ITAB) + NEMS = NEM(N,LIMB) + +C SPECIAL TREATMENT FOR CERTAIN OPERATOR DESCRIPTORS (TAB=C) +C ---------------------------------------------------------- + + IF(TAB.EQ.'C') THEN + READ(NEMS,'(3X,I3)') IYYY + IF(ITAB.EQ.1) THEN + IF(IYYY.NE.0) THEN + IF(ICDW.NE.0) GOTO 907 + ICDW = IYYY-128 + ELSE + ICDW = 0 + ENDIF + ELSEIF(ITAB.EQ.2) THEN + IF(IYYY.NE.0) THEN + IF(ICSC.NE.0) GOTO 908 + ICSC = IYYY-128 + ELSE + ICSC = 0 + ENDIF + ELSEIF(ITAB.EQ.3) THEN + IF(IYYY.EQ.0) THEN + +C Stop applying new reference values to subset nodes. +C Instead, revert to the use of standard Table B values. + + IF(IPFNRV.EQ.0) GOTO 911 + DO JJ=IPFNRV,NNRV + IENRV(JJ) = NTAB + ENDDO + IPFNRV = 0 + ELSEIF(IYYY.EQ.255) THEN + +C End the definition of new reference values. + + IBTNRV = 0 + ELSE + +C Begin the definition of new reference values. + + IF(IBTNRV.NE.0) GOTO 909 + IBTNRV = IYYY + ENDIF + ELSEIF(ITAB.EQ.7) THEN + IF(IYYY.GT.0) THEN + IF(ICDW.NE.0) GOTO 907 + IF(ICSC.NE.0) GOTO 908 + ICDW = ((10*IYYY)+2)/3 + ICSC = IYYY + ICRV = 10**IYYY + ELSE + ICSC = 0 + ICDW = 0 + ICRV = 1 + ENDIF + ELSEIF(ITAB.EQ.8) THEN + INCW = IYYY + ENDIF + ELSE + NODL(LIMB) = NTAB+1 + IREP = IRP(N,LIMB) + IKNT = KRP(N,LIMB) + JUM0 = JMP0(LIMB) + CALL TABENT(LUN,NEMS,TAB,ITAB,IREP,IKNT,JUM0) + ENDIF + + IF(TAB.EQ.'D') THEN + +C Note here how a new tree "LIMB" is created (and is then +C immediately recursively resolved) whenever a Table D mnemonic +C contains another Table D mnemonic as one of its children. + + LIMB = LIMB+1 + IF(LIMB.GT.MAXLIM) GOTO 901 + CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,LIMB),IRP(1,LIMB),KRP(1,LIMB)) + NTAG(LIMB,1) = 1 + NTAG(LIMB,2) = NSEQ + JMP0(LIMB) = NTAB + GOTO 1 + ELSEIF(DROP(LIMB)) THEN +2 LINK(NODL(LIMB)) = 0 + LIMB = LIMB-1 + IF(LIMB.EQ.0 ) THEN + IF(ICRV.NE.1) GOTO 904 + IF(ICDW.NE.0) GOTO 902 + IF(ICSC.NE.0) GOTO 903 + IF(INCW.NE.0) GOTO 905 + IF(IBTNRV.NE.0) GOTO 910 + IF(IPFNRV.NE.0) THEN + +C One or more new reference values were defined for this +C subset, but there was no subsequent 2-03-000 operator, +C so set all IENRV(*) values for this subset to point to +C the last element of the subset within the jump/link table. +C Note that, if there had been a subsequent 2-03-000 +C operator, then these IENRV(*) values would have already +C been properly set above. + + DO JJ=IPFNRV,NNRV + IENRV(JJ) = NTAB + ENDDO + ENDIF + GOTO 100 + ENDIF + IF(DROP(LIMB)) GOTO 2 + LINK(NODL(LIMB)) = NTAB+1 + GOTO 1 + ELSEIF(TAB.NE.'C') THEN + LINK(NODL(LIMB)) = NTAB+1 + ENDIF + + ENDDO + + GOTO 906 + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D '// + . '(TAB=",A,") FOR INPUT MNEMONIC ",A)') TAB,NEMO + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '// + . 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE '// + . 'LIMIT IS",I4)') NEMO,MAXLIM + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '// + . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '// + . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '// + . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '// + . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +906 WRITE(BORT_STR,'("BUFRLIB: TABSUB - ENTITIES WERE NOT '// + . 'SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '// + . 'DEFINED BY TBL A MNEM. ",A)') NEMO + CALL BORT(BORT_STR) +907 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// + . 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT ' // + . 'MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +908 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// + . 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT ' // + . 'MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +909 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// + . 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT ' // + . 'MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +910 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '// + . 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR '// + . 'INPUT MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) +911 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '// + . 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR '// + . 'INPUT MNEMONIC ",A)') NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/trybump.f b/src/bufr/trybump.f new file mode 100644 index 0000000000..9c46988ba4 --- /dev/null +++ b/src/bufr/trybump.f @@ -0,0 +1,120 @@ + SUBROUTINE TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: TRYBUMP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CHECKS THE FIRST NODE ASSOCIATED WITH A +C CHARACTER STRING (PARSED INTO ARRAYS IN COMMON BLOCK /USRSTR/) IN +C ORDER TO DETERMINE IF IT REPRESENTS A DELAYED REPLICATION SEQUENCE. +C IF SO, THEN THE DELAYED REPLICATION SEQUENCE IS INITIALIZED AND +C EXPANDED (I.E. "BUMPED") TO THE VALUE OF INPUT ARGUMENT I2. +C A CALL IS THEN MADE TO SUBROUTINE UFBRW IN ORDER TO WRITE USER DATA +C INTO THE NEWLY EXPANDED REPLICATION SEQUENCE. +C +C TRYBUMP IS USUALLY CALLED FROM UFBINT AFTER UFBINT RECEIVES A +C NON-ZERO RETURN CODE FROM UFBRW. THE CAUSE OF A BAD RETURN FROM +C UFBRW IS USUALLY A DELAYED REPLICATION SEQUENCE WHICH ISN'T +C EXPANDED ENOUGH TO HOLD THE ARRAY OF DATA THE USER IS TRYING TO +C WRITE. SO TRYBUMP IS ONE LAST CHANCE TO RESOLVE THAT SITUATION. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE); OUTPUTS MORE +C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION +C +C USAGE: CALL TRYBUMP (LUNIT, LUN, USR, I1, I2, IO, IRET) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C (SEE REMARKS) +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) +C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES TO BE +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR +C I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE +C WRITTEN TO DATA SUBSET +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUNIT (SEE REMARKS): +C 0 = INPUT FILE (POSSIBLE FUTURE USE) +C 1 = OUTPUT FILE +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: RETURN CODE FROM CALL TO SUBROUTINE UFBRW +C +C REMARKS: +C ARGUMENT LUNIT IS NOT REFERENCED IN THIS SUBROUTINE. IT WAS +C INCLUDED ONLY FOR POTENTIAL FUTURE EXPANSION OF THE SUBROUTINE. +C +C ARGUMENT IO IS ALWAYS PASSED IN WITH A VALUE OF 1 AT THE PRESENT +C TIME. IN THE FUTURE THE SUBROUTINE MAY BE EXPANDED TO ALLOW IT +C TO OPERATE ON INPUT FILES. +C +C THIS ROUTINE CALLS: BORT INVWIN LSTJPB UFBRW +C USRTPL +C THIS ROUTINE IS CALLED BY: UFBINT UFBOVR +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + + REAL*8 USR(I1,I2),VAL + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C SEE IF THERE IS A DELAYED REPLICATION GROUP INVOLVED +C ---------------------------------------------------- + + NDRP = LSTJPB(NODS(1),LUN,'DRP') + IF(NDRP.LE.0) GOTO 100 + +C IF SO, CLEAN IT OUT AND BUMP IT TO I2 +C ------------------------------------- + + INVN = INVWIN(NDRP,LUN,1,NVAL(LUN)) + VAL(INVN,LUN) = 0 + JNVN = INVN+1 + DO WHILE(NINT(VAL(JNVN,LUN)).GT.0) + JNVN = JNVN+NINT(VAL(JNVN,LUN)) + ENDDO + DO KNVN=1,NVAL(LUN)-JNVN+1 + INV(INVN+KNVN,LUN) = INV(JNVN+KNVN-1,LUN) + VAL(INVN+KNVN,LUN) = VAL(JNVN+KNVN-1,LUN) + ENDDO + NVAL(LUN) = NVAL(LUN)-(JNVN-INVN-1) + CALL USRTPL(LUN,INVN,I2) + +C FINALLY, CALL THE MNEMONIC WRITER +C ---------------------------------------- + + CALL UFBRW(LUN,USR,I1,I2,IO,IRET) + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/ufbcnt.f b/src/bufr/ufbcnt.f new file mode 100644 index 0000000000..a0656c1715 --- /dev/null +++ b/src/bufr/ufbcnt.f @@ -0,0 +1,86 @@ + SUBROUTINE UFBCNT(LUNIT,KMSG,KSUB) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBCNT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE RETURNS A COUNT OF THE CURRENT MESSAGE +C NUMBER AND SUBSET NUMBER, WHERE THE MESSAGE NUMBER IS RELATIVE TO +C ALL MESSAGES IN THE BUFR FILE AND THE SUBSET NUMBER IS RELATIVE TO +C ALL SUBSETS IN THE MESSAGE. IF THE MESSAGE/SUBSET ARE BEING READ, +C THE MESSAGE COUNT ADVANCES EACH TIME BUFR ARCHIVE LIBRARY +C SUBROUTINE READMG (OR EQUIVALENT) IS CALLED AND THE SUBSET COUNT +C ADVANCES EACH TIME BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR +C EQUIVALENT) IS CALLED FOR A PARTICULAR MESSAGE. IF THE MESSAGE/ +C SUBSET ARE BEING WRITTEN, THE MESSAGE COUNT ADVANCES EACH TIME +C BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG (OR EQUIVALENT) IS CALLED +C AND THE SUBSET COUNT ADVANCES EACH TIME BUFR ARCHIVE LIBRARY +C SUBROUTINE WRITSB (OR EQUIVALENT) IS CALLED. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: CALL UFBCNT (LUNIT, KMSG, KSUB) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C OUTPUT ARGUMENT LIST: +C KMSG - INTEGER: POINTER TO MESSAGE COUNT IN BUFR FILE +C (INCLUDING MESSAGE CURRENTLY OPEN FOR READING/WRITING) +C KSUB - INTEGER: POINTER TO SUBSET COUNT IN BUFR MESSAGE +C (INCLUDING SUBSET CURRENTLY OPEN FOR READING/WRITING) +C +C REMARKS: +C IF AN APPLICATION PROGRAM DESIRES TO KNOW THE NUMBER OF SUBSETS IN +C A BUFR MESSAGES JUST OPENED, IT MUST USE THE FUNCTION NMSUB RATHER +C THAN THIS SUBROUTINE BECAUSE KSUB ONLY INCREMENTS BY ONE FOR EACH +C CALL TO READSB (I.E., KSUB = 0 IMMEDIATELY AFTER READMG IS +C CALLED). +C +C THIS ROUTINE CALLS: BORT STATUS +C THIS ROUTINE IS CALLED BY: UFBPOS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS - RETURN THE MESSAGE AND SUBSET COUNTERS +C -------------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + KMSG = NMSG(LUN) + KSUB = NSUB(LUN) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: STATUS - BUFR FILE IS CLOSED, IT MUST BE '// + . 'OPEN FOR EITHER INPUT OR OUTPUT') + END diff --git a/src/bufr/ufbcpy.f b/src/bufr/ufbcpy.f new file mode 100644 index 0000000000..827f431807 --- /dev/null +++ b/src/bufr/ufbcpy.f @@ -0,0 +1,129 @@ + SUBROUTINE UFBCPY(LUBIN,LUBOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBCPY +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE COPIES A COMPLETE SUBSET BUFFER, UNPACKED +C INTO INTERNAL MEMORY FROM LOGICAL UNIT LUBIN BY A PREVIOUS CALL +C TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR READNS, TO +C LOGICAL UNIT LUBOT. BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR +C OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A +C BUFR MESSAGE WITHIN MEMORY FOR LOGICAL UNIT LUBOU. BOTH FILES MUST +C HAVE BEEN OPENED TO THE INTERFACE (VIA A CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF) WITH IDENTICAL BUFR TABLES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2009-06-26 J. ATOR -- USE IOK2CPY +C 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO REMEMBER WHICH UNIT +C IS COPIED TO WHAT SUBSET BUFFER IN ORDER TO +C TRANSFER LONG STRINGS VIA UFBCPY AND WRTREE +C +C USAGE: CALL UFBCPY (LUBIN, LUBOT) +C INPUT ARGUMENT LIST: +C LUBIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT IOK2CPY STATUS +C THIS ROUTINE IS CALLED BY: COPYSB +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /UFBCPL/ LUNCPY(NFILES) + + CHARACTER*10 TAG + CHARACTER*3 TYP + + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C CHECK THE FILE STATUSES AND I-NODE +C ---------------------------------- + + CALL STATUS(LUBIN,LUI,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903 + + CALL STATUS(LUBOT,LUO,IL,IM) + IF(IL.EQ.0) GOTO 904 + IF(IL.LT.0) GOTO 905 + IF(IM.EQ.0) GOTO 906 + + IF(INODE(LUI).NE.INODE(LUO)) THEN + IF( (TAG(INODE(LUI)).NE.TAG(INODE(LUO))) .OR. + . (IOK2CPY(LUI,LUO).NE.1) ) GOTO 907 + ENDIF + +C EVERYTHING OKAY COPY USER ARRAY FROM LUI TO LUO +C ----------------------------------------------- + + NVAL(LUO) = NVAL(LUI) + + DO N=1,NVAL(LUI) + INV(N,LUO) = INV(N,LUI) + VAL(N,LUO) = VAL(N,LUI) + ENDDO + + LUNCPY(LUO)=LUBIN + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR '// + . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') +904 CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +905 CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +906 CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') +907 CALL BORT('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST '// + . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') + END diff --git a/src/bufr/ufbcup.f b/src/bufr/ufbcup.f new file mode 100644 index 0000000000..bd378b21d6 --- /dev/null +++ b/src/bufr/ufbcup.f @@ -0,0 +1,137 @@ + SUBROUTINE UFBCUP(LUBIN,LUBOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBCUP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE MAKES ONE COPY OF EACH UNIQUE ELEMENT IN AN +C INPUT SUBSET BUFFER INTO THE IDENTICAL MNEMONIC SLOT IN THE OUTPUT +C SUBSET BUFFER. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C +C USAGE: CALL UFBCUP (LUBIN, LUBOT) +C INPUT ARGUMENT LIST: +C LUBIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR +C FILE +C LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR +C FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*10 TAG,TAGI(MAXJL),TAGO + CHARACTER*3 TYP + DIMENSION NINI(MAXJL) + REAL*8 VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C CHECK THE FILE STATUSES AND I-NODE +C ---------------------------------- + + CALL STATUS(LUBIN,LUI,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903 + + CALL STATUS(LUBOT,LUO,IL,IM) + IF(IL.EQ.0) GOTO 904 + IF(IL.LT.0) GOTO 905 + IF(IM.EQ.0) GOTO 906 + +C MAKE A LIST OF UNIQUE TAGS IN INPUT BUFFER +C ------------------------------------------ + + NTAG = 0 + + DO 5 NI=1,NVAL(LUI) + NIN = INV(NI,LUI) + IF(ITP(NIN).GE.2) THEN + DO NV=1,NTAG + IF(TAGI(NV).EQ.TAG(NIN)) GOTO 5 + ENDDO + NTAG = NTAG+1 + NINI(NTAG) = NI + TAGI(NTAG) = TAG(NIN) + ENDIF +5 ENDDO + + IF(NTAG.EQ.0) GOTO 907 + +C GIVEN A LIST MAKE ONE COPY OF COMMON ELEMENTS TO OUTPUT BUFFER +C -------------------------------------------------------------- + + DO 10 NV=1,NTAG + NI = NINI(NV) + DO NO=1,NVAL(LUO) + TAGO = TAG(INV(NO,LUO)) + IF(TAGI(NV).EQ.TAGO) THEN + VAL(NO,LUO) = VAL(NI,LUI) + GOTO 10 + ENDIF + ENDDO +10 ENDDO + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// + . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') +904 CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +905 CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +906 CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') +907 CALL BORT('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN '// + . 'INPUT SUBSET BUFFER') + END diff --git a/src/bufr/ufbdmp.f b/src/bufr/ufbdmp.f new file mode 100644 index 0000000000..c48d12684b --- /dev/null +++ b/src/bufr/ufbdmp.f @@ -0,0 +1,290 @@ + SUBROUTINE UFBDMP(LUNIN,LUPRT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBDMP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE +C CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE +C INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT +C ABS(LUNIN). ABS(LUNIN) MUST HAVE BEEN OPENED FOR INPUT VIA A +C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. THE DATA +C SUBSET MUST HAVE BEEN SUBSEQUENTLY READ INTO THE INTERNAL BUFR +C ARCHIVE LIBRARY ARRAYS VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE +C READMG OR READERME, FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE READNS!). FOR A PARTICULAR SUBSET, THE PRINT LISTING +C CONTAINS EACH MNEMONIC ACCOMPANIED BY ITS CORRESPONDING DATA VALUE +C (INCLUDING THE ACTUAL BITS THAT WERE SET FOR FLAG TABLE VALUES!) +C ALONG WITH OTHER POTENTIALLY USEFUL INFORMATION SUCH AS WHICH OTHER +C MNEMONIC(S) THAT MNEMONIC WAS A CONSTITUENT OF WITHIN THE OVERALL +C DATA SUBSET. HOWEVER, THE LISTING ALSO CONTAINS OTHER MORE ESOTERIC +C INFORMATION SUCH AS BUFR STORAGE CHARACTERISTICS AND A COPY OF THE +C JUMP/LINK TABLE USED INTERNALLY WITHIN THE BUFR ARCHIVE LIBRARY +C SOFTWARE. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE UFDUMP, EXCEPT THAT UFDUMP DOES NOT PRINT POINTERS, +C COUNTERS AND THE OTHER MORE ESOTERIC INFORMATION DESCRIBING THE +C INTERNAL SUBSET STRUCTURES. EACH SUBROUTINE, UFBDMP AND UFDUMP, +C IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP +C IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR +C FOR INFORMATIONAL PURPOSES; TEST FOR A +C MISSING VALUE NOW ALLOWS SOME FUZZINESS +C ABOUT 10E10 (RATHER THAN TRUE EQUALITY AS +C BEFORE) BECAUSE SOME MISSING VALUES (E.G., +C CHARACTER STRINGS < 8 CHARACTERS) WERE NOT +C GETTING STAMPED OUT AS "MISSING"; ADDED +C OPTION TO PRINT VALUES USING FORMAT EDIT +C DESCRIPTOR "F15.6" IF LUNIN IS < ZERO, +C IF LUNIN IS > ZERO EDIT DESCRIPTOR EXPANDED +C FROM "G10.3" TO "G15.6" {REGARDLESS OF +C LUNIN, ADDITIONAL VALUES +C "IB,IS,IR,ND,JP,LK,JB" NOW PRINTED (THEY +C WERE COMMENTED OUT)} +C 2004-08-18 J. ATOR -- MODIFIED FUZZINESS TEST;ADDED READLC OPTION; +C RESTRUCTURED SOME LOGIC FOR CLARITY +C 2006-04-14 D. KEYSER -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET +C ACTUAL BITS THAT WERE SET TO GENERATE VALUE +C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS +C +C USAGE: CALL UFBDMP (LUNIN, LUPRT) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE +C - IF LUNIN IS GREATER THAN ZERO, DATA VALUES ARE +C PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR +C "G15.6" (all values are printed since output +C format adapts to the magnitude of the data, but +C they are not lined up in columns according to +C decimal point) +C - IF LUNIN IS LESS THAN ZERO, DATA VALUES ARE +C PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR +C "F15.6" {values are lined up in columns according +C to decimal point, but data of large magnitude, +C (i.e., exceeding the format width of 15) get the +C overflow ("***************") print} +C LUPRT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT +C FILE +C 0 = LUPRT is set to 06 (standard output) and +C the subroutine will scroll the output, +C twenty elements at a time (see REMARKS) +C +C INPUT FILES: +C UNIT 05 - STANDARD INPUT (SEE REMARKS) +C +C OUTPUT FILES: +C IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT) +C IF LUPRT = 0: UNIT 06 - STANDARD OUTPUT PRINT (SEE REMARKS) +C +C +C REMARKS: +C THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS +C AT A TIME WHEN LUPRT IS INPUT AS "0". IN THIS CASE, THE EXECUTING +C SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND +C STANDARD OUTPUT. INITIALLY, THE FIRST TWENTY ELEMENTS OF THE +C CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL, +C FOLLOWED BY THE PROMPT "( for MORE, q to QUIT)". +C IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY +C "" (e.g., ""), THE NEXT TWENTY ELEMENTS WILL BE +C DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT. THIS CONTINUES +C UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL +C ENTERS "q" FOLLOWED BY "" AFTER THE PROMPT, IN WHICH CASE +C THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING +C PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE). +C +C THIS ROUTINE CALLS: BORT IBFMS ISIZE READLC +C RJUST STATUS UPFTBV +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + + CHARACTER*20 LCHR + CHARACTER*14 BITS + CHARACTER*10 TAG,TG,TG_RJ + CHARACTER*8 VC + CHARACTER*7 FMTF + CHARACTER*3 TYP,TP + CHARACTER*1 TAB,YOU + EQUIVALENCE (VL,VC) + REAL*8 VAL,VL + + PARAMETER (MXFV=31) + INTEGER IFV(MXFV) + + DATA YOU /'Y'/ + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IF(LUPRT.EQ.0) THEN + LUOUT = 6 + ELSE + LUOUT = LUPRT + ENDIF + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + LUNIT = ABS(LUNIN) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 + +C DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT ABS(LUNIN) +C -------------------------------------------------------- + + DO NV=1,NVAL(LUN) + IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN + +C When LUPRT=0, the output will be scrolled, 20 elements at a time +C ---------------------------------------------------------------- + + PRINT*,'( for MORE, q to QUIT)' + READ(5,'(A1)') YOU + +C If the terminal enters "q" followed by "" after the prompt +C "( for MORE, q to QUIT)", scrolling will end and the +C subroutine will return to the calling program +C ------------------------------------------------------------------- + + IF(YOU.EQ.'q') THEN + PRINT* + PRINT*,'==> You have chosen to stop the dumping of this subset' + PRINT* + GOTO 100 + ENDIF + ENDIF + ND = INV (NV,LUN) + VL = VAL (NV,LUN) + TG = TAG (ND) + TP = TYP (ND) + IT = ITP (ND) + IB = IBT (ND) + IS = ISC (ND) + IR = IRF (ND) + JP = JUMP(ND) + LK = LINK(ND) + JB = JMPB(ND) + TG_RJ = TG + RJ = RJUST(TG_RJ) + IF(TP.NE.'CHR') THEN + BITS = ' ' + IF(IT.EQ.2) THEN + CALL NEMTAB(LUN,TG,IDN,TAB,N) + IF(TABB(N,LUN)(71:75).EQ.'FLAG') THEN + +C Print a listing of the bits corresponding to +C this value. + + CALL UPFTBV(LUNIT,TG,VL,MXFV,IFV,NIFV) + IF(NIFV.GT.0) THEN + BITS(1:1) = '(' + IPT = 2 + DO II=1,NIFV + ISZ = ISIZE(IFV(II)) + WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)' + IF((IPT+ISZ).LE.14) THEN + WRITE(BITS(IPT:IPT+ISZ),FMTF) IFV(II), ',' + IPT = IPT + ISZ + 1 + ELSE + BITS(2:13) = 'MANY BITS ON' + IPT = 15 + ENDIF + ENDDO + BITS(IPT-1:IPT-1) = ')' + ENDIF + ENDIF + ENDIF + IF(IBFMS(VL).NE.0) THEN + LCHR = 'MISSING' + RJ = RJUST(LCHR) + WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB + ELSE + IF(LUNIT.EQ.LUNIN) THEN + WRITE(LUOUT,1) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK, + . JB + ELSE + WRITE(LUOUT,10) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK, + . JB + ENDIF + ENDIF + ELSE + IF(IB.GT.64) THEN + CALL READLC(LUNIT,LCHR,TG_RJ) + ELSE + LCHR = VC + ENDIF + IF(IBFMS(VL).NE.0) LCHR = 'MISSING' + RJ = RJUST(LCHR) + WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB + ENDIF + ENDDO + + WRITE(LUOUT,3) + +1 FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,G15.6,1X,A14,7(1X,I5)) +10 FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,F15.6,1X,A14,7(1X,I5)) +2 FORMAT(I5,1X,A3,'-',I1,1X,A10, A20, 15X, 7(1X,I5)) +3 FORMAT(/' >>> END OF SUBSET <<< '/) + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '// + . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') + END diff --git a/src/bufr/ufbevn.f b/src/bufr/ufbevn.f new file mode 100644 index 0000000000..5111e98e3b --- /dev/null +++ b/src/bufr/ufbevn.f @@ -0,0 +1,290 @@ + SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBEVN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT +C BUFR DATA SUBSET WITHIN INTERNAL ARRAYS. THE DATA VALUES +C CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION +C SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE. THE INNER +C SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER +C SEQUENCE WITH DATA "EVENTS". THE BUFR FILE IN LOGICAL UNIT LUNIT +C MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF. IN ADDITION, THE DATA SUBSET MUST HAVE +C SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY +C ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR +C READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE +C READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE READNS). OTHER THAN THE ADDITION OF A THIRD +C DIMENSION AND THE READ ONLY RESTRICTION, THE CONTEXT AND USAGE OF +C UFBEVN IS EXACTLY THE SAME AS FOR BUFR ARCHIVE LIBRARY SUBROUTINES +C UFBINT, UFBREP AND UFBSEQ. THIS SUBROUTINE IS DESIGNED TO READ +C EVENT INFORMATION FROM "PREPBUFR" TYPE BUFR FILES. PREPBUFR FILES +C HAVE THE FOLLOWING BUFR TABLE EVENT STRUCTURE (NOTE SIXTEEN +C CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN TO ALLOW THE +C TABLE TO FIT IN THIS DOCBLOCK): +C +C | ADPUPA | HEADR {PLEVL} | +C | HEADR | SID XOB YOB DHR ELV TYP T29 TSB ITP SQN | +C | PLEVL | CAT | +C | PINFO | [PEVN] | +C | QINFO | [QEVN] TDO | +C | TINFO | [TEVN] TVO | +C | ZINFO | [ZEVN] | +C | WINFO | [WEVN] | +C | PEVN | POB PQM PPC PRC | +C | QEVN | QOB QQM QPC QRC | +C | TEVN | TOB TQM TPC TRC | +C | ZEVN | ZOB ZQM ZPC ZRC | +C | WEVN | UOB WQM WPC WRC VOB | +C | PBACKG | POE PFC | +C | QBACKG | QOE QFC | +C | TBACKG | TOE TFC | +C | ZBACKG | ZOE ZFC | +C | WBACKG | WOE UFC VFC | +C | PPOSTP | PAN | +C | QPOSTP | QAN | +C | TPOSTP | TAN | +C | ZPOSTP | ZAN | +C | WPOSTP | UAN VAN | +C +C NOTE THAT THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES "[xxxx]" +C ARE NESTED INSIDE ONE-BIT DELAYED REPLICATED SEQUENCES "". +C THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBIN3 DOES NOT WORK +C PROPERLY ON THIS TYPE OF EVENT STRUCTURE. IT WORKS ONLY ON THE +C EVENT STRUCTURE FOUND IN "PREPFITS" TYPE BUFR FILES (SEE UFBIN3 FOR +C MORE DETAILS). IN TURN, UFBEVN DOES NOT WORK PROPERLY ON THE EVENT +C STRUCTURE FOUND IN PREPFITS FILES (ALWAYS USE UFBIN3 IN THIS CASE). +C ONE OTHER DIFFERENCE BETWEEN UFBEVN AND UFBIN3 IS THAT UFBEVN +C STORES THE MAXIMUM NUMBER OF EVENTS FOUND FOR ALL DATA VALUES +C SPECIFIED AMONGST ALL LEVELS RETURNED INTERNALLY IN COMMON BLOCK +C /UFBN3C/. UFBIN3 RETURNS THIS VALUE AS AN ADDITIONAL OUTPUT +C ARGUMENT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; IMPROVED MACHINE +C PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. WOOLLEN -- SAVES THE MAXIMUM NUMBER OF EVENTS FOUND +C FOR ALL DATA VALUES SPECIFIED AMONGST ALL +C LEVELS RETURNED AS VARIABLE MAXEVN IN NEW +C COMMON BLOCK /UFBN3C/ +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); ADDED CALL TO BORT +C IF BUFR FILE IS OPEN FOR OUTPUT; UNIFIED/ +C PORTABLE FOR WRF; ADDED DOCUMENTATION +C (INCLUDING HISTORY); OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY OR UNUSUAL THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBEVN (LUNIT, USR, I1, I2, I3, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE .GE. LATTER) +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM +C VALUE IS 255) +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED +C TO TABLE B, THESE RETURN THE FOLLOWING +C INFORMATION IN CORRESPONDING USR LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C USR - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM +C DATA SUBSET (MUST BE NO LARGER THAN I2) +C +C REMARKS: +C APPLICATION PROGRAMS READING PREPFITS FILES SHOULD NOT CALL THIS +C ROUTINE. +C +C THIS ROUTINE CALLS: BORT CONWIN ERRWRT GETWIN +C NVNWIN NXTWIN STATUS STRING +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /UFBN3C/ MAXEVN + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 ERRSTR + DIMENSION INVN(255) + REAL*8 VAL,USR(I1,I2,I3) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + MAXEVN = 0 + IRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I3.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ENDIF + +C PARSE OR RECALL THE INPUT STRING +C -------------------------------- + + CALL STRING(STR,LUN,I1,0) + +C INITIALIZE USR ARRAY +C -------------------- + + DO K=1,I3 + DO J=1,I2 + DO I=1,I1 + USR(I,J,K) = BMISS + ENDDO + ENDDO + ENDDO + +C LOOP OVER COND WINDOWS +C ---------------------- + + INC1 = 1 + INC2 = 1 + +1 CALL CONWIN(LUN,INC1,INC2) + IF(NNOD.EQ.0) THEN + IRET = I2 + GOTO 100 + ELSEIF(INC1.EQ.0) THEN + GOTO 100 + ELSE + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INS2 = INC1 + CALL GETWIN(NODS(I),LUN,INS1,INS2) + IF(INS1.EQ.0) GOTO 100 + GOTO 2 + ENDIF + ENDDO + INS1 = INC1 + INS2 = INC2 + ENDIF + +C READ PUSH DOWN STACK DATA INTO 3D ARRAYS +C ---------------------------------------- + +2 IRET = IRET+1 + IF(IRET.LE.I2) THEN + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + NNVN = NVNWIN(NODS(I),LUN,INS1,INS2,INVN,I3) + MAXEVN = MAX(NNVN,MAXEVN) + DO N=1,NNVN + USR(I,IRET,N) = VAL(INVN(N),LUN) + ENDDO + ENDIF + ENDDO + ENDIF + +C DECIDE WHAT TO DO NEXT +C ---------------------- + + CALL NXTWIN(LUN,INS1,INS2) + IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 + IF(NCON.GT.0) GOTO 1 + + IF(IRET.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, ' // + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// + . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') + END diff --git a/src/bufr/ufbget.f b/src/bufr/ufbget.f new file mode 100644 index 0000000000..44fa7af383 --- /dev/null +++ b/src/bufr/ufbget.f @@ -0,0 +1,187 @@ + SUBROUTINE UFBGET(LUNIT,TAB,I1,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBGET +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE VALUES FOR ONE- +C DIMENSIONAL DESCRIPTORS IN THE INPUT STRING WITHOUT ADVANCING THE +C SUBSET POINTER. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; IMPROVED MACHINE +C PORTABILITY +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2012-03-02 J. ATOR -- USE FUNCTION UPS +C +C USAGE: CALL UFBGET (LUNIT, TAB, I1, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C I1 - INTEGER: LENGTH OF TAB +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH THE WORDS +C IN THE ARRAY TAB +C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED +C TO TABLE B, THESE RETURN THE FOLLOWING +C INFORMATION IN CORRESPONDING TAB LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C TAB - REAL*8: (I1) STARTING ADDRESS OF DATA VALUES READ FROM +C DATA SUBSET +C IRET - INTEGER: RETURN CODE: +C 0 = normal return +C -1 = there are no more subsets in the BUFR +C message +C +C REMARKS: +C THIS ROUTINE CALLS: BORT INVWIN STATUS STRING +C UPBB UPC UPS USRTPL +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) + + CHARACTER*(*) STR + CHARACTER*10 TAG + CHARACTER*8 CVAL + CHARACTER*3 TYP + EQUIVALENCE (CVAL,RVAL) + REAL*8 VAL,RVAL,TAB(I1),UPS + +C----------------------------------------------------------------------- + MPS(NODE) = 2**(IBT(NODE))-1 +C----------------------------------------------------------------------- + + IRET = 0 + + DO I=1,I1 + TAB(I) = BMISS + ENDDO + +C MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT +C ------------------------------------------ + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE +C --------------------------------------------- + + IF(NSUB(LUN).EQ.MSUB(LUN)) THEN + IRET = -1 + GOTO 100 + ENDIF + +C PARSE THE STRING +C ---------------- + + CALL STRING(STR,LUN,I1,0) + +C EXPAND THE TEMPLATE FOR THIS SUBSET AS LITTLE AS POSSIBLE +C --------------------------------------------------------- + + N = 1 + NBIT(N) = 0 + MBIT(N) = MBYT(LUN)*8 + 16 + CALL USRTPL(LUN,N,N) + +10 DO N=N+1,NVAL(LUN) + NODE = INV(N,LUN) + NBIT(N) = IBT(NODE) + MBIT(N) = MBIT(N-1)+NBIT(N-1) + IF(NODE.EQ.NODS(NNOD)) THEN + NVAL(LUN) = N + GOTO 20 + ELSEIF(ITP(NODE).EQ.1) THEN + CALL UPBB(IVAL,NBIT(N),MBIT(N),MBAY(1,LUN)) + CALL USRTPL(LUN,N,IVAL) + GOTO 10 + ENDIF + ENDDO +20 CONTINUE + +C UNPACK ONLY THE NODES FOUND IN THE STRING +C ----------------------------------------- + + DO I=1,NNOD + NODE = NODS(I) + INVN = INVWIN(NODE,LUN,1,NVAL(LUN)) + IF(INVN.GT.0) THEN + CALL UPBB(IVAL,NBIT(INVN),MBIT(INVN),MBAY(1,LUN)) + IF(ITP(NODE).EQ.1) THEN + TAB(I) = IVAL + ELSEIF(ITP(NODE).EQ.2) THEN + IF(IVAL.LT.MPS(NODE)) TAB(I) = UPS(IVAL,NODE) + ELSEIF(ITP(NODE).EQ.3) THEN + CVAL = ' ' + KBIT = MBIT(INVN) + CALL UPC(CVAL,NBIT(INVN)/8,MBAY(1,LUN),KBIT) + TAB(I) = RVAL + ENDIF + ELSE + TAB(I) = BMISS + ENDIF + ENDDO + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') + END diff --git a/src/bufr/ufbin3.f b/src/bufr/ufbin3.f new file mode 100644 index 0000000000..d37f8d70fe --- /dev/null +++ b/src/bufr/ufbin3.f @@ -0,0 +1,263 @@ + SUBROUTINE UFBIN3(LUNIT,USR,I1,I2,I3,IRET,JRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBIN3 +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT +C BUFR DATA SUBSET WITHIN INTERNAL ARRAYS. THE DATA VALUES +C CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION +C SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE. THE INNER +C SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER +C SEQUENCE WITH DATA "EVENTS". THE BUFR FILE IN LOGICAL UNIT LUNIT +C MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF. IN ADDITION, THE DATA SUBSET MUST HAVE +C SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY +C ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR +C READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE +C READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY +C SUBROUTINE READNS). THIS SUBROUTINE IS DESIGNED TO READ EVENT +C INFORMATION FROM "PREPFITS" TYPE BUFR FILES (BUT NOT FROM +C "PREPBUFR" TYPE FILES!!). PREPFITS FILES HAVE THE FOLLOWING BUFR +C TABLE EVENT STRUCTURE (NOTE SIXTEEN CHARACTERS HAVE BEEN REMOVED +C FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK): +C +C | ADPUPA | HEADR {PLEVL} | +C | HEADR | SID XOB YOB DHR ELV TYP T29 ITP | +C | PLEVL | CAT PRC PQM QQM TQM ZQM WQM CDTP_QM [OBLVL] | +C | OBLVL | SRC FHR | +C | OBLVL | | +C | PEVN | POB PMO | +C | QEVN | QOB | +C | TEVN | TOB | +C | ZEVN | ZOB | +C | WEVN | UOB VOB | +C | CEVN | CAPE CINH LI | +C | CTPEVN | CDTP GCDTT TOCC | +C +C NOTE THAT THE ONE-BIT DELAYED REPLICATED SEQUENCES "" ARE +C NESTED INSIDE THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES +C "[yyyy]". THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBEVN +C DOES NOT WORK PROPERLY ON THIS TYPE OF EVENT STRUCTURE. IT WORKS +C ONLY ON THE EVENT STRUCTURE FOUND IN "PREPBUFR" TYPE BUFR FILES +C (SEE UFBEVN FOR MORE DETAILS). IN TURN, UFBIN3 DOES NOT WORK +C PROPERLY ON THE EVENT STRUCTURE FOUND IN PREPBUFR FILES (ALWAYS USE +C UFBEVN IN THIS CASE). ONE OTHER DIFFERENCE BETWEEN UFBIN3 AND +C UFBEVN IS THAT UFBIN3 RETURNS THE MAXIMUM NUMBER OF EVENTS FOUND +C FOR ALL DATA VALUES SPECIFIED AS AN OUTPUT ARGUMENT (JRET). UFBEVN +C DOES NOT DO THIS, BUT RATHER IT STORES THIS VALUE INTERNALLY IN +C COMMON BLOCK /UFBN3C/. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION +C VERSION) +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY OR UNUSUAL THINGS HAPPEN +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBIN3 (LUNIT, USR, I1, I2, I3, IRET, JRET, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE .GE. LATTER) +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM +C VALUE IS 255) +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED +C TO TABLE B, THESE RETURN THE FOLLOWING +C INFORMATION IN CORRESPONDING USR LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C USR - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM +C DATA SUBSET (MUST BE NO LARGER THAN I2) +C JRET - INTEGER: MAXIMUM NUMBER OF "EVENTS" FOUND FOR ALL DATA +C VALUES SPECIFIED AMONGST ALL LEVELS READ FROM DATA +C SUBSET (MUST BE NO LARGER THAN I3) +C +C REMARKS: +C IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY THE VERIFICATION +C APPLICATION PROGRAM "GRIDTOBS", WHERE IT WAS PREVIOUSLY +C AN IN-LINE SUBROUTINE. IN GENERAL, UFBIN3 DOES NOT +C WORK PROPERLY IN OTHER APPLICATION PROGRAMS (I.E, THOSE +C THAT ARE READING PREPBUFR FILES) AT THIS TIME. ALWAYS +C USE UFBEVN INSTEAD!! +C +C THIS ROUTINE CALLS: BORT CONWIN ERRWRT GETWIN +C NEVN NXTWIN STATUS STRING +C THIS ROUTINE IS CALLED BY: None +C SHOULD NOT BE CALLED BY ANY APPLICATION +C PROGRAMS EXCEPT GRIDTOBS!! +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 ERRSTR + REAL*8 VAL,USR(I1,I2,I3) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + JRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // + . '8th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // + . '8th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I3.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // + . '8th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ENDIF + +C PARSE OR RECALL THE INPUT STRING +C -------------------------------- + + CALL STRING(STR,LUN,I1,0) + +C INITIALIZE USR ARRAY +C -------------------- + + DO K=1,I3 + DO J=1,I2 + DO I=1,I1 + USR(I,J,K) = BMISS + ENDDO + ENDDO + ENDDO + +C LOOP OVER COND WINDOWS +C ---------------------- + + INC1 = 1 + INC2 = 1 + +1 CALL CONWIN(LUN,INC1,INC2) + IF(NNOD.EQ.0) THEN + IRET = I2 + GOTO 100 + ELSEIF(INC1.EQ.0) THEN + GOTO 100 + ELSE + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INS2 = INC1 + CALL GETWIN(NODS(I),LUN,INS1,INS2) + IF(INS1.EQ.0) GOTO 100 + GOTO 2 + ENDIF + ENDDO + INS1 = INC1 + INS2 = INC2 + ENDIF + +C READ PUSH DOWN STACK DATA INTO 3D ARRAYS +C ---------------------------------------- + +2 IRET = IRET+1 + IF(IRET.LE.I2) THEN + DO I=1,NNOD + NNVN = NEVN(NODS(I),LUN,INS1,INS2,I1,I2,I3,USR(I,IRET,1)) + JRET = MAX(JRET,NNVN) + ENDDO + ENDIF + +C DECIDE WHAT TO DO NEXT +C ---------------------- + + CALL NXTWIN(LUN,INS1,INS2) + IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 + IF(NCON.GT.0) GOTO 1 + + IF(IRET.EQ.0 .OR. JRET.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' // + . 'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; ' // + . '8th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '// + . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') + END diff --git a/src/bufr/ufbint.f b/src/bufr/ufbint.f new file mode 100644 index 0000000000..b6e5b18897 --- /dev/null +++ b/src/bufr/ufbint.f @@ -0,0 +1,454 @@ + SUBROUTINE UFBINT(LUNIN,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBINT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM +C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF +C ABS(LUNIN) (I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN +C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). +C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A +C DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION +C AT ALL. IF UFBINT IS READING VALUES, THEN EITHER BUFR ARCHIVE +C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY +C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO +C INTERNAL MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY +C CALLED TO OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS +C ABS(LUNIN). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-11-25 J. WOOLLEN -- MODIFIED TO ADD A RETURN CODE WHEN +C MNEMONICS ARE NOT FOUND WHEN READING +C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO +C WRITE NON-EXISTING MNEMONICS +C 1996-12-17 J. WOOLLEN -- MODIFIED TO ALWAYS INITIALIZE "USR" ARRAY +C TO MISSING (10E10) WHEN BUFR FILE IS BEING +C READ +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT"; IMPROVED MACHINE +C PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR +C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM +C BORT TO BORT2 IN SOME CASES +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBINT (LUNIN, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE +C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS +C THAN ZERO, UFBINT TREATS THE BUFR FILE AS THOUGH +C IT WERE OPEN FOR INPUT +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR INPUT: THIS CAN ALSO BE A +C SINGLE TABLE D (SEQUENCE) MNEMONIC WITH EITHER 8- +C OR 16-BIT DELAYED REPLICATION (SEE REMARKS 1) +C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE +C "GENERIC" MNEMONICS NOT RELATED TO TABLE B OR D, +C THESE RETURN THE FOLLOWING INFORMATION IN +C CORRESPONDING USR LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C +C REMARKS: +C 1) UFBINT CAN ALSO BE CALLED TO PROVIDE INFORMATION ABOUT A SINGLE +C TABLE D (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED +C REPLICATION IN A SUBSET WHEN THE BUFR FILE IS OPEN FOR INPUT. +C THE MNEMONIC IN STR MUST APPEAR AS IT DOES IN THE BUFR TABLE, +C I.E., BRACKETED BY "{" AND "}" OR "[" AND "]" FOR 8-BIT DELAYED +C REPLICATION, OR BRACKETED BY "(" AND ")" FOR 16-BIT DELAYED +C REPLICATION. {NOTE: THIS WILL NOT WORK FOR SEQUENCES WITH +C 1-BIT DELAYED REPLICATION (BRACKETED BY "<" AND ">"), STANDARD +C REPLICATION (BRACKETED BY "'s), OR NO REPLICATION (NO +C BRACKETING SYMBOLS).} +C +C FOR EXAMPLE: +C +C CALL UFBINT(LUNIN,PLEVL,1, 50,IRET,'{PLEVL}') +C +C WILL RETURN WITH IRET EQUAL TO THE NUMBER OF OCCURRENCES OF THE +C 8-BIT DELAYED REPLICATION SEQUENCE PLEVL IN THE SUBSET AND WITH +C (PLEVL(I),I=1,IRET) EQUAL TO THE NUMBER OF REPLICATIONS IN EACH +C OCCURRENCE OF PLEVL IN THE SUBSET. IF THERE ARE NO OCCURRENCES +C OF PLEVL IN THE SUBSET, IRET IS RETURNED AS ZERO. +C +C 2) WHEN THE BUFR FILE IS OPEN FOR OUTPUT, UFBINT CAN BE USED TO +C PRE-ALLOCATE SPACE FOR SOME OR ALL MNEMONICS WITHIN DELAYED +C REPLICATION SEQUENCES. A SUBSEQUENT CALL TO BUFR ARCHIVE +C LIBRARY ROUTINE UFBREP OR UFBSEQ THEN ACTUALLY STORES THE +C VALUES INTO THE BUFR FILES. HERE ARE TWO EXAMPLES OF THIS: +C +C EXAMPLE 1) PROBLEM: AN OUTPUT SUBSET "SEQNCE" IS LAID OUT AS +C FOLLOWS IN A BUFR TABLE (NOTE 16 CHARACTERS HAVE BEEN +C REMOVED FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN +C THIS DOCBLOCK): +C +C | SEQNCE | {PLEVL} | +C | PLEVL | WSPD WDIR TSIG PRLC TSIG PRLC TSIG PRLC | +C +C -- OR -- +C +C | SEQNCE | {PLEVL} | +C | PLEVL | WSPD WDIR "PSEQ"3 | +C | PSEQ | TSIG PRLC | +C +C IN THIS CASE THE APPLICATION PROGRAM MUST STORE VALUES WHICH +C HAVE STANDARD REPLICATION NESTED INSIDE OF A DELAYED +C REPLICATION SEQUENCE. FOR EXAMPLE, ASSUME 50 LEVELS OF WIND +C SPEED, WIND DIRECTION, OBSERVED PRESSURE, FIRST GUESS +c PRESSURE AND ANALYZED PRESSURE ARE TO BE WRITTEN TO "SEQNCE". +C +C THE FOLLOWING LOGIC WOULD ENCODE VALUES PROPERLY: +C..................................................................... +C .... +C REAL*8 DROBS(2,50) +C REAL*8 SROBS(2,150) +C .... +C DO I=1,50 +C DROBS(1,I) = Value of wind speed on level "I" +C DROBS(2,I) = Value of wind direction on level "I" +C SROBS(1,I*3-2) = Value of observed pressure on level "I" +C SROBS(2,I*3-2) = 25. ! Value in Code Table 0-08-021 (TSIG) +C ! for time sigificance (Nominal +C ! reporting time) for observed +C ! pressure on level "I" +C SROBS(1,I*3-1) = Value of first guess pressure on level "I" +C SROBS(2,I*3-1) = 27. ! Value in Code Table 0-08-021 (TSIG) +C ! for time sigificance (First guess) +C ! for first guess pressure on level "I" +C SROBS(1,I*3) = Value of analyzed pressure on level "I" +C SROBS(2,I*3) = 16. ! Value in Code Table 0-08-021 (TSIG) +C ! for time sigificance (Analysis) for +C ! analyzed pressure on level "I" +C ENDDO +C +C ! The call to UFBINT here will not only store the 50 +C ! values of WSPD and WDIR into the BUFR subset, it +C ! will also allocate the space to store three +C ! replications of TSIG and PRLC on each of the 50 +C ! delayed-replication "levels" +C CALL UFBINT(LUNIN,DROBS,2, 50,IRET,'WSPD WDIR') +C +C ! The call to UFBREP here will actually store the 150 +C ! values of both TSIG and PRLC (three values for each +C ! on 50 delayed-replication "levels") +C CALL UFBREP(LUNIN,SROBS,2,150,IRET,'TSIG PRLC') +C .... +C STOP +C END +C..................................................................... +C +C A SIMILAR EXAMPLE COULD BE PROVIDED FOR READING VALUES WHICH +C HAVE STANDARD REPLICATION NESTED WITHIN DELAYED REPLICATION, +C FROM BUFR FILES OPEN FOR INPUT. (NOT SHOWN HERE.) +C +C +C EXAMPLE 2) PROBLEM: AN INPUT SUBSET, "REPT_IN", AND AN OUTPUT +C SUBSET "REPT_OUT", ARE LAID OUT AS FOLLOWS IN A BUFR TABLE +C (NOTE 16 CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN +C TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK): +C +C | REPT_IN | YEAR MNTH DAYS HOUR MINU {PLEVL} CLAT CLON | +C | REPT_OUT | YEAR DOYR HOUR MINU {PLEVL} CLAT CLON | +C | PLEVL | PRLC TMBD REHU WDIR WSPD +C +C IN THIS CASE THE APPLICATION PROGRAM IS READING IN VALUES +C FROM A BUFR FILE CONTAINING SUBSET "REPT_IN", CONVERTING +C MONTH AND DAY TO DAY OF YEAR, AND THEN WRITING VALUES TO +C SUBSET "REPT_OUT" IN ANOTHER BUFR FILE. A CONVENIENT WAY TO +C DO THIS IS TO CALL UFBSEQ TO READ IN AND WRITE OUT THE +C VALUES, HOWEVER THIS IS COMPLICATED BY THE PRESENCE OF THE +C DELAYED-RELICATION SEQUENCE "PLEVL" BECAUSE THE OUTPUT CALL +C TO UFBSEQ DOES NOT KNOW A-PRIORI HOW MANY REPLICATIONS ARE +C NEEDED TO STORE THE CONTENTS OF "PLEVL" (IT SETS THE NUMBER +C TO ZERO BY DEFUALT). A CALL TO UFBINT IS FIRST NEEDED TO +C ALLOCATE THE SPACE AND DETERMINE THE NUMBER OF LEVELS NEEDED +C TO STORE ALL VALUES IN "PLEVL". +C +C THE FOLLOWING LOGIC WOULD PEFORM THE READ/WRITE PROPERLY: +C..................................................................... +C .... +C REAL*8 OBSI(2000),OBSO(1999),PLEVL(5,255),REPS_8 +C CHARACTER*8 SUBSET +C .... +C +C CALL DATELEN(10) +C +C ! Open input BUFR file in LUBFI and open output BUFR file in +C ! LUBFJ, both use the BUFR table in LINDX +C CALL OPENBF(LUBFI,'IN', LINDX) +C CALL OPENBF(LUBFJ,'OUT',LINDX) +C +C ! Read through the BUFR messages in the input file +C DO WHILE(IREADMG(LUBFI,SUBSET,IDATE).GE.0) +C +C ! Open message (for writing) in output file +C CALL OPENMB(LUBFJ,'REPT_OUT',IDATE) +C +C ! Read through the subsets in this input BUFR messages +C DO WHILE(IREADSB(LUBFI).EQ.0) +C +C ! This call to UFBSEQ will read in the entire contents +C ! of subset "REPT_IN", storing them into array OBSI +C ! (Note: On input, UFBSEQ knows how many replications +C of "PLEV" are present) +C CALL UFBSEQ(LUBFI,OBSI,2000,1,IRET,'REPT_IN') +C +C ! This call to UFBINT will return the number of +C ! replications ("levels") in "PLEVL" for subset +C ! "REPT_IN"" ! {see 1) above in REMARKS} +C CALL UFBINT(LUBFI,REPS_8,1,1,IRET,'{PLEVL}') +C IREPS = REPS_8 +C +C IYR = OBSI(1) +C IMO = OBSI(2) +C IDA = OBSI(3) +C CALL xxxx(IYR, IMO, IDA, JDY) ! convert month and day +C ! to day of year (JDY) +C OBSO(1) = OBSI(1) +C OBSO(2) = JDY +C DO I = 3,1999 +C OBSO(I) = OBSI(1+1) +C ENDDO +C +C PLEVL = GETBMISS() +C +C ! The call to UFBINT here will allocate the space to +C ! later allow UFBSEQ to store IREPS replications of +C ! "PLEVL" into the output BUFR subset "REPT_OUT" (note +C ! here it is simply storing missing values) +C CALL UFBINT(LUBFJ,PLEVL,5,IREPS,IRET, +C $ 'PRLC TMBD REHU WDIR WSPD') +C +C ! The call to UFBSEQ here will write out the entire +C ! contents of subset "REPT_OUT", reading them from +C ! array OBSO +C CALL UFBSEQ(LUBFJ,OBSO,1999,1,IRET,'REPT_OUT') +C +C ! Write the subset into the output BUFR message +C CALL WRITSB(LUBFJ) +C ENDDO +C +C ! All done +C +C STOP +C END +C..................................................................... +C +C +C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS +C STRING TRYBUMP UFBRW +C THIS ROUTINE IS CALLED BY: UFBINX UFBRMS +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR + REAL*8 USR(I1,I2),VAL + + DATA IFIRST1/0/,IFIRST2/0/ + + SAVE IFIRST1, IFIRST2 + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + LUNIT = ABS(LUNIN) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IM.EQ.0) GOTO 901 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 + + IO = MIN(MAX(0,IL),1) + IF(LUNIT.NE.LUNIN) IO = 0 + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.EQ.-1) IFIRST1 = 1 + IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST1 = 1 + ENDIF + GOTO 100 + ENDIF + +C PARSE OR RECALL THE INPUT STRING +C -------------------------------- + + CALL STRING(STR,LUN,I1,IO) + +C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION +C -------------------------------------------------- + + IF(IO.EQ.0) THEN + DO J=1,I2 + DO I=1,I1 + USR(I,J) = BMISS + ENDDO + ENDDO + ENDIF + +C CALL THE MNEMONIC READER/WRITER +C ------------------------------- + + CALL UFBRW(LUN,USR,I1,I2,IO,IRET) + +C IF INCOMPLETE WRITE TRY TO INITIALIZE REPLICATION SEQUENCE OR RETURN +C --------------------------------------------------------------------- + + IF(IO.EQ.1 .AND. IRET.NE.I2 .AND. IRET.GE.0) THEN + CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) + IF(IRET.NE.I2) GOTO 903 + ELSEIF(IRET.EQ.-1) THEN + IRET = 0 + ENDIF + + IF(IRET.EQ.0) THEN + IF(IO.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ELSE + IF(IPRT.EQ.-1) IFIRST2 = 1 + IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') + IF(IPRT.EQ.0) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST2 = 1 + ENDIF + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') +901 CALL BORT('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR '// + . 'FILE, NONE ARE') +902 CALL BORT('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR '// + . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// + . 'SUBSET ARRAY') +903 WRITE(BORT_STR1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS'// + . ': ",A)') STR + WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// + . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// + . ' - INCOMPLETE WRITE")') IRET,I2 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/ufbinx.f b/src/bufr/ufbinx.f new file mode 100644 index 0000000000..5213529a94 --- /dev/null +++ b/src/bufr/ufbinx.f @@ -0,0 +1,168 @@ + SUBROUTINE UFBINX(LUNIT,IMSG,ISUB,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBINX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO +C LOGICAL UNIT LUNIT FOR INPUT OPERATIONS (IF IT IS NOT ALREADY +C OPENED AS SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST +C DATA MESSAGE (IF BUFR FILE ALREADY OPENED), THEN (VIA A CALL TO +C BUFR ARCHIVE LIBRARY SUBROUTINE UFBINT) READS SPECIFIED VALUES FROM +C INTERNAL SUBSET ARRAYS ASSOCIATED WITH A PARTICULAR SUBSET FROM A +C PARTICULAR BUFR MESSAGE IN A MESSAGE BUFFER. THE PARTICULAR SUBSET +C AND BUFR MESSAGE ARE BASED BASED ON THE SUBSET NUMBER IN THE +C MESSAGE AND THE MESSAGE NUMBER IN THE BUFR FILE. FINALLY, THIS +C SUBROUTINE EITHER CLOSES THE BUFR FILE IN LUNIT (IF IS WAS OPENED +C HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND POSITION +C (IF IT WAS NOT OPENED HERE). SEE UFBINT FOR MORE INFORMATION ON +C THE READING OF VALUES OUT OF A BUFR MESSAGE SUBSET. NOTE: THE +C MESSAGE NUMBER HERE DOES NOT INCLUDE THE DICTIONARY MESSAGES AT THE +C BEGINNING OF THE FILE. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION +C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION +C VERSION AT ONE TIME AND THEN REMOVED) +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- MODIFY LOGIC TO HANDLE BUFR TABLE MESSAGES +C ENCOUNTERED ANYWHERE IN THE FILE (AND NOT +C JUST AT THE BEGINNING!) +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE +C USE 'INX' ARGUMENT TO OPENBF +C +C USAGE: CALL UFBINX (LUNIT, IMSG, ISUB, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER TO READ IN +C BUFR FILE +C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR +C MESSAGE +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D +C (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED +C REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)} +C +C OUTPUT ARGUMENT LIST: +C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ +C FROM DATA SUBSET +C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM +C DATA SUBSET (MUST BE NO LARGER THAN I2) +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CLOSBF OPENBF READMG +C READSB REWNBF STATUS UFBINT +C UPB +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + LOGICAL OPENIT + REAL*8 USR(I1,I2) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + OPENIT = IL.EQ.0 + + IF(OPENIT) THEN + +C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN +C ---------------------------------------------------------------- + + CALL OPENBF(LUNIT,'INX',LUNIT) + ELSE + +C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG +C --------------------------------------------------------------------- + + CALL REWNBF(LUNIT,0) + ENDIF + +C SKIP TO MESSAGE # IMSG +C ---------------------- + +C Note that we need to use subroutine READMG to actually read in all +C of the messages (including the first (IMSG-1) messages!), just in +C case there are any embedded dictionary messages in the file. + + DO I=1,IMSG + CALL READMG(LUNIT,SUBSET,JDATE,JRET) + IF(JRET.LT.0) GOTO 901 + ENDDO + +C POSITION AT SUBSET # ISUB +C ------------------------- + + DO I=1,ISUB-1 + IF(NSUB(LUN).GT.MSUB(LUN)) GOTO 902 + IBIT = MBYT(LUN)*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + MBYT(LUN) = MBYT(LUN) + NBYT + NSUB(LUN) = NSUB(LUN) + 1 + ENDDO + + CALL READSB(LUNIT,JRET) + IF(JRET.NE.0) GOTO 902 + + CALL UFBINT(LUNIT,USR,I1,I2,IRET,STR) + + IF(OPENIT) THEN + +C CLOSE BUFR FILE IF IT WAS OPENED HERE +C ------------------------------------- + + CALL CLOSBF(LUNIT) + ELSE + + +C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE +C --------------------------------------------------------------------- + + CALL REWNBF(LUNIT,1) + ENDIF + +C EXITS +C ----- + + RETURN +901 WRITE(BORT_STR,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// + . 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO'// + . ' UNIT",I4)') IMSG,LUNIT + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// + . 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR '// + . 'FILE CONNECTED TO UNIT",I4)') ISUB,IMSG,LUNIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbmem.f b/src/bufr/ufbmem.f new file mode 100644 index 0000000000..b158af92ce --- /dev/null +++ b/src/bufr/ufbmem.f @@ -0,0 +1,249 @@ + SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBMEM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH +C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY +C MSGS IN COMMON BLOCK /MSGMEM/). IF MESSAGES ARE APPENDED TO +C EXISTING MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS +C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO +C STORE ALL MESSAGES INTERNALLY WAS INCREASED +C FROM 4 MBYTES TO 8 MBYTES +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-11-15 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THERE ARE EITHER +C TOO MANY MESSAGES READ IN (I.E., .GT. +C MAXMSG) OR TOO MANY BYTES READ IN (I.E., +C .GT. MAXMEM), BUT RATHER JUST STORE MAXMSG +C MESSAGES OR MAXMEM BYTES AND PRINT A +C DIAGNOSTIC; PARAMETER MAXMEM (THE MAXIMUM +C NUMBER OF BYTES REQUIRED TO STORE ALL +C MESSAGES INTERNALLY) WAS INCREASED FROM 16 +C MBYTES TO 50 MBYTES +C 2005-11-29 J. ATOR -- USE RDMSGW AND NMWRD +C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE +C (DICTIONARY) MESSAGES +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C CALL STATUS TO GET LUN; REPLACE FORTRAN +C REWIND AND BACKSPACE WITH C ROUTINES CEWIND +C AND BACKBUFR +C +C USAGE: CALL UFBMEM (LUNIT, INEW, IRET, IUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C INEW - INTEGER: SWITCH: +C 0 = initialize internal arrays prior to +C transferring messages here +C else = append the messages transferred here to +C internal memory arrays +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED +C IUNIT - INTEGER: RETURN CODE: +C 0 = no messages were read from LUNIT, file is +C empty +C LUNIT = INEW input as 0 +C else = FORTRAN logical unit for BUFR file +C associated with initial message transferred +C to internal memory +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C +C REMARKS: +C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB +C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES +C FROM INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT CLOSBF CPDXMM ERRWRT +C IDXMSG NMWRD OPENBF RDMSGW +C STATUS CEWIND BACKBUFR +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + + CHARACTER*128 BORT_STR,ERRSTR + DIMENSION MBAY(MXMSGLD4) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE +C ---------------------------------------------------------- + + CALL OPENBF(LUNIT,'IN',LUNIT) + + IF(INEW.EQ.0) THEN + MSGP(0) = 0 + MUNIT = 0 + MLAST = 0 + NDXTS = 0 + LDXTS = 0 + NDXM = 0 + LDXM = 0 + ENDIF + + NMSG = MSGP(0) + IRET = 0 + IFLG = 0 + ITIM = 0 + +C Copy any BUFR dictionary table messages from the beginning of +C LUNIT into COMMON /MSGMEM/ for possible later use. Note that +C such a table (if one exists) is already now in scope due to the +C prior call to subroutine OPENBF, which in turn would have +C automatically called subroutines READDX, RDBFDX and MAKESTAB +C for this table. + + ITEMP = NDXTS + CALL STATUS(LUNIT,LUN,IL,IM) + CALL CEWIND(LUN) + CALL CPDXMM(LUNIT) + +C If a table was indeed present at the beginning of the file, +C then set the flag to indicate that this table is now in scope. + + IF ((ITEMP+1).EQ.NDXTS) LDXTS = NDXTS + +C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS +C ------------------------------------------------------------ + +1 CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.EQ.-1) GOTO 100 + IF(IER.EQ.-2) GOTO 900 + + IF(IDXMSG(MBAY).EQ.1) THEN + +C New "embedded" BUFR dictionary table messages have been found in +C this file. Copy them into COMMON /MSGMEM/ for later use. + + call backbufr(lun) !BACKSPACE LUNIT + CALL CPDXMM(LUNIT) + GOTO 1 + ENDIF + + NMSG = NMSG+1 + IF(NMSG .GT.MAXMSG) IFLG = 1 + LMEM = NMWRD(MBAY) + IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2 + + IF(IFLG.EQ.0) THEN + IRET = IRET+1 + DO I=1,LMEM + MSGS(MLAST+I) = MBAY(I) + ENDDO + MSGP(0) = NMSG + MSGP(NMSG) = MLAST+1 + ELSE + IF(ITIM.EQ.0) THEN + MLAST0 = MLAST + ITIM=1 + ENDIF + ENDIF + MLAST = MLAST+LMEM + GOTO 1 + +C EXITS +C ----- + +100 IF(IFLG.EQ.1) THEN + +C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW +C -------------------------------------------------- + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) + . 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ', + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, + . ') - INCOMPLETE READ' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + MLAST=MLAST0 + ENDIF + + IF(IFLG.EQ.2) THEN + +C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW +C -------------------------------------------------- + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) + . 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ', + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, + . ') - INCOMPLETE READ' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + MLAST=MLAST0 + ENDIF + + IF(IRET.EQ.0) THEN + CALL CLOSBF(LUNIT) + ELSE + IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) + IF(MUNIT.EQ.0) MUNIT = LUNIT + ENDIF + IUNIT = MUNIT + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE '// + . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbmex.f b/src/bufr/ufbmex.f new file mode 100644 index 0000000000..4c38f13e07 --- /dev/null +++ b/src/bufr/ufbmex.f @@ -0,0 +1,202 @@ + SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBMEX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-01-26 +C +C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH +C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY +C MSGS IN COMMON BLOCK /MSGMEM/). IF MESSAGES ARE APPENDED TO +C EXISTING MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS +C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. AN ARRAY IS +C ALSO RETURNED CONTAINING A LIST OF MESSAGE TYPES READ IN. +C +C THIS IS A VARIATION OF UFBMEM WHICH ENABLES MESSAGE SORTING BEFORE +C READING. BECAUSE OF THIS RE-ORDERING, EMBEDDED TABLE MESSAGES ARE +C NOT STORED IN COMMON /MSGMEM/, SINCE THEY ARE NO LONGER RELEVANT +C ONCE THE RE-ORDERING (I.E. SORTING) HAS TAKEN PLACE. INSTEAD, A +C SEPARATE UNIT NUMBER IS ADDED TO THE INPUT ARGUMENTS TO SPECIFY +C WHERE THE NECESSARY BUFR TABLE INFORMATION CAN BE FOUND. +C +C PROGRAM HISTORY LOG: +C 2012-01-26 J. WOOLLEN -- MODIFIED UFBMEM TO READ AND SORT MEMORY +C MESSAGES FOR TRANJB INGEST ROUTINES AND +C RETURN A LIST OF MESSAGE TYPES READ IN. +C ALSO, A SEPARATE INPUT ARGUMENT IS ADDED +C TO SPECIFY WHERE TO FIND THE BUFR TABLE, +C INSTEAD OF SAVING EMBEDDED DICTIONARY +C MESSAGES IN COMMON /MSGMEM/ +C +C USAGE: CALL UFBMEX (LUNIT, LUNDX, INEW, IRET, MESG) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER- +C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT +C INEW - INTEGER: SWITCH: +C 0 = initialize internal arrays prior to +C transferring messages here +C else = append the messages transferred here to +C internal memory arrays +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED +C MESG - INTEGER: ARRAY OF MESSAGE TYPES READ INTO MEMORY +C +C INPUT FILES: +C UNIT "LUNIT" - BUFR FILE +C UNIT "LUNDX" - BUFR DICTIONARY TABLE IN CHARACTER FORMAT +C +C REMARKS: +C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB +C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES +C FROM INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IUPBS01 +C NMWRD OPENBF RDMSGW +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + + CHARACTER*128 BORT_STR,ERRSTR + DIMENSION MBAY(MXMSGLD4) + INTEGER MESG(MAXMSG) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE +C ---------------------------------------------------------- + + CALL OPENBF(LUNIT,'IN',LUNDX) + + IF(INEW.EQ.0) THEN + MSGP(0) = 0 + MUNIT = 0 + MLAST = 0 + NDXTS = 0 + LDXTS = 0 + NDXM = 0 + LDXM = 0 + ENDIF + + NMSG = MSGP(0) + IRET = 0 + IFLG = 0 + ITIM = 0 + +C SET SOME FLAGS SO THAT SUBSEQUENT CALLS TO THE MESSAGE READING +C ROUTINES WILL KNOW THERE IS A BUFR TABLE IN SCOPE. + + NDXTS = 1 + LDXTS = 1 + IPMSGS(1) = 1 + +C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS +C ------------------------------------------------------------ + +1 CALL RDMSGW(LUNIT,MBAY,IER) + IF(IER.EQ.-1) GOTO 100 + IF(IER.EQ.-2) GOTO 900 + + NMSG = NMSG+1 + MESG(NMSG) = IUPBS01(MBAY,'MTYP') + IF(NMSG .GT.MAXMSG) IFLG = 1 + LMEM = NMWRD(MBAY) + IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2 + + IF(IFLG.EQ.0) THEN + IRET = IRET+1 + DO I=1,LMEM + MSGS(MLAST+I) = MBAY(I) + ENDDO + MSGP(0) = NMSG + MSGP(NMSG) = MLAST+1 + ELSE + IF(ITIM.EQ.0) THEN + MLAST0 = MLAST + ITIM=1 + ENDIF + ENDIF + MLAST = MLAST+LMEM + GOTO 1 + +C EXITS +C ----- + +100 IF(IFLG.EQ.1) THEN + +C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW +C -------------------------------------------------- + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) + . 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ', + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, + . ') - INCOMPLETE READ' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + MLAST=MLAST0 + ENDIF + + IF(IFLG.EQ.2) THEN + +C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW +C -------------------------------------------------- + + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) + . 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ', + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, + . ') - INCOMPLETE READ' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + MLAST=MLAST0 + ENDIF + + IF(IRET.EQ.0) THEN + CALL CLOSBF(LUNIT) + ELSE + IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) + IF(MUNIT.EQ.0) MUNIT = LUNIT + ENDIF + IUNIT = MUNIT + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '// + . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbmms.f b/src/bufr/ufbmms.f new file mode 100644 index 0000000000..11a737dabe --- /dev/null +++ b/src/bufr/ufbmms.f @@ -0,0 +1,109 @@ + SUBROUTINE UFBMMS(IMSG,ISUB,SUBSET,JDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBMMS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET INTO INTERNAL +C SUBSET ARRAYS FROM A PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY +C BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE MESSAGE NUMBER IN +C INTERNAL MEMORY. THIS SUBROUTINE IS ACTUALLY A COMBINATION OF +C BUFR ARCHIVE LIBRARY SUBROUTINES RDMEMM AND RDMEMS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO +C STORE ALL MESSAGES INTERNALLY WAS INCREASED +C FROM 4 MBYTES TO 8 MBYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C +C USAGE: CALL UFBMMS (IMSG, ISUB, SUBSET, JDATE) +C INPUT ARGUMENT LIST: +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C STORAGE +C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR +C MESSAGE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE +C CONTAINING SUBSET +C JDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE +C CONTAINING SUBSET, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C +C REMARKS: +C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT RDMEMM RDMEMS STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C READ SUBSET #ISUB FROM MEMORY MESSAGE #IMSG +C ------------------------------------------- + + CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) + IF(IRET.LT.0) GOTO 900 + CALL RDMEMS(ISUB,IRET) + IF(IRET.NE.0) GOTO 901 + +C EXITS +C ----- + + RETURN +900 IF(IMSG.GT.0) THEN + WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE '// + . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '// + . 'MEMORY (",I5,")")') IMSG,MSGP(0) + ELSE + WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE '// + . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")') + ENDIF + CALL BORT(BORT_STR) +901 CALL STATUS(MUNIT,LUN,IL,IM) + WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQ. SUBSET NUMBER TO READ '// + . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// + . 'REG. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbmns.f b/src/bufr/ufbmns.f new file mode 100644 index 0000000000..88552a5c37 --- /dev/null +++ b/src/bufr/ufbmns.f @@ -0,0 +1,107 @@ + SUBROUTINE UFBMNS(IREP,SUBSET,IDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBMNS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET INTO INTERNAL +C SUBSET ARRAYS FROM A COLLECTION OF BUFR MESSAGES IN INTERNAL MEMORY +C BASED ON THE SUBSET NUMBER RELATIVE TO THE TOTAL NUMBER OF SUBSETS +C IN THE COLLECTION. THE SUBROUTINE DOES NOT RETURN ANY INFORMATION +C ABOUT WHICH MESSAGE NUMBER CONTAINED THE DESIRED SUBSET. IF THE +C REQUESTED SUBSET IS LARGER THAN THE TOTAL NUMBER OF SUBSETS IN +C MEMORY, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY +C SUBROUTINE BORT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO +C STORE ALL MESSAGES INTERNALLY WAS INCREASED +C FROM 4 MBYTES TO 8 MBYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2009-03-23 J. ATOR -- USE IREADMM INSTEAD OF RDMEMM; +C SIMPLIFY LOGIC +C +C USAGE: CALL UFBMNS (IREP, SUBSET, IDATE) +C INPUT ARGUMENT LIST: +C IREP - INTEGER: POINTER TO SUBSET NUMBER TO READ IN +C COLLECTION OF MESSAGES +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE +C CONTAINING SUBSET +C IDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE +C CONTAINING SUBSET, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C +C REMARKS: +C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT IREADMM NMSUB RDMEMS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + JREP = 0 + IMSG = 1 + +C READ SUBSET #ISUB FROM MEMORY MESSAGE #IMSG +C ------------------------------------------- + + DO WHILE(IREADMM(IMSG,SUBSET,IDATE).EQ.0) + IF(JREP+NMSUB(MUNIT).GE.IREP) THEN + CALL RDMEMS(IREP-JREP,IRET) + GOTO 100 + ENDIF + JREP = JREP+NMSUB(MUNIT) + ENDDO + GOTO 900 + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: UFBMNS - REQ. SUBSET NO. TO READ IN '// + . '(",I5,") EXCEEDS TOTAL NO. OF SUBSETS IN THE COLLECTION OF '// + . 'MEMORY MESSAGES (",I5,")")') IREP,JREP + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbovr.f b/src/bufr/ufbovr.f new file mode 100644 index 0000000000..75bcdfccd2 --- /dev/null +++ b/src/bufr/ufbovr.f @@ -0,0 +1,191 @@ + SUBROUTINE UFBOVR(LUNIT,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBOVR +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE WRITES OVER SPECIFIED VALUES WHICH EXIST +C IN CURRENT INTERNAL BUFR SUBSET ARRAYS IN A FILE OPEN FOR OUTPUT. +C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A +C DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION +C AT ALL. EITHER BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR OPENMB +C MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A BUFR +C MESSAGE WITHIN MEMORY FOR THIS LUNIT. IN ADDITION, BUFR ARCHIVE +C LIBRARY SUBROUTINE WRITSB OR INVMRG MUST HAVE BEEN CALLED TO STORE +C DATA IN THE INTERNAL OUTPUT SUBSET ARRAYS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR +C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM +C BORT TO BORT2 IN SOME CASES +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBOVR (LUNIT, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE +C WRITTEN TO DATA SUBSET +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES WRITTEN TO +C DATA SUBSET (SHOULD BE SAME AS I2) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS +C STRING TRYBUMP +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + + CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR + CHARACTER*(*) STR + REAL*8 USR(I1,I2),VAL + + DATA IFIRST1/0/,IFIRST2/0/ + + SAVE IFIRST1, IFIRST2 + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 + +C .... DK: Why check, isn't IO always 1 here? + IO = MIN(MAX(0,IL),1) + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.EQ.-1) IFIRST1 = 1 + IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST1 = 1 + ENDIF + GOTO 100 + ENDIF + +C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES +C ---------------------------------------------------- + + CALL STRING(STR,LUN,I1,IO) + CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) + + IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 904 + + IF(IRET.EQ.0) THEN + IF(IPRT.EQ.-1) IFIRST2 = 1 + IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBOVR - NO SPECIFIED VALUES WRITTEN OUT, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') + IF(IPRT.EQ.0) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST2 = 1 + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// + . 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') +904 WRITE(BORT_STR1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS'// + . ': ",A)') STR + WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// + . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// + . ' - INCOMPLETE WRITE")') IRET,I2 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/ufbpos.f b/src/bufr/ufbpos.f new file mode 100644 index 0000000000..a3d667255f --- /dev/null +++ b/src/bufr/ufbpos.f @@ -0,0 +1,143 @@ + SUBROUTINE UFBPOS(LUNIT,IREC,ISUB,SUBSET,JDATE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBPOS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1995-11-22 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT POSITIONS THE +C MESSAGE POINTER TO A USER-SPECIFIED BUFR MESSAGE NUMBER IN THE FILE +C CONNECTED TO LUNIT AND THEN CALLS BUFR ARCHIVE LIBRARY SUBROUTINE +C READMG TO READ THIS BUFR MESSAGE INTO A MESSAGE BUFFER (ARRAY MBAY +C IN COMMON BLOCK /BITBUF/). IT THEN POSITIONS THE SUBSET POINTER TO +C A USER-SPECIFIED SUBSET NUMBER WITHIN THE BUFR MESSAGE AND CALLS +C BUFR ARCHIVE LIBRARY SUBROUTINE READSB TO READ THIS SUBSET INTO +C INTERNAL SUBSET ARRAYS. THE BUFR MESSAGE HERE MAY BE EITHER +C COMPRESSED OR UNCOMPRESSED. THE USER-SPECIFIED MESSAGE NUMBER DOES +C NOT INCLUDE ANY DICTIONARY MESSAGES THAT MAY BE AT THE TOP OF THE +C FILE). +C +C PROGRAM HISTORY LOG: +C 1995-11-22 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN-LINED IN PROGRAM +C NAM_STNMLIST) +C 2005-03-04 D. KEYSER -- ADDED TO BUFR ARCHIVE LIBRARY; ADDED +C DOCUMENTATION +C 2005-11-29 J. ATOR -- USE IUPBS01 AND RDMSGW +C 2006-04-14 J. ATOR -- REMOVE UNNECESSARY MOIN INITIALIZATION +C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE +C (DICTIONARY) MESSAGES +C +C USAGE: CALL UFBPOS( LUNIT, IREC, ISUB, SUBSET, JDATE ) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C IREC - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C FILE (DOES NOT INCLUDE ANY DICTIONARY MESSSAGES THAT +C MAY BE AT THE TOP OF THE FILE) +C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR +C MESSAGE +C +C OUTPUT ARGUMENT LIST: +C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE +C BEING READ +C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR +C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR +C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CEWIND NMSUB READMG +C READSB STATUS UFBCNT UPB +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + + CHARACTER*128 BORT_STR + CHARACTER*8 SUBSET + +C----------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C MAKE SURE A FILE IS OPEN FOR INPUT +C ---------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + + IF(IREC.LE.0) GOTO 902 + IF(ISUB.LE.0) GOTO 903 + +C SEE WHERE POINTERS ARE CURRENTLY LOCATED +C ---------------------------------------- + + CALL UFBCNT(LUNIT,JREC,JSUB) + +C REWIND FILE IF REQUESTED POINTERS ARE BEHIND CURRENT POINTERS +C ------------------------------------------------------------- + + IF(IREC.LT.JREC .OR. (IREC.EQ.JREC.AND.ISUB.LT.JSUB)) THEN + CALL CEWIND(LUN) + NMSG(LUN) = 0 + NSUB(LUN) = 0 + CALL UFBCNT(LUNIT,JREC,JSUB) + ENDIF + +C READ SUBSET #ISUB FROM MESSAGE #IREC FROM FILE +C ---------------------------------------------- + + DO WHILE (IREC.GT.JREC) + CALL READMG(LUNIT,SUBSET,JDATE,IRET) + IF(IRET.LT.0) GOTO 904 + CALL UFBCNT(LUNIT,JREC,JSUB) + ENDDO + + KSUB = NMSUB(LUNIT) + IF(ISUB.GT.KSUB) GOTO 905 + + DO WHILE (ISUB-1.GT.JSUB) + IBIT = MBYT(LUN)*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + MBYT(LUN) = MBYT(LUN) + NBYT + NSUB(LUN) = NSUB(LUN) + 1 + CALL UFBCNT(LUNIT,JREC,JSUB) + ENDDO + + CALL READSB(LUNIT,IRET) + IF(IRET.NE.0) GOTO 905 + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST'// + . ' BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT'// + . ', IT MUST BE OPEN FOR INPUT') +902 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// + . 'TO READ IN (",I5,") IS NOT VALID")') IREC + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED SUBSET NUMBER '// + . 'TO READ IN (",I5,") IS NOT VALID")') ISUB + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// + . 'TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN THE '// + . 'FILE (",I5,")")') IREC,JREC + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQ. SUBSET NUMBER TO READ'// + . ' IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// + . 'REQ. MESSAGE (",I5,")")') ISUB,KSUB,IREC + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbqcd.f b/src/bufr/ufbqcd.f new file mode 100644 index 0000000000..6f88d9d29a --- /dev/null +++ b/src/bufr/ufbqcd.f @@ -0,0 +1,95 @@ + SUBROUTINE UFBQCD(LUNIT,NEMO,QCD) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBQCD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS IN A MNEMONIC KNOWN TO BE IN THE BUFR +C TABLE ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT, AND +C RETURNS THE DESCRIPTOR ENTRY (Y) ASSOCIATED WITH IT WHEN THE FXY +C DESCRIPTOR IS A SEQUENCE DESCRIPTOR (F=3) WITH TABLE D CATEGORY 63 +C (X=63). THIS ROUTINE WILL NOT WORK FOR ANY OTHER TYPE OF +C DESCRIPTOR OR ANY OTHER SEQUENCE DESCRIPTOR TABLE D CATEGORY. +C LUNIT MUST ALREADY BE OPENED FOR INPUT OR OUTPUT VIA A CALL TO +C OPENBF. THIS ROUTINE IS ESPECIALLY USEFUL WHEN THE CALLING PROGRAM +C IS WRITING "EVENTS" TO AN OUTPUT BUFR FILE (USUALLY THE "PREPBUFR" +C FILE) USING THE SAME BUFR TABLE SINCE THE DESCRIPTOR ENTRY (Y) HERE +C DEFINES THE EVENT PROGRAM CODE. THUS, THE CALLING PROGRAM CAN PASS +C THE PROGRAM CODE INTO VARIOUS EVENTS WITHOUT ACTUALLY KNOWING ITS +C VALUE AS LONG AS IT KNOWS THE MNEMONIC NAME ASSOCIATED WITH IT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: CALL UFBQCD (LUNIT, NEMO, QCD) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C (ASSOCIATED BUFR TABLE MAY BE INTERNAL OR EXTERNAL) +C NEMO - CHARACTER*(*): MNEMONIC +C +C OUTPUT ARGUMENT LIST: +C QCD - REAL: SEQUENCE DESCRIPTOR ENTRY (I.E., EVENT PROGRAM +C CODE) IN BUFR TABLE ASSOCIATED WITH NEMO (Y IN FXY +C DESCRIPTOR, WHERE F=3 AND X=63) +C +C REMARKS: +C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE +C UFBQCP. +C +C THIS ROUTINE CALLS: ADN30 BORT NEMTAB STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) NEMO + CHARACTER*128 BORT_STR + CHARACTER*6 FXY,ADN30 + CHARACTER*1 TAB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + + CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) + IF(TAB.NE.'D') GOTO 901 + + FXY = ADN30(IDN,6) + IF(FXY(2:3).NE.'63') GOTO 902 + READ(FXY(4:6),'(F3.0)',ERR=903) QCD + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') +901 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT '// + . 'DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') NEMO + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - BUFR TABLE SEQ. DESCRIPTOR '// + . 'ASSOC. WITH INPUT MNEMONIC ",A," HAS INVALID CATEGORY ",A," -'// + . ' CATEGORY MUST BE 63")') NEMO,FXY(2:3) + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - ERROR READING ENTRY '// + . '(PROGRAM CODE) FROM BUFR TBL SEQ. DESCRIPTOR ",A," ASSOC. '// + . 'WITH INPUT MNEM. ",A)') FXY,NEMO + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbqcp.f b/src/bufr/ufbqcp.f new file mode 100644 index 0000000000..9281cc6157 --- /dev/null +++ b/src/bufr/ufbqcp.f @@ -0,0 +1,79 @@ + SUBROUTINE UFBQCP(LUNIT,QCP,NEMO) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBQCP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS IN A FXY DESCRIPTOR ENTRY (Y) FOR A +C SEQUENCE DESCRIPTOR (F=3) WITH TABLE D CATEGORY 63 (X=63) WHEN THE +C DESCRIPTOR IS KNOWN TO BE IN THE BUFR TABLE IN LOGICAL UNIT LUNIT, +C AND RETURNS THE MNEMONIC ASSOCIATED WITH IT. THIS ROUTINE WILL NOT +C WORK FOR ANY OTHER TYPE OF DESCRIPTOR OR ANY OTHER SEQUENCE +C DESCRIPTOR TABLE D CATEGORY. LUNIT MUST ALREADY BE OPENED FOR +C INPUT OR OUTPUT VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE +C OPENBF. THIS ROUTINE IS ESPECIALLY USEFUL WHEN THE CALLING PROGRAM +C IS READING "EVENTS" FROM AN INPUT BUFR FILE IN LUNIT (USUALLY THE +C "PREPBUFR" FILE) SINCE THE DESCRIPTOR ENTRY (Y) HERE DEFINES THE +C EVENT PROGRAM CODE. THUS, THE CALLING PROGRAM CAN OBTAIN THE +C MNEMONIC NAME ASSOCIATED WITH AN EVENT PROGRAM CODE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C +C USAGE: CALL UFBQCP (LUNIT, QCP, NEMO) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C (ASSOCIATED BUFR TABLE MAY BE INTERNAL OR EXTERNAL) +C QCP - REAL: SEQUENCE DESCRIPTOR ENTRY (I.E., EVENT PROGRAM +C CODE) (Y IN FXY DESCRIPTOR) +C +C OUTPUT ARGUMENT LIST: +C NEMO - CHARACTER*(*): MNEMONIC IN BUFR TABLE ASSOCIATED WITH +C SEQUENCE DESCRIPTOR FXY WHERE F=3 AND X=63 AND +C Y=INT(QCP) +C +C REMARKS: +C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE +C UFBQCD. +C +C THIS ROUTINE CALLS: BORT IFXY NUMTAB STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*(*) NEMO + CHARACTER*1 TAB + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + + IDN = IFXY('363000')+IFIX(QCP) +c .... get NEMO from IDN + CALL NUMTAB(LUN,IDN,NEMO,TAB,IRET) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') + END diff --git a/src/bufr/ufbrep.f b/src/bufr/ufbrep.f new file mode 100644 index 0000000000..ee59ea329c --- /dev/null +++ b/src/bufr/ufbrep.f @@ -0,0 +1,296 @@ + SUBROUTINE UFBREP(LUNIO,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBREP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR +C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF +C ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN +C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). +C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE EITHER: +C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE +C OR +C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN +C OVERALL SUBSET DEFINITION +C +C THE DIFFERENCE IN THE WAY UFBREP WORKS AS COMPARED TO UFBINT IS IN +C THE WAY THE MNEMONIC STRING IS INTERPRETED TO DEFINE WHICH ELEMENTS +C ARE PROCESSED AND IN WHAT ORDER. UFBREP INTERPRETS THE FIRST +C MNEMONIC IN THE STRING AS A "PIVOT". THIS MEANS THE 2ND DIMENSION +C OF THE DATA RETURNED (AS INDICATED BY ARGUMENT I2) IS DEFINED BY +C OCCURRENCES OF THE PIVOT ELEMENT FOUND WITHIN THE OVERALL SUBSET +C DEFINITION. FOR EXAMPLE, IF THE SUBSET DEFINITION CONTAINS THE +C FOLLOWING SEQUENCE OF MNEMONICS: +C {..,A,..,B,..,C,..,D,..,A,..,C,..,D,..,B,.. +C A,..,B,..,D,..,C,..,A,..,C,..,B,..,D,..}, +C THEN READING A SUBSET VIA UFBREP WITH STR = "A B C D" RETURNS THE +C FOLLOWING 4X4 MATRIX OF VALUES IN USR, USING A AS THE "PIVOT" +C MNEMONIC SINCE IT WAS THE FIRST MNEMONIC IN THE STRING: +C ( A1, B1, C1, D2, +C A2, B2, C2, D2, +C A3, B3, C3, D3, +C A4, B4, C4, D4 ) +C NOTE THAT, WHEN USING UFBREP, THE ORDER OF THE NON-PIVOT MNEMONICS +C BETWEEN EACH PIVOT IS IMMATERIAL, I.E., IN THE ABOVE EXAMPLE, UFBREP +C FINDS ALL OF THE OCCURRENCES OF MNEMONICS B, C AND D BETWEEN EACH +C PIVOT BECAUSE IT SEARCHES INDEPENDENTLY FOR EACH ONE BETWEEN +C SUCCESSIVE PIVOTS. +C +C IN CONTRAST, NOTE THERE IS ALSO A SEPARATE SUBROUTINE UFBSTP WHICH +C IS SIMILAR TO UFBREP, EXCEPT THAT UFBSTP ALWAYS STEPS FORWARD WHEN +C SEARCHING FOR EACH SUCCESSIVE NON-PIVOT MNEMONIC, RATHER THAN +C SEARCHING INDEPENDENTLY FOR EACH ONE BETWEEN SUCCESSIVE PIVOTS. +C SO IN THE ABOVE EXAMPLE WITH STR="A B C D" AND STARTING FROM EACH +C SUCCESSIVE PIVOT MNEMONIC A, UFBSTP WOULD SEARCH FORWARD FOR THE +C NEXT OCCURRENCE OF MNEMONIC B, THEN IF FOUND SEARCH FORWARD FROM +C THERE FOR THE NEXT OCCURRENCE OF C, THEN IF FOUND SEARCH FORWARD +C FROM THERE FOR THE NEXT OCCURRENCE OF D, ETC. UP UNTIL REACHING +C THE NEXT OCCURRENCE OF THE PIVOT MNEMONIC A (OR THE END OF THE DATA +C SUBSET), WITHOUT EVER DOING ANY BACKTRACKING. SO IN THE ABOVE +C EXAMPLE UFBSTP WOULD RETURN THE FOLLOWING 4x4 MATRIX OF VALUES IN +C ARRAY USR, WHERE XX DENOTES A "MISSING" VALUE: +C ( A1, B1, C1, D2, +C A2, B2, XX, XX, +C A3, B3, C3, XX, +C A4, B4, XX, XX ) +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-05-19 J. WOOLLEN -- DISABLED THE PARSING SWITCH WHICH CONTROLS +C CHECKING FOR IN THE SAME REPLICATION GROUP, +C UFBREP DOES NOT NEED THIS CHECK, AND IT +C INTERFERES WITH WHAT UFBREP CAN DO +C OTHERWISE +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR +C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM +C BORT TO BORT2 IN SOME CASES +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS +C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBREP (LUNIO, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIO - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE +C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS +C THAN ZERO, UFBREP TREATS THE BUFR FILE AS THOUGH +C IT WERE OPEN FOR INPUT +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE +C "GENERIC" MNEMONICS NOT RELATED TO TABLE B, +C THESE RETURN THE FOLLOWING INFORMATION IN +C CORRESPONDING USR LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS +C STRING UFBRP +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /ACMODE/ IAC + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR + REAL*8 USR(I1,I2),VAL + + DATA IFIRST1/0/,IFIRST2/0/ + + SAVE IFIRST1, IFIRST2 + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + LUNIT = ABS(LUNIO) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IM.EQ.0) GOTO 901 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 + + IO = MIN(MAX(0,IL),1) + IF(LUNIO.NE.LUNIT) IO = 0 + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.EQ.-1) IFIRST1 = 1 + IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST1 = 1 + ENDIF + GOTO 100 + ENDIF + +C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION +C -------------------------------------------------- + + IF(IO.EQ.0) THEN + DO J=1,I2 + DO I=1,I1 + USR(I,J) = BMISS + ENDDO + ENDDO + ENDIF + +C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES +C ---------------------------------------------------- + + IA2 = IAC + IAC = 1 + CALL STRING(STR,LUN,I1,IO) + +C CALL THE MNEMONIC READER/WRITER +C ------------------------------- + + CALL UFBRP(LUN,USR,I1,I2,IO,IRET) + IAC = IA2 + + IF(IO.EQ.1 .AND. IRET.LT.I2) GOTO 903 + + IF(IRET.EQ.0) THEN + IF(IO.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ELSE + IF(IPRT.EQ.-1) IFIRST2 = 1 + IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES WRITTEN OUT, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') + IF(IPRT.EQ.0) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST2 = 1 + ENDIF + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') +901 CALL BORT('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR '// + . 'FILE, NONE ARE') +902 CALL BORT('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR '// + . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// + . 'SUBSET ARRAY') +903 WRITE(BORT_STR1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS'// + . ': ",A)') STR + WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// + . 'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - '// + . 'INCOMPLETE WRITE")') IRET,I2 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/ufbrms.f b/src/bufr/ufbrms.f new file mode 100644 index 0000000000..f4149fa286 --- /dev/null +++ b/src/bufr/ufbrms.f @@ -0,0 +1,154 @@ + SUBROUTINE UFBRMS(IMSG,ISUB,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBRMS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES OUT OF A PARTICULAR +C SUBSET WHICH HAS BEEN READ INTO INTERNAL SUBSET ARRAYS FROM A +C PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY. THE DATA VALUES +C CORRESPOND TO MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION +C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. THE SUBSET +C READ IN IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE +C MESSAGE READ IN IS BASED ON THE MESSAGE NUMBER IN INTERNAL MEMORY. +C THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY +C SUBROUTINES RDMEMM, RDMEMS AND UFBINT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO +C STORE ALL MESSAGES INTERNALLY WAS INCREASED +C FROM 4 MBYTES TO 8 MBYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBRMS (IMSG, ISUB, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN +C STORAGE +C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR +C MESSAGE +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D +C (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED +C REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)} +C +C OUTPUT ARGUMENT LIST: +C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ +C FROM DATA SUBSET +C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM +C DATA SUBSET (MUST BE NO LARGER THAN I2) +C +C REMARKS: +C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT ERRWRT RDMEMM RDMEMS +C STATUS UFBINT +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*8 SUBSET + REAL*8 USR(I1,I2) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IRET = 0 + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ENDIF + +C UFBINT SUBSET #ISUB FROM MEMORY MESSAGE #IMSG +C --------------------------------------------- + + CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) + IF(IRET.LT.0) GOTO 900 + CALL RDMEMS(ISUB,IRET) + IF(IRET.NE.0) GOTO 901 + + CALL UFBINT(MUNIT,USR,I1,I2,IRET,STR) + +C EXITS +C ----- + +100 RETURN +900 IF(IMSG.GT.0) THEN + WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '// + . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '// + . 'MEMORY (",I5,")")') IMSG,MSGP(0) + ELSE + WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '// + . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")') + ENDIF + CALL BORT(BORT_STR) +901 CALL STATUS(MUNIT,LUN,IL,IM) + WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ '// + . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// + . 'REQ. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbrp.f b/src/bufr/ufbrp.f new file mode 100644 index 0000000000..58f071fcca --- /dev/null +++ b/src/bufr/ufbrp.f @@ -0,0 +1,145 @@ + SUBROUTINE UFBRP(LUN,USR,I1,I2,IO,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBRP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR +C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO +C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR +C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). +C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED +C STRINGS OF MNEMONICS WHICH ARE EITHER: +C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE +C OR +C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN +C OVERALL SUBSET DEFINITION +C +C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; +C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE +C LIBRARY SUBROUTINE UFBREP. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION +C +C USAGE: CALL UFBRP (LUN, USR, I1, I2, IO, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUN: +C 0 = input file +C 1 = output file +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C +C REMARKS: +C THIS ROUTINE CALLS: INVTAG +C THIS ROUTINE IS CALLED BY: UFBREP +C Normally not called by any application +C programs (they should call UFBREP). +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + + REAL*8 USR(I1,I2),VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + INS1 = 0 + INS2 = 0 + +C FIND FIRST NON-ZERO NODE IN STRING +C ---------------------------------- + + DO NZ=1,NNOD + IF(NODS(NZ).GT.0) GOTO 1 + ENDDO + GOTO 100 + +C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME +C ---------------------------------------------------- + +1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100 + IF(IO.EQ.1 .AND. IRET.EQ.I2) GOTO 100 + INS1 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN)) + IF(INS1.EQ.0) GOTO 100 + + INS2 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN)) + IF(INS2.EQ.0) INS2 = NVAL(LUN) + IRET = IRET+1 + +C READ USER VALUES +C ---------------- + + IF(IO.EQ.0 .AND. IRET.LE.I2) THEN + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INVN = INVTAG(NODS(I),LUN,INS1,INS2) + IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) + ENDIF + ENDDO + ENDIF + +C WRITE USER VALUES +C ----------------- + + IF(IO.EQ.1 .AND. IRET.LE.I2) THEN + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INVN = INVTAG(NODS(I),LUN,INS1,INS2) + IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET) + ENDIF + ENDDO + ENDIF + +C GO FOR NEXT FRAME +C ----------------- + + GOTO 1 + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/ufbrw.f b/src/bufr/ufbrw.f new file mode 100644 index 0000000000..778af9723d --- /dev/null +++ b/src/bufr/ufbrw.f @@ -0,0 +1,218 @@ + SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBRW +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM +C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO +C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR +C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). +C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED +C STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION +C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. +C +C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; +C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE +C LIBRARY SUBROUTINE UFBINT. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO +C WRITE NON-EXISTING MNEMONICS +C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS +C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT; USE LSTJPB INSTEAD OF LSTRPS +C +C USAGE: CALL UFBRW (LUN, USR, I1, I2, IO, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUN: +C 0 = input file +C 1 = output file +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED +C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED +C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE +C +C REMARKS: +C THIS ROUTINE CALLS: CONWIN DRSTPL ERRWRT GETWIN +C IBFMS INVWIN LSTJPB NEWWIN +C NXTWIN +C THIS ROUTINE IS CALLED BY: TRYBUMP UFBINT +C Normally not called by any application +C programs (they should call UFBINT). +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /QUIET / IPRT + + CHARACTER*128 ERRSTR + CHARACTER*10 TAG + CHARACTER*3 TYP + REAL*8 USR(I1,I2),VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + +C LOOP OVER COND WINDOWS +C ---------------------- + + INC1 = 1 + INC2 = 1 + +1 CALL CONWIN(LUN,INC1,INC2) + IF(NNOD.EQ.0) THEN + IRET = I2 + GOTO 100 + ELSEIF(INC1.EQ.0) THEN + GOTO 100 + ELSE + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INS2 = INC1 + CALL GETWIN(NODS(I),LUN,INS1,INS2) + IF(INS1.EQ.0) GOTO 100 + GOTO 2 + ENDIF + ENDDO + IRET = -1 + GOTO 100 + ENDIF + +C LOOP OVER STORE NODES +C --------------------- + +2 IRET = IRET+1 + + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(5(A,I4))' ) + . 'BUFRLIB: UFBRW - IRET:INS1:INS2:INC1:INC2 = ', + . IRET, ':', INS1, ':', INS2, ':', INC1, ':', INC2 + CALL ERRWRT(ERRSTR) + KK = INS1 + DO WHILE ( ( INS2 - KK ) .GE. 5 ) + WRITE ( UNIT=ERRSTR, FMT='(5A10)' ) + . (TAG(INV(I,LUN)),I=KK,KK+4) + CALL ERRWRT(ERRSTR) + KK = KK+5 + ENDDO + WRITE ( UNIT=ERRSTR, FMT='(5A10)' ) + . (TAG(INV(I,LUN)),I=KK,INS2) + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C WRITE USER VALUES +C ----------------- + + IF(IO.EQ.1 .AND. IRET.LE.I2) THEN + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + IF(IBFMS(USR(I,IRET)).EQ.0) THEN + INVN = INVWIN(NODS(I),LUN,INS1,INS2) + IF(INVN.EQ.0) THEN + CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) + IF(INVN.EQ.0) THEN + IRET = 0 + GOTO 100 + ENDIF + CALL NEWWIN(LUN,INC1,INC2) + VAL(INVN,LUN) = USR(I,IRET) + ELSEIF(LSTJPB(NODS(I),LUN,'RPS').EQ.0) THEN + VAL(INVN,LUN) = USR(I,IRET) + ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN + VAL(INVN,LUN) = USR(I,IRET) + ELSE + CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) + IF(INVN.EQ.0) THEN + IRET = 0 + GOTO 100 + ENDIF + CALL NEWWIN(LUN,INC1,INC2) + VAL(INVN,LUN) = USR(I,IRET) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + +C READ USER VALUES +C ---------------- + + IF(IO.EQ.0 .AND. IRET.LE.I2) THEN + DO I=1,NNOD + USR(I,IRET) = BMISS + IF(NODS(I).GT.0) THEN + INVN = INVWIN(NODS(I),LUN,INS1,INS2) + IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) + ENDIF + ENDDO + ENDIF + +C DECIDE WHAT TO DO NEXT +C ---------------------- + + IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100 + CALL NXTWIN(LUN,INS1,INS2) + IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 + IF(NCON.GT.0) GOTO 1 + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/ufbseq.f b/src/bufr/ufbseq.f new file mode 100644 index 0000000000..66e73ecbb4 --- /dev/null +++ b/src/bufr/ufbseq.f @@ -0,0 +1,386 @@ + SUBROUTINE UFBSEQ(LUNIN,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBSEQ +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM +C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF +C ABS(LUNIN) {I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN +C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET}. +C THE DATA VALUES CORRESPOND TO A SEQUENCE OF TABLE B MNEMONICS WHICH +C ARE REPRESENTED BY A SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC. +C THIS SEQUENCE MNEMONIC MAY ITSELF CONTAIN ONE OR MORE TABLE D +C SEQUENCE MNEMONICS ALONG WITH TABLE B MNEMONICS, THE SEQUENCE +C MNEMONICS HERE CAN USE EITHER DELAYED REPLICATION, REGULAR (I.E., +C NON-DELAYED) REPLICATION OR THEY CAN HAVE NO REPLICATION AT ALL. +C HOWEVER, IN CASES WHERE THIS SUBROUTINE IS WRITING DATA VALUES TO +C SEQUENCES USING DELAYED-REPLICATION, THE APPLICATION PROGRAM MUST +C FIRST CALL BUFR ARCHIVE LIBRARY ROUTINE DRFINI TO PRE-ALLOCATE THE +C SPACE NEEDED TO EXPAND THE DELAYED-REPLICATION SEQUENCE (THE NUMBER +C OF REPLICATIONS IN DELAYED-REPLICATION IS SET TO ZERO BY DEFAULT). +C (SEE BUFR ARCHIVE LIBRARY DRFINI DOCBLOCK REMARKS FOR MORE +C INFORMATION.) IF UFBSEQ IS READING VALUES, THEN EITHER BUFR ARCHIVE +C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY +C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO INTERNAL +C MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE LIBRARY +C SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO +C OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS +C ABS(LUNIN). +C +C PROGRAM HISTORY LOG: +C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR +C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY UFBSEQ +C WOULD NOT RECOGNIZE COMPRESSED DELAYED +C REPLICATION AS A LEGITIMATE DATA STRUCTURE +C 2003-05-19 J. WOOLLEN -- CORRECTED THE LOGIC ARRAY OF EXIT +C CONDITIONS FOR THE SUBROUTINE, PREVIOUSLY, +C IN SOME CASES, PROPER EXITS WERE MISSED, +C GENERATING BOGUS ERROR MESSAGES, BECAUSE OF +C SEVERAL MISCELLANEOUS BUGS WHICH ARE NOW +C REMOVED +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR +C UNUSUAL THINGS HAPPEN +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBSEQ (LUNIN, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT +C NUMBER FOR BUFR FILE +C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS +C THAN ZERO, UFBSEQ TREATS THE BUFR FILE AS THOUGH +C IT WERE OPEN FOR INPUT +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF UNIQUE TABLE B MNEMONICS REPRESENTED BY THE +C SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC IN STR +C (FORMER MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET; THIS +C CORRESPONDS TO THE NUMBER OF REPLICATIONS OF THE +C MNEMONIC IN STR +C STR - CHARACTER*(*): STRING CONTAINING A SINGLE TABLE A OR +C TABLE D SEQUENCE MNEMONIC WHOSE SEQUENCE OF TABLE B +C MNEMONICS ARE IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE +C "GENERIC" MNEMONICS NOT RELATED TO TABLE A OR D, +C THESE RETURN THE FOLLOWING INFORMATION IN +C CORRESPONDING USR LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT INVTAG INVWIN +C PARSTR STATUS +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + PARAMETER (MTAG=10) + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*10 TAG,TAGS(MTAG) + CHARACTER*3 TYP + REAL*8 USR(I1,I2),VAL + + DATA IFIRST1/0/,IFIRST2/0/ + + SAVE IFIRST1, IFIRST2 + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + LUNIT = ABS(LUNIN) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IM.EQ.0) GOTO 901 + + IO = MIN(MAX(0,IL),1) + IF(LUNIT.NE.LUNIN) IO = 0 + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.EQ.-1) IFIRST1 = 1 + IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST1 = 1 + ENDIF + GOTO 100 + ENDIF + +C CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS +C ------------------------------------------------------ + + CALL PARSTR(STR,TAGS,MTAG,NTAG,' ',.TRUE.) + IF(NTAG.LT.1) GOTO 902 + IF(NTAG.GT.1) GOTO 903 + IF(I1.LE.0) GOTO 904 + IF(I2.LE.0) GOTO 905 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 906 + + +C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION +C -------------------------------------------------- + + IF(IO.EQ.0) THEN + DO J=1,I2 + DO I=1,I1 + USR(I,J) = BMISS + ENDDO + ENDDO + ENDIF + +C FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE +C --------------------------------------------- + + DO NODE=INODE(LUN),ISC(INODE(LUN)) + IF(STR.EQ.TAG(NODE)) THEN + IF(TYP(NODE).EQ.'SEQ'.OR.TYP(NODE).EQ.'RPC') THEN + INS1 = INVTAG(NODE,LUN, 1,NVAL(LUN)) + INS2 = INVTAG(NODE,LUN,INS1+1,NVAL(LUN)) + IF(INS1.EQ.0) GOTO 200 + IF(INS2.EQ.0) INS2 = 10E5 + NODS = NODE + DO WHILE(LINK(NODS).EQ.0.AND.JMPB(NODS).GT.0) + NODS = JMPB(NODS) + ENDDO + IF(LINK(NODS).EQ.0) THEN + INSX = NVAL(LUN) + ELSEIF(LINK(NODS).GT.0) THEN + INSX = INVWIN(LINK(NODS),LUN,INS1+1,NVAL(LUN))-1 + ENDIF + INS2 = MIN(INS2,INSX) + ELSEIF(TYP(NODE).EQ.'SUB') THEN + INS1 = 1 + INS2 = NVAL(LUN) + ELSE + GOTO 907 + ENDIF + NSEQ = 0 + DO ISQ=INS1,INS2 + ITYP = ITP(INV(ISQ,LUN)) + IF(ITYP.GT.1) NSEQ = NSEQ+1 + ENDDO + IF(NSEQ.GT.I1) GOTO 908 + GOTO 1 + ENDIF + ENDDO + + GOTO 200 + +C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME +C ---------------------------------------------------- + +1 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN)) +c .... previous SP version of BUFR ARCHIVE LIBRARY has line below +c (note ".gt.") + IF(INS1.GT.NVAL(LUN)) GOTO 200 + IF(INS1.GT.0) THEN +c .... previous decoder version of BUFR ARCHIVE LIBRARY has line below +c (note ".ge.") +ccccc IF(INS1.GE.NVAL(LUN)) GOTO 200 + IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN + INS1 = INS1+1 + GOTO 1 + ELSEIF(IO.EQ.0.AND.IRET+1.GT.I2) THEN + GOTO 909 + ENDIF + ELSEIF(INS1.EQ.0) THEN + IF(IO.EQ.1.AND.IRET.LT.I2) GOTO 910 + ELSE + GOTO 911 + ENDIF + + IF(INS1.EQ. 0) GOTO 200 + IF(IRET.EQ.I2) GOTO 200 + + IRET = IRET+1 + INS1 = INS1+1 + +C READ/WRITE USER VALUES +C ---------------------- + + J = INS1 + DO I=1,NSEQ + DO WHILE(ITP(INV(J,LUN)).LT.2) + J = J+1 + ENDDO + IF(IO.EQ.0) USR(I,IRET) = VAL(J,LUN ) + IF(IO.EQ.1) VAL(J,LUN ) = USR(I,IRET) + J = J+1 + ENDDO + +C CHECK FOR NEXT FRAME +C -------------------- + + GOTO 1 + +200 CONTINUE + + IF(IRET.EQ.0) THEN + IF(IO.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ELSE + IF(IPRT.EQ.-1) IFIRST2 = 1 + IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') + IF(IPRT.EQ.0) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST2 = 1 + ENDIF + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') +901 CALL BORT('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '// + . 'FILE, NONE ARE') +902 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '// + . 'DOES NOT CONTAIN ANY MNEMONICS!!")') STR + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// + . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'// + . ',")")') STR,NTAG + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'// + . ' BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)') + . I1,TAGS(1) + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '// + . 'MUST BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)') + . I2,TAGS(1) + CALL BORT(BORT_STR) +906 CALL BORT('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// + . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// + . 'SUBSET ARRAY') +907 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// + . 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') TAGS(1),TYP(NODE) + CALL BORT(BORT_STR) +908 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'// + . '" CONSISTS OF",I4," TABLE B MNEM., .GT. THE MAX. SPECIFIED IN'// + . ' (INPUT) ARGUMENT 3 (",I3,")")') TAGS(1),NSEQ,I1 + CALL BORT(BORT_STR) +909 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' READ > '// + . 'LIMIT OF",I4," IN THE 4-TH ARG. (INPUT) - INCOMPLETE READ '// + . '(INPUT MNEMONIC IS ",A,")")') I2,TAGS(1) + CALL BORT(BORT_STR) +910 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '// + . '(",I3,") .LT. NO. REQUESTED (",I3,") - INCOMPLETE WRITE '// + . '(INPUT MNEMONIC IS ",A,")")') IRET,I2,TAGS(1) + CALL BORT(BORT_STR) +911 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE .GE. '// + . 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') INS1,TAGS(1) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbsp.f b/src/bufr/ufbsp.f new file mode 100644 index 0000000000..68e89cf630 --- /dev/null +++ b/src/bufr/ufbsp.f @@ -0,0 +1,141 @@ + SUBROUTINE UFBSP(LUN,USR,I1,I2,IO,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBSP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR +C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO +C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR +C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). +C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED +C STRINGS OF MNEMONICS WHICH ARE EITHER: +C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE +C OR +C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN +C OVERALL SUBSET DEFINITION +C SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE UFBRP, BUT THERE IS AN IMPORTANT DIFFERENCE (SEE BELOW). +C +C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; +C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE +C LIBRARY SUBROUTINE UFBSTP. +C +C SEE THE DOCBLOCK FOR BUFR ARCHIVE LIBRARY SUBROUTINE UFBREP FOR AN +C EXPLANATION OF HOW UFBSTP DIFFERS FROM UFBREP, AND THEREFORE HOW +C UFBSP DIFFERS FROM UFBRP. +C +C PROGRAM HISTORY LOG: +C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION +C +C USAGE: CALL UFBSP (LUN, USR, I1, I2, IO, IRET) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR +C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED +C WITH LUN: +C 0 = input file +C 1 = output file +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C +C REMARKS: +C THIS ROUTINE CALLS: INVTAG +C THIS ROUTINE IS CALLED BY: UFBSTP +C Normally not called by any application +C programs (they should call UFBSTP). +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + + REAL*8 USR(I1,I2),VAL + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + INS1 = 0 + INS2 = 0 + +C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME +C ---------------------------------------------------- + +1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100 + INS1 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN)) + IF(INS1.EQ.0) GOTO 100 + + INS2 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN)) + IF(INS2.EQ.0) INS2 = NVAL(LUN) + IRET = IRET+1 + +C READ USER VALUES +C ---------------- + + IF(IO.EQ.0 .AND. IRET.LE.I2) THEN + INVM = INS1 + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INVN = INVTAG(NODS(I),LUN,INVM,INS2) + IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) + INVM = MAX(INVN,INVM) + ENDIF + ENDDO + ENDIF + +C WRITE USER VALUES +C ----------------- + + IF(IO.EQ.1 .AND. IRET.LE.I2) THEN + INVM = INS1 + DO I=1,NNOD + IF(NODS(I).GT.0) THEN + INVN = INVTAG(NODS(I),LUN,INVM,INS2) + IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET) + INVM = MAX(INVN,INVM) + ENDIF + ENDDO + ENDIF + +C GO FOR NEXT FRAME +C ----------------- + + GOTO 1 + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/ufbstp.f b/src/bufr/ufbstp.f new file mode 100644 index 0000000000..cb3fb33150 --- /dev/null +++ b/src/bufr/ufbstp.f @@ -0,0 +1,244 @@ + SUBROUTINE UFBSTP(LUNIO,USR,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBSTP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 +C +C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM +C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE +C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF +C ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN +C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; +C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). +C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED +C STRINGS OF MNEMONICS WHICH ARE EITHER: +C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE +C OR +C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN +C OVERALL SUBSET DEFINITION +C SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE UFBREP. HOWEVER, THERE IS AN IMPORTANT DIFFERENCE IN +C HOW UFBSTP PROCESSES THE INPUT MNEMONIC STRING STR; FOR MORE DETAILS +C SEE THE EXAMPLE IN THE DOCBLOCK FOR SUBROUTINE UFBREP. +C +C PROGRAM HISTORY LOG: +C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE); OUTPUTS MORE +C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN; CHANGED CALL FROM BORT TO BORT2 IN +C SOME CASES +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL UFBSTP (LUNIO, USR, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIO - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT +C NUMBER FOR BUFR FILE +C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS +C THAN ZERO, UFBSTP TREATS THE BUFR FILE AS THOUGH +C IT WERE OPEN FOR INPUT +C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C WRITTEN TO DATA SUBSET +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE AT LEAST AS LARGE AS LATTER) +C I2 - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS +C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF USR +C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE +C "GENERIC" MNEMONICS NOT RELATED TO TABLE B, +C THESE RETURN THE FOLLOWING INFORMATION IN +C CORRESPONDING USR LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET +C NUMBER OF THIS SUBSET WITHIN THE BUFR +C MESSAGE (RECORD) NUMBER 'IREC' +C +C OUTPUT ARGUMENT LIST: +C USR - ONLY IF BUFR FILE OPEN FOR INPUT: +C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES +C READ FROM DATA SUBSET +C IRET - INTEGER: +C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF +C DATA VALUES READ FROM DATA SUBSET (MUST BE NO +C LARGER THAN I2) +C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" +C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE +C SAME AS I2) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS +C STRING UFBSP +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR + REAL*8 USR(I1,I2),VAL + + DATA IFIRST1/0/,IFIRST2/0/ + + SAVE IFIRST1, IFIRST2 + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + IRET = 0 + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + LUNIT = ABS(LUNIO) + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IM.EQ.0) GOTO 901 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 + + IO = MIN(MAX(0,IL),1) + IF(LUNIO.NE.LUNIT) IO = 0 + + IF(I1.LE.0) THEN + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ELSEIF(I2.LE.0) THEN + IF(IPRT.EQ.-1) IFIRST1 = 1 + IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST1 = 1 + ENDIF + GOTO 100 + ENDIF + +C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION +C -------------------------------------------------- + + IF(IO.EQ.0) THEN + DO J=1,I2 + DO I=1,I1 + USR(I,J) = BMISS + ENDDO + ENDDO + ENDIF + +C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES +C ---------------------------------------------------- + + CALL STRING(STR,LUN,I1,IO) + +C CALL THE MNEMONIC READER/WRITER +C ------------------------------- + + CALL UFBSP(LUN,USR,I1,I2,IO,IRET) + + IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 903 + + IF(IRET.EQ.0) THEN + IF(IO.EQ.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + ELSE + IF(IPRT.EQ.-1) IFIRST2 = 1 + IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES WRITTEN OUT, ' // + . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(STR) + CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') + IF(IPRT.EQ.0) THEN + ERRSTR = 'Note: Only the first occurrence of this WARNING ' // + . 'message is printed, there may be more. To output all ' // + . 'such messages,' + CALL ERRWRT(ERRSTR) + ERRSTR = 'modify your application program to add ' // + . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // + . 'to a BUFRLIB routine.' + CALL ERRWRT(ERRSTR) + ENDIF + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + IFIRST2 = 1 + ENDIF + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE'// + . ' OPEN') +901 CALL BORT('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR '// + . 'FILE, NONE ARE') +902 CALL BORT('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR '// + . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// + . 'SUBSET ARRAY') +903 WRITE(BORT_STR1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS'// + . ': ",A)') STR + WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// + . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// + . ' - INCOMPLETE WRITE")') IRET,I2 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/ufbtab.f b/src/bufr/ufbtab.f new file mode 100644 index 0000000000..3076bd76b3 --- /dev/null +++ b/src/bufr/ufbtab.f @@ -0,0 +1,564 @@ + SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBTAB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO +C ABS(LUNIN) FOR INPUT OPERATIONS (IF IT IS NOT ALREADY OPENED AS +C SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST DATA +C MESSAGE (IF BUFR FILE ALREADY OPENED), THE EXTENT OF ITS PROCESSING +C IS DETERMINED BY THE SIGN OF LUNIN. IF LUNIN IS GREATER THAN ZERO, +C THIS SUBROUTINE READS SPECIFIED VALUES FROM ALL DATA SUBSETS IN THE +C BUFR FILE INTO INTERNAL ARRAYS AND RETURNS THESE VALUES ALONG WITH +C A COUNT OF THE SUBSETS. IF LUNIN IS LESS THAN ZERO, THIS +C SUBROUTINE RETURNS THE BUFR ARCHIVE LIBRARY'S GLOBAL VALUE FOR +C MISSING (REGARDLESS OF THE MNEMONICS SPECIFIED IN STR) +C ALONG WITH A COUNT OF THE SUBSETS (SEE REMARKS 2). FINALLY, THIS +C SUBROUTINE EITHER CLOSES THE BUFR FILE IN ABS(LUNIN) (IF IT WAS +C OPENED HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND +C POSITION (IF IT WAS NOT OPENED HERE). WHEN LUNIN IS GREATER THAN +C ZERO, THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE +C IS NO REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT +C THIS SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC +C IN EACH SUBSET). UFBTAB PROVIDES A MECHANISM WHEREBY A USER CAN +C EITHER DO A QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE +C OR MORE MNEMNONICS AMONGST ALL DATA SUBSETS FOR AN ENTIRE BUFR FILE +C (WHEN LUNIN IS GREATER THAN ZERO), OR SIMPLY OBTAIN A COUNT OF +C SUBSETS IN THE BUFR FILE (WHEN LUNIN IS LESS THAN ZERO); NO OTHER +C BUFR ARCHIVE LIBRARY ROUTINES HAVE TO BE CALLED. THIS SUBROUTINE +C IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UFBTAM EXCEPT UFBTAM +C READS SUBSETS FROM MESSAGES STORED IN INTERNAL MEMORY AND IT HAS NO +C OPTION FOR RETURNING ONLY A COUNT OF THE SUBSETS. IN ADDITION, +C UFBTAM CURRENTLY CANNOT READ DATA FROM COMPRESSED BUFR MESSAGES. +C UFBTAB CAN READ DATA FROM BOTH UNCOMPRESSED AND COMPRESSED BUFR +C MESSAGES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THERE ARE TOO +C MANY SUBSETS COMING IN (I.E., .GT. "I2"), +C BUT RATHER JUST PROCESS "I2" REPORTS AND +C PRINT A DIAGNOSTIC; MAXJL (MAXIMUM NUMBER +C OF JUMP/LINK ENTRIES) INCREASED FROM 15000 +C TO 16000 (WAS IN VERIFICATION VERSION); +C MODIFIED TO CALL ROUTINE REWNBF WHEN THE +C BUFR FILE IS ALREADY OPENED, ALLOWS +C SPECIFIC SUBSET INFORMATION TO BE READ FROM +C A FILE IN THE MIDST OF ITS BEING READ FROM +C OR WRITTEN TO), BEFORE OPENBF WAS ALWAYS +C CALLED AND THIS WOULD HAVE LED TO AN ABORT +C OF THE APPLICATION PROGRAM (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-09-16 J. WOOLLEN -- WORKS FOR COMPRESSED BUFR MESSAGES; ADDED +C OPTION TO RETURN ONLY SUBSET COUNT (WHEN +C INPUT UNIT NUMBER IS LESS THAN ZERO) +C 2006-04-14 J. ATOR -- ADD DECLARATION FOR CREF +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C 2009-04-21 J. ATOR -- USE ERRWRT +C 2009-12-01 J. ATOR -- FIX BUG FOR COMPRESSED CHARACTER STRINGS +C WHICH ARE IDENTICAL ACROSS ALL SUBSETS IN +C A SINGLE MESSAGE +C 2010-05-07 J. ATOR -- WHEN CALLING IREADMG, TREAT READ ERROR AS +C END-OF-FILE CONDITION +C 2012-03-02 J. ATOR -- USE FUNCTION UPS +C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; +C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE +C THE C FILE WITHOUT CLOSING THE FORTRAN FILE +C +C USAGE: CALL UFBTAB (LUNIN, TAB, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE +C I1 - INTEGER: +C - IF LUNIN IS GREATER THAN ZERO: LENGTH OF FIRST +C DIMENSION OF TAB OR THE NUMBER OF BLANK-SEPARATED +C MNEMONICS IN STR, (FORMER MUST BE AT LEAST AS +C LARGE AS LATTER) +C - IF LUNIN IS LESS THAN ZERO: LENGTH OF FIRST +C DIMENSION OF TAB (RECOMMEND PASSING IN WITH VALUE +C OF 1 - SEE REMARKS 2) +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB +C - IF LUNIN IS GREATER THAN ZERO: MUST BE AT LEAST AS +C LARGE AS VALUE RETURNED IN IRET, OTHERWISE ONLY +C FIRST I2 SUBSETS ARE RETURNED IN TAB +C - IF LUNIN IS LESS THAN ZERO: RECOMMEND PASSING IN +C WITH VALUE OF 1 - SEE REMARKS 2 +C STR - CHARACTER*(*): +C - IF LUNIN IS GREATER THAN ZERO: STRING OF BLANK- +C SEPARATED TABLE B MNEMONICS IN ONE-TO-ONE +C CORRESPONDENCE WITH FIRST DIMENSION OF TAB, I1 +C (THE NUMBER OF MNEMONICS IN THE STRING MUST BE NO +C LARGER THAN I1) +C - THERE ARE THREE "GENERIC" MNEMONICS NOT +C RELATED TO TABLE B, THESE RETURN THE FOLLOWING +C INFORMATION IN CORRESPONDING TAB LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR +C MESSAGE (RECORD) NUMBER IN WHICH THIS +C SUBSET RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT +C SUBSET NUMBER OF THIS SUBSET WITHIN +C THE BUFR MESSAGE (RECORD) NUMBER +C 'IREC' +C - IF LUNIN IS LESS THAN ZERO: DUMMY {RECOMMEND +C PASSING IN STRING AS A 1-CHARACTER BLANK (i.e., +C ' ') - SEE REMARKS 2} +C +C OUTPUT ARGUMENT LIST: +C TAB - REAL*8: (I1,I2): +C - IF LUNIN IS GREATER THAN ZERO: STARTING ADDRESS OF +C DATA VALUES READ FROM BUFR FILE +C - IF LUNIN IS LESS THAN ZERO: STARTING ADDRESS OF +C ARRAY OF VALUES ALL RETURNED WITH THE BUFRLIB'S +C GLOBAL VALUE FOR MISSING (BMISS) +C IRET - INTEGER: NUMBER OF DATA SUBSETS IN BUFR FILE +C - IF LUNIN IS GREATER THAN ZERO: MUST BE NO LARGER +C THAN I2, OTHERWISE ONLY FIRST I2 SUBSETS ARE +C RETURNED IN TAB +C +C REMARKS: +C 1) NOTE THAT UFBMEM CAN BE CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C 2) BELOW ARE TWO EXAMPLES WHERE THE USER CALLS UFBTAB WITH LUNIN +C LESS THAN ZERO SO AS TO ONLY OBTAIN A COUNT OF SUBSETS IN A +C BUFR FILE (ALONG WITH THE BUFRLIB'S GLOBAL VALUE FOR +C "MISSING"). +C +C EXAMPLE 1) I1 AND I2 ARE SET TO 1 SUCH THAT TAB IS A SCALAR AND +C STR IS SET TO A 1-CHARACTER BLANK. THESE ARE THE +C RECOMMENDED VALUES FOR I1, I2 AND STR SINCE THEY USE THE +C LEAST AMOUNT OF MEMORY): +C +C REAL(8) TAB +C .... +C .... +C CALL UFBTAB(-LUNIN,TAB,1,1,IRET,' ') +C .... +C .... +C +C HERE IRET WILL RETURN THE COUNT OF SUBSETS IN THE BUFR FILE +C AND TAB WILL RETURN THE BUFRLIB'S GLOBAL VALUE FOR "MISSING" +C (BMISS). +C +C EXAMPLE 2) I1 IS SET TO 4 AND I2 IS SET TO 8 SUCH THAT TAB IS A +C 32-WORD ARRAY, AND STR IS SET TO A NONSENSICAL STRING. +C THESE VALUES FOR I1, I2 AND STR WASTE MEMORY BUT GIVE THE +C SAME ANSWERS FOR TAB AND IRET AS IN EXAMPLE 1 (FOR THE SAME +C INPUT BUFR FILE!): +C +C REAL(8) TAB(4,8) +C .... +C .... +C CALL UFBTAB(-LUNIN,TAB,4,8,IRET,'BUFR IS A WONDERFUL FMT') +C .... +C .... +C +C HERE IRET WILL AGAIN RETURN THE COUNT OF SUBSETS IN THE BUFR +C FILE AND ALL 32 VALUES OF ARRAY TAB WILL RETURN THE +C BUFRLIB'S GLOBAL VALUE FOR "MISSING" (BMISS). +C +C THE SIXTH ARGUMENT STR IS A DUMMY VALUE AND CAN BE SET TO +C ANY CHARACTER STRING (AGAIN, A 1-CHARACTER BLANK ' ' IS +C RECOMMENDED). THE THIRD ARGUMENT I1 HAS NO RELATIONSHIP WITH +C THE NUMBER OF BLANK-SEPARATED MNEMONICS IN STR AND CAN BE SET +C TO ANY INTEGER VALUE (AGAIN, 1 IS RECOMMENDED). THE FOURTH +C ARGUMENT I2 HAS NO RELATIONSHIP WITH THE NUMBER OF DATA SUBSETS +C IN THE BUFR FILE RETURNED IN IRET (AGAIN, 1 IS RECOMMENDED). +C +C..................................................................... +C +C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IREADMG +C IREADSB MESGBC NMSUB OPENBF +C PARSTR REWNBF STATUS STRING +C UPB UPBB UPC UPS +C USRTPL +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /ACMODE/ IAC + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*40 CREF + CHARACTER*10 TAG,TGS(100) + CHARACTER*8 SUBSET,CVAL + CHARACTER*3 TYP + EQUIVALENCE (CVAL,RVAL) + LOGICAL OPENIT,JUST_COUNT + REAL*8 VAL,TAB(I1,I2),RVAL,UPS + + DATA MAXTG /100/ + +C----------------------------------------------------------------------- + MPS(NODE) = 2**(IBT(NODE))-1 + LPS(LBIT) = MAX(2**(LBIT)-1,1) +C----------------------------------------------------------------------- + +C SET COUNTERS TO ZERO +C -------------------- + + IRET = 0 + IREC = 0 + ISUB = 0 + IACC = IAC + +C CHECK FOR COUNT SUBSET ONLY OPTION (RETURNING THE BUFRLIB'S GLOBAL +C VALUE FOR MISSING IN OUTPUT ARRAY) INDICATED BY NEGATIVE UNIT +C ------------------------------------------------------------------ + + LUNIT = ABS(LUNIN) + JUST_COUNT = LUNIN.LT.LUNIT + + CALL STATUS(LUNIT,LUN,IL,IM) + OPENIT = IL.EQ.0 + + IF(OPENIT) THEN + +C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN +C ---------------------------------------------------------------- + + CALL OPENBF(LUNIT,'INX',LUNIT) + ELSE + +C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG +C --------------------------------------------------------------------- + + CALL REWNBF(LUNIT,0) + ENDIF + + IAC = 1 + +C SET THE OUTPUT ARRAY VALUES TO THE BUFRLIB'S GLOBAL VALUE FOR +C MISSING (BMISS) +C ------------------------------------------------------------- + + DO J=1,I2 + DO I=1,I1 + TAB(I,J) = BMISS + ENDDO + ENDDO + + IF(JUST_COUNT) THEN + +C COME HERE FOR COUNT ONLY OPTION (OUTPUT ARRAY VALUES REMAIN MISSING) +C -------------------------------------------------------------------- + + DO WHILE(IREADMG(-LUNIT,SUBSET,IDATE).GE.0) + IRET = IRET+NMSUB(LUNIT) + ENDDO + GOTO 25 + ENDIF + +C OTHERWISE, CHECK FOR SPECIAL TAGS IN STRING +C ------------------------------------------- + + CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) + DO I=1,NTG + IF(TGS(I).EQ.'IREC') IREC = I + IF(TGS(I).EQ.'ISUB') ISUB = I + ENDDO + +C READ A MESSAGE AND PARSE A STRING +C --------------------------------- + +10 IF(IREADMG(-LUNIT,SUBSET,JDATE).LT.0) GOTO 25 + CALL STRING(STR,LUN,I1,0) + IF(IREC.GT.0) NODS(IREC) = 0 + IF(ISUB.GT.0) NODS(ISUB) = 0 + +C PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT +C -------------------------------------------------------- + + CALL MESGBC(-LUNIT,MTYP,ICMP) + IF(ICMP.EQ.0) THEN + GOTO 15 + ELSEIF(ICMP.EQ.1) then + GOTO 115 + ELSE + GOTO 900 + ENDIF + +C --------------------------------------------- +C THIS BRANCH IS FOR UNCOMPRESSED MESSAGES +C --------------------------------------------- +C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE +C --------------------------------------------- + +15 IF(NSUB(LUN).EQ.MSUB(LUN)) GOTO 10 + IF(IRET+1.GT.I2) GOTO 99 + IRET = IRET+1 + + DO I=1,NNOD + NODS(I) = ABS(NODS(I)) + ENDDO + +C PARSE THE STRING NODES FROM A SUBSET +C ------------------------------------ + + MBIT = MBYT(LUN)*8 + 16 + NBIT = 0 + N = 1 + CALL USRTPL(LUN,N,N) +20 IF(N+1.LE.NVAL(LUN)) THEN + N = N+1 + NODE = INV(N,LUN) + MBIT = MBIT+NBIT + NBIT = IBT(NODE) + IF(ITP(NODE).EQ.1) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + CALL USRTPL(LUN,N,IVAL) + ENDIF + DO I=1,NNOD + IF(NODS(I).EQ.NODE) THEN + IF(ITP(NODE).EQ.1) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + TAB(I,IRET) = IVAL + ELSEIF(ITP(NODE).EQ.2) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE) + ELSEIF(ITP(NODE).EQ.3) THEN + CVAL = ' ' + KBIT = MBIT + CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT) + TAB(I,IRET) = RVAL + ENDIF + NODS(I) = -NODS(I) + GOTO 20 + ENDIF + ENDDO + DO I=1,NNOD + IF(NODS(I).GT.0) GOTO 20 + ENDDO + ENDIF + +C UPDATE THE SUBSET POINTERS BEFORE NEXT READ +C ------------------------------------------- + + IBIT = MBYT(LUN)*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + MBYT(LUN) = MBYT(LUN) + NBYT + NSUB(LUN) = NSUB(LUN) + 1 + IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN) + IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN) + GOTO 15 + +C --------------------------------------------- +C THIS BRANCH IS FOR COMPRESSED MESSAGES +C --------------------------------------------- +C STORE ANY MESSAGE AND/OR SUBSET COUNTERS +C --------------------------------------------- + +C CHECK ARRAY BOUNDS +C ------------------ + +115 IF(IRET+MSUB(LUN).GT.I2) GOTO 99 + +C STORE MESG/SUBS TOKENS +C ---------------------- + + IF(IREC.GT.0.OR.ISUB.GT.0) THEN + DO NSB=1,MSUB(LUN) + IF(IREC.GT.0) TAB(IREC,IRET+NSB) = NMSG(LUN) + IF(ISUB.GT.0) TAB(ISUB,IRET+NSB) = NSB + ENDDO + ENDIF + +C SETUP A NEW SUBSET TEMPLATE, PREPARE TO SUB-SURF +C ------------------------------------------------ + + CALL USRTPL(LUN,1,1) + IBIT = MBYT(LUN) + N = 0 + +C UNCOMPRESS CHOSEN NODES INTO THE TAB ARRAY (FIRST OCCURANCES ONLY) +C ------------------------------------------------------------------ + +C READ ELEMENTS LOOP +C ------------------ + +120 DO N=N+1,NVAL(LUN) + NODE = INV(N,LUN) + NBIT = IBT(NODE) + ITYP = ITP(NODE) + +C FIRST TIME IN RESET NODE INDEXES, OR CHECK FOR NODE(S) STILL NEEDED +C ------------------------------------------------------------------- + + IF(N.EQ.1) THEN + DO I=1,NNOD + NODS(I) = ABS(NODS(I)) + ENDDO + ELSE + DO I=1,NNOD + IF(NODS(I).GT.0) GOTO 125 + ENDDO + GOTO 135 + ENDIF + +C FIND THE EXTENT OF THE NEXT SUB-GROUP +C ------------------------------------- + +125 IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN + CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) + CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) + NIBIT = IBIT + LINC*MSUB(LUN) + ELSEIF(ITYP.EQ.3) THEN + CREF=' ' + CALL UPC(CREF,NBIT/8,MBAY(1,LUN),IBIT) + CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) + NIBIT = IBIT + 8*LINC*MSUB(LUN) + ELSE + GOTO 120 + ENDIF + +C LOOP OVER STRING NODES +C ---------------------- + + DO I=1,NNOD + +C CHOSEN NODES LOOP - KEEP TRACK OF NODES NEEDED AND NODES FOUND +C -------------------------------------------------------------- + + IF(NODE.NE.NODS(I)) GOTO 130 + NODS(I) = -NODS(I) + LRET = IRET + +C PROCESS A FOUND NODE INTO TAB +C ----------------------------- + + IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN + DO NSB=1,MSUB(LUN) + JBIT = IBIT + LINC*(NSB-1) + CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) + IVAL = LREF+NINC + LRET = LRET+1 + IF(NINC.LT.LPS(LINC)) TAB(I,LRET) = UPS(IVAL,NODE) + ENDDO + ELSEIF(ITYP.EQ.3) THEN + DO NSB=1,MSUB(LUN) + IF(LINC.EQ.0) THEN + CVAL = CREF + ELSE + JBIT = IBIT + LINC*(NSB-1)*8 + CVAL = ' ' + CALL UPC(CVAL,LINC,MBAY(1,LUN),JBIT) + ENDIF + LRET = LRET+1 + TAB(I,LRET) = RVAL + ENDDO + ELSE + CALL BORT('UFBTAB - INVALID ELEMENT TYPE SPECIFIED') + ENDIF + +C END OF LOOPS FOR COMPRESSED MESSAGE PARSING +C ------------------------------------------- + +130 CONTINUE + ENDDO + IF(ITYP.EQ.1) CALL USRTPL(LUN,N,IVAL) + IBIT = NIBIT + +C END OF READ ELEMENTS LOOP +C ------------------------- + + ENDDO +135 IRET = IRET+MSUB(LUN) + +C END OF MESSAGE PARSING - GO BACK FOR ANOTHER +C -------------------------------------------- + + GOTO 10 + +C ------------------------------------------- +C ERROR PROCESSING AND EXIT ROUTES BELOW +C ------------------------------------------- +C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW +C ------------------------------------------- + +99 NREP = IRET + DO WHILE(IREADSB(LUNIT).EQ.0) + NREP = NREP+1 + ENDDO + DO WHILE(IREADMG(-LUNIT,SUBSET,JDATE).GE.0) + NREP = NREP+NMSUB(LUNIT) + ENDDO + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' ) + . 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', + . 'IS .GT. LIMIT OF ', I2, ' IN THE 4TH ARG. (INPUT) - ', + . 'INCOMPLETE READ' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBTAB STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + +25 IF(OPENIT) THEN + +C CLOSE BUFR FILE IF IT WAS OPENED HERE +C ------------------------------------- + + CALL CLOSBF(LUNIT) + ELSE + +C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE +C --------------------------------------------------------------------- + + CALL REWNBF(LUNIT,1) + ENDIF + + IAC = IACC + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: UFBTAB - INVALID COMPRESSION '// + . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '// + . 'ROUTINE MESGBC")') ICMP + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufbtam.f b/src/bufr/ufbtam.f new file mode 100644 index 0000000000..d39198808b --- /dev/null +++ b/src/bufr/ufbtam.f @@ -0,0 +1,283 @@ + SUBROUTINE UFBTAM(TAB,I1,I2,IRET,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFBTAM +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES INTO INTERNAL ARRAYS +C FROM ALL DATA SUBSETS IN BUFR MESSAGES STORED IN INTERNAL MEMORY. +C THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE IS NO +C REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT THIS +C SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC IN +C EACH SUBSET). UFBTAM PROVIDES A MECHANISM WHEREBY A USER CAN DO A +C QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE OR MORE +C MNEMNONICS AMONGST ALL DATA SUBSETS FOR A GROUP OF BUFR MESSAGES +C STORED IN INTERNAL MEMORY, NO OTHER BUFR ARCHIVE LIBRARY ROUTINES +C HAVE TO BE CALLED. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE +C LIBRARY SUBROUTINE UFBTAB EXCEPT UFBTAB READS SUBSETS FROM MESSAGES +C IN A PHYSICAL BUFR FILE. UFBTAM CURRENTLY CANNOT READ DATA FROM +C COMPRESSED BUFR MESSAGES. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO +C 16 MBYTES; MODIFIED TO NOT ABORT WHEN THERE +C ARE TOO MANY SUBSETS COMING IN (I.E., .GT. +C I2), BUT RATHER JUST PROCESS I2 REPORTS AND +C PRINT A DIAGNOSTIC +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF +C BUFR MESSAGES WHICH CAN BE STORED +C INTERNALLY) INCREASED FROM 50000 TO 200000; +C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF +C BYTES REQUIRED TO STORE ALL MESSAGES +C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO +C 50 MBYTES +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C 2009-04-21 J. ATOR -- USE ERRWRT +C 2009-10-21 D. KEYSER -- ADDED OPTION TO INPUT NEW MNEMONIC "ITBL" +C IN ARGUMENT STR, RETURNS THE BUFR +C DICTIONARY TABLE NUMBER ASSOCIATED WITH +C EACH SUBSET IN INTERNAL MEMORY +C 2012-03-02 J. ATOR -- USE FUNCTION UPS +C +C USAGE: CALL UFBTAM (TAB, I1, I2, IRET, STR) +C INPUT ARGUMENT LIST: +C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF TAB OR THE +C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER +C MUST BE .GE. LATTER) +C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB +C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B +C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST +C DIMENSION OF TAB +C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED +C TO TABLE B, THESE RETURN THE FOLLOWING +C INFORMATION IN CORRESPONDING TAB LOCATION: +C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") +C 'IREC' WHICH ALWAYS RETURNS THE BUFR MESSAGE +C (RECORD) NUMBER IN WHICH EACH SUBSET IN +C INTERNAL MEMORY RESIDES +C 'ISUB' WHICH ALWAYS RETURNS THE LOCATION WITHIN +C MESSAGE "IREC" (I.E., THE SUBSET NUMBER) +C FOR EACH SUBSET IN INTERNAL MEMORY +C 'ITBL' WHICH ALWAYS RETURNS THE BUFR DICTIONARY +C TABLE NUMBER ASSOCIATED WITH EACH SUBSET +C IN INTERNAL MEMORY +C +C OUTPUT ARGUMENT LIST: +C TAB - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ +C FROM INTERNAL MEMORY +C IRET - INTEGER: NUMBER OF DATA SUBSETS IN INTERNAL MEMORY +C (MUST BE NO LARGER THAN I2) +C +C REMARKS: +C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR +C MESSAGES INTO INTERNAL MEMORY. +C +C THIS ROUTINE CALLS: BORT ERRWRT NMSUB PARSTR +C RDMEMM STATUS STRING UPB +C UPBB UPC UPS USRTPL +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), + . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, + . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),VALS(10),KONS(10) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /QUIET / IPRT + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*10 TAG,TGS(100) + CHARACTER*8 SUBSET,CVAL + CHARACTER*3 TYP + EQUIVALENCE (CVAL,RVAL) + REAL*8 TAB(I1,I2),VAL,RVAL,UPS + + DATA MAXTG /100/ + +C----------------------------------------------------------------------- + MPS(NODE) = 2**(IBT(NODE))-1 +C----------------------------------------------------------------------- + + IRET = 0 + + IF(MSGP(0).EQ.0) GOTO 100 + + DO J=1,I2 + DO I=1,I1 + TAB(I,J) = BMISS + ENDDO + ENDDO + +C CHECK FOR SPECIAL TAGS IN STRING +C -------------------------------- + + CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) + IREC = 0 + ISUB = 0 + ITBL = 0 + DO I=1,NTG + IF(TGS(I).EQ.'IREC') IREC = I + IF(TGS(I).EQ.'ISUB') ISUB = I + IF(TGS(I).EQ.'ITBL') ITBL = I + ENDDO + +C READ A MESSAGE AND PARSE A STRING +C --------------------------------- + + CALL STATUS(MUNIT,LUN,IL,IM) + + DO IMSG=1,MSGP(0) + CALL RDMEMM(IMSG,SUBSET,JDATE,MRET) + IF(MRET.LT.0) GOTO 900 + + CALL STRING(STR,LUN,I1,0) + IF(IREC.GT.0) NODS(IREC) = 0 + IF(ISUB.GT.0) NODS(ISUB) = 0 + IF(ITBL.GT.0) NODS(ITBL) = 0 + +C PROCESS ALL THE SUBSETS IN THE MEMORY MESSAGE +C --------------------------------------------- + + DO WHILE (NSUB(LUN).LT.MSUB(LUN)) + IF(IRET+1.GT.I2) GOTO 99 + IRET = IRET+1 + + DO I=1,NNOD + NODS(I) = ABS(NODS(I)) + ENDDO + + CALL USRTPL(LUN,1,1) + MBIT = MBYT(LUN)*8+16 + NBIT = 0 + N = 1 + +20 IF(N+1.LE.NVAL(LUN)) THEN + N = N+1 + NODE = INV(N,LUN) + MBIT = MBIT+NBIT + NBIT = IBT(NODE) + IF(ITP(NODE).EQ.1) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + CALL USRTPL(LUN,N,IVAL) + ENDIF + DO I=1,NNOD + IF(NODS(I).EQ.NODE) THEN + IF(ITP(NODE).EQ.1) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + TAB(I,IRET) = IVAL + ELSEIF(ITP(NODE).EQ.2) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE) + ELSEIF(ITP(NODE).EQ.3) THEN + CVAL = ' ' + KBIT = MBIT + CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT) + TAB(I,IRET) = RVAL + ENDIF + NODS(I) = -NODS(I) + GOTO 20 + ENDIF + ENDDO + DO I=1,NNOD + IF(NODS(I).GT.0) GOTO 20 + ENDDO + ENDIF + +C UPDATE THE SUBSET POINTERS BEFORE NEXT READ +C ------------------------------------------- + + IBIT = MBYT(LUN)*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + MBYT(LUN) = MBYT(LUN) + NBYT + NSUB(LUN) = NSUB(LUN) + 1 + IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN) + IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN) + IF(ITBL.GT.0) TAB(ITBL,IRET) = LDXTS + ENDDO + + ENDDO + + GOTO 200 + +C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW +C ------------------------------------------- + +99 CALL RDMEMM(0,SUBSET,JDATE,MRET) + NREP = 0 + DO IMSG=1,MSGP(0) + CALL RDMEMM(IMSG,SUBSET,JDATE,MRET) + IF(MRET.LT.0) GOTO 900 + NREP = NREP+NMSUB(MUNIT) + ENDDO + IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' ) + . 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ', + . 'IS .GT. LIMIT OF ', I2, ' IN THE 3RD ARG. (INPUT) - ', + . 'INCOMPLETE READ' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) + . '>>>UFBTAM STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C RESET THE MEMORY FILE +C --------------------- + +200 CALL RDMEMM(0,SUBSET,JDATE,MRET) + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING '// + . 'MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') IMSG + CALL BORT(BORT_STR) + END diff --git a/src/bufr/ufdump.f b/src/bufr/ufdump.f new file mode 100644 index 0000000000..7e4c537cbc --- /dev/null +++ b/src/bufr/ufdump.f @@ -0,0 +1,409 @@ + SUBROUTINE UFDUMP(LUNIT,LUPRT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UFDUMP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE +C CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE +C INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT. +C LUNIT MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR +C ARCHIVE LIBRARY SUBROUTINE OPENBF. THE DATA SUBSET MUST HAVE BEEN +C SUBSEQUENTLY READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY ARRAYS VIA +C A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR READERME, +C FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR VIA +C A SINGLE CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READNS!). FOR A +C PARTICULAR SUBSET, THE PRINT LISTING CONTAINS EACH MNEMONIC +C ACCOMPANIED BY ITS CORRESPONDING DATA VALUE (INCLUDING THE ACTUAL +C BITS THAT WERE SET FOR FLAG TABLE VALUES!) AS WELL AS OTHER USEFUL +C IDENTIFICATION INFORMATION. THIS SUBROUTINE IS SIMILAR TO BUFR +C ARCHIVE LIBRARY SUBROUTINE UFBDMP EXCEPT THAT IT DOES NOT PRINT +C POINTERS, COUNTERS AND OTHER MORE ESOTERIC INFORMATION DESCRIBING +C THE INTERNAL SUBSET STRUCTURES. EACH SUBROUTINE, UFBDMP AND UFDUMP, +C IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP +C IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. WOOLLEN -- MODIFIED TO HANDLE PRINT OF CHARACTER +C VALUES GREATER THAN EIGHT BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC +C INFO WHEN ROUTINE TERMINATES ABNORMALLY +C 2004-08-18 J. ATOR -- ADDED FUZZINESS TEST AND THRESHOLD FOR +C MISSING VALUE; ADDED INTERACTIVE AND +C SCROLLING CAPABILITY SIMILAR TO UFBDMP +C 2006-04-14 J. ATOR -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET +C ACTUAL BITS THAT WERE SET TO GENERATE VALUE +C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS +C 2009-03-23 J. ATOR -- ADD LEVEL MARKERS TO OUTPUT FOR SEQUENCES +C WHERE THE REPLICATION COUNT IS > 1; OUTPUT +C ALL OCCURRENCES OF LONG CHARACTER STRINGS +C 2012-02-24 J. ATOR -- FIX MISSING CHECK FOR LONG CHARACTER STRINGS +C 2012-03-02 J. ATOR -- LABEL REDEFINED REFERENCE VALUES +C +C USAGE: CALL UFDUMP (LUNIT, LUPRT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LUPRT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT +C FILE +C 0 = LUPRT is set to 06 +C +C OUTPUT FILES: +C IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT) +C IF LUPRT = 0: UNIT 06 - STANDARD OUTPUT PRINT +C +C REMARKS: +C THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS +C AT A TIME WHEN LUPRT IS INPUT AS "0". IN THIS CASE, THE EXECUTING +C SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND +C STANDARD OUTPUT. INITIALLY, THE FIRST TWENTY ELEMENTS OF THE +C CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL, +C FOLLOWED BY THE PROMPT "( for MORE, q to QUIT)". +C IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY +C "" (e.g., ""), THE NEXT TWENTY ELEMENTS WILL BE +C DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT. THIS CONTINUES +C UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL +C ENTERS "q" FOLLOWED BY "" AFTER THE PROMPT, IN WHICH CASE +C THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING +C PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE). +C +C THIS ROUTINE CALLS: BORT ICBFMS IBFMS ISIZE +C NEMTAB READLC RJUST STATUS +C STRSUC UPFTBV +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), + . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV + + + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + + CHARACTER*80 FMT + CHARACTER*64 DESC + CHARACTER*24 UNIT + CHARACTER*120 LCHR2 + CHARACTER*20 LCHR,PMISS + CHARACTER*15 NEMO3 + CHARACTER*10 TAG,NEMO,NEMO2 + CHARACTER*6 NUMB + CHARACTER*7 FMTF + CHARACTER*8 CVAL,TAGNRV + CHARACTER*3 TYP,TYPE + CHARACTER*1 TAB,YOU + EQUIVALENCE (RVAL,CVAL) + REAL*8 VAL,RVAL + LOGICAL TRACK,FOUND,RDRV + + PARAMETER (MXFV=31) + INTEGER IFV(MXFV) + + PARAMETER (MXSEQ=10) + INTEGER IDXREP(MXSEQ) + INTEGER NUMREP(MXSEQ) + CHARACTER*10 SEQNAM(MXSEQ) + + PARAMETER (MXLS=10) + CHARACTER*10 LSNEMO(MXLS) + INTEGER LSCT(MXLS) + + DATA PMISS /' MISSING'/ + DATA YOU /'Y'/ + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + NSEQ = 0 + NLS = 0 + + IF(LUPRT.EQ.0) THEN + LUOUT = 6 + ELSE + LUOUT = LUPRT + ENDIF + +C CHECK THE FILE STATUS AND I-NODE +C -------------------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.GT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 + + WRITE(LUOUT,*) + WRITE(LUOUT,*) 'MESSAGE TYPE ',TAG(INODE(LUN)) + WRITE(LUOUT,*) + +C DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT LUNIT +C --------------------------------------------------- + + DO NV=1,NVAL(LUN) + IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN + +C When LUPRT=0, the output will be scrolled, 20 elements at a time +C ---------------------------------------------------------------- + + PRINT*,'( for MORE, q to QUIT)' + READ(5,'(A1)') YOU + +C If the terminal enters "q" followed by "" after the prompt +C "( for MORE, q to QUIT)", scrolling will end and the +C subroutine will return to the calling program +C ------------------------------------------------------------------- + + IF(YOU.EQ.'q') THEN + PRINT* + PRINT*,'==> You have chosen to stop the dumping of this subset' + PRINT* + GOTO 100 + ENDIF + ENDIF + + NODE = INV (NV,LUN) + NEMO = TAG (NODE) + ITYP = ITP (NODE) + TYPE = TYP (NODE) + + IF(ITYP.GE.1.AND.ITYP.LE.3) THEN + CALL NEMTAB(LUN,NEMO,IDN,TAB,N) + NUMB = TABB(N,LUN)(1:6) + DESC = TABB(N,LUN)(16:70) + UNIT = TABB(N,LUN)(71:94) + RVAL = VAL(NV,LUN) + ENDIF + + IF((ITYP.EQ.0).OR.(ITYP.EQ.1)) THEN + +C Sequence descriptor or delayed descriptor replication factor + + IF((TYPE.EQ.'REP').OR.(TYPE.EQ.'DRP').OR.(TYPE.EQ.'DRB')) THEN + +C Print the number of replications + + NSEQ = NSEQ+1 + IF(NSEQ.GT.MXSEQ) GOTO 904 + IF(TYPE.EQ.'REP') THEN + NUMREP(NSEQ) = IRF(NODE) + ELSE + NUMREP(NSEQ) = NINT(RVAL) + ENDIF + CALL STRSUC(NEMO,NEMO2,LNM2) + FMT = '(11X,A,I6,1X,A)' + WRITE(LUOUT,FMT) NEMO2(1:LNM2), NUMREP(NSEQ), 'REPLICATIONS' + +C How many times is this sequence replicated? + + IF(NUMREP(NSEQ).GT.1) THEN + +C Track the sequence + + SEQNAM(NSEQ) = NEMO + IDXREP(NSEQ) = 1 + ELSE + +C Don't bother + + NSEQ = NSEQ-1 + ENDIF + ELSEIF( ((TYPE.EQ.'SEQ').OR.(TYPE.EQ.'RPC')) + . .AND. (NSEQ.GT.0) ) THEN + +C Is this one of the sequences being tracked? + + II = NSEQ + TRACK = .FALSE. + CALL STRSUC(NEMO,NEMO2,LNM2) + DO WHILE ((II.GE.1).AND.(.NOT.TRACK)) + IF(INDEX(SEQNAM(II),NEMO2(1:LNM2)).GT.0) THEN + TRACK = .TRUE. + +C Mark this level in the output + + FMT = '(4X,A,2X,A,2X,A,I6,2X,A)' + WRITE(LUOUT,FMT) '++++++', NEMO2(1:LNM2), + . 'REPLICATION #', IDXREP(II), '++++++' + IF(IDXREP(II).LT.NUMREP(II)) THEN + +C There are more levels to come + + IDXREP(II) = IDXREP(II)+1 + ELSE + +C This was the last level for this sequence, so stop +C tracking it + + NSEQ = NSEQ-1 + ENDIF + ELSE + II = II-1 + ENDIF + ENDDO + ENDIF + ELSEIF(ITYP.EQ.2) THEN + +C Other numeric value + +C First check if this node contains a redefined reference +C value. If so, modify the DESC field to label it as such. + + JJ = 1 + RDRV = .FALSE. + DO WHILE ((JJ.LE.NNRV).AND.(.NOT.RDRV)) + IF (NODE.EQ.INODNRV(JJ)) THEN + RDRV = .TRUE. + DESC = 'NEW REFERENCE VALUE FOR ' // NUMB + UNIT = ' ' + ELSE + JJ = JJ+1 + ENDIF + ENDDO + +C Now print the value + + IF(IBFMS(RVAL).NE.0) THEN + +C The value is "missing". + + FMT = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)' + WRITE(LUOUT,FMT) NUMB,NEMO,PMISS,UNIT,DESC + ELSE + FMT = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)' + +C Based upon the corresponding scale factor, select an +C appropriate format for the printing of this value. + + WRITE(FMT(19:20),'(I2)') MAX(1,ISC(NODE)) + IF(UNIT(1:4).EQ.'FLAG') THEN + +C Print a listing of the bits corresponding to +C this value. + + CALL UPFTBV(LUNIT,NEMO,RVAL,MXFV,IFV,NIFV) + IF(NIFV.GT.0) THEN + UNIT(11:11) = '(' + IPT = 12 + DO II=1,NIFV + ISZ = ISIZE(IFV(II)) + WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)' + IF((IPT+ISZ).LE.24) THEN + WRITE(UNIT(IPT:IPT+ISZ),FMTF) IFV(II), ',' + IPT = IPT + ISZ + 1 + ELSE + UNIT(12:23) = 'MANY BITS ON' + IPT = 25 + ENDIF + ENDDO + UNIT(IPT-1:IPT-1) = ')' + ENDIF + ENDIF + WRITE(LUOUT,FMT) NUMB,NEMO,RVAL,UNIT,DESC + ENDIF + ELSEIF(ITYP.EQ.3) THEN + +C Character (CCITT IA5) value + + NCHR = IBT(NODE)/8 + + IF(IBFMS(RVAL).NE.0) THEN + LCHR = PMISS + ELSE IF(NCHR.LE.8) THEN + LCHR = CVAL + ELSE + +C Track the number of occurrences of this long character string, so +C that we can properly output each one. + + II = 1 + FOUND = .FALSE. + DO WHILE((II.LE.NLS).AND.(.NOT.FOUND)) + IF(NEMO.EQ.LSNEMO(II)) THEN + FOUND = .TRUE. + ELSE + II = II + 1 + ENDIF + ENDDO + + IF(.NOT.FOUND) THEN + NLS = NLS+1 + IF(NLS.GT.MXLS) GOTO 905 + LSNEMO(NLS) = NEMO + LSCT(NLS) = 1 + NEMO3 = NEMO + ELSE + CALL STRSUC(NEMO,NEMO3,LNM3) + LSCT(II) = LSCT(II) + 1 + WRITE(FMTF,'(A,I1,A)') '(2A,I', ISIZE(LSCT(II)), ')' + WRITE(NEMO3,FMTF) NEMO(1:LNM3), '#', LSCT(II) + ENDIF + + CALL READLC(LUNIT,LCHR2,NEMO3) + IF (ICBFMS(LCHR2,NCHR).NE.0) THEN + LCHR = PMISS + ELSE + LCHR = LCHR2(1:20) + ENDIF + ENDIF + + IF ( NCHR.LE.20 .OR. LCHR.EQ.PMISS ) THEN + IRET = RJUST(LCHR) + FMT = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)' + WRITE(LUOUT,FMT) NUMB,NEMO,LCHR,NCHR,UNIT,DESC + ELSE + FMT = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)' + WRITE(LUOUT,FMT) NUMB,NEMO,LCHR2(1:NCHR),NCHR,UNIT,DESC + ENDIF + ENDIF + + ENDDO + + WRITE(LUOUT,3) +3 FORMAT(/' >>> END OF SUBSET <<< '/) + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '// + . 'OUTPUT, IT MUST BE OPEN FOR INPUT') +902 CALL BORT('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '// + . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// + . 'INTERNAL SUBSET ARRAY') +904 CALL BORT('BUFRLIB: UFDUMP - MXSEQ OVERFLOW') +905 CALL BORT('BUFRLIB: UFDUMP - MXLS OVERFLOW') + END diff --git a/src/bufr/upb.f b/src/bufr/upb.f new file mode 100644 index 0000000000..bf3a3467e3 --- /dev/null +++ b/src/bufr/upb.f @@ -0,0 +1,69 @@ + SUBROUTINE UPB(NVAL,NBITS,IBAY,IBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER +C CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1). +C ON OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS +C UNPACKED. THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPBB, +C EXCEPT IN UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF +C ARGUMENTS IS DIFFERENT). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-05-19 J. ATOR -- ADDED CHECK FOR NBITS EQUAL TO ZERO +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS +C IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2009-03-23 J. ATOR -- REWROTE TO CALL UPBB +C +C USAGE: CALL UPB (NVAL, NBITS, IBAY, IBIT) +C INPUT ARGUMENT LIST: +C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK +C NVAL +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED +C NVAL +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER +C WHICH TO START UNPACKING +C +C OUTPUT ARGUMENT LIST: +C NVAL - INTEGER: UNPACKED INTEGER +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT +C THAT WAS UNPACKED +C +C REMARKS: +C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE +C PKB. +C +C THIS ROUTINE CALLS: UPBB +C THIS ROUTINE IS CALLED BY: COPYSB IUPB MVB RDCMPS +C RDMGSB READSB STNDRD UFBINX +C UFBPOS UFBTAB UFBTAM UPC +C WRCMPS WRITLC +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION IBAY(*) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + CALL UPBB(NVAL,NBITS,IBIT,IBAY) + + IBIT = IBIT+NBITS + + RETURN + END diff --git a/src/bufr/upbb.f b/src/bufr/upbb.f new file mode 100644 index 0000000000..57dd460e1f --- /dev/null +++ b/src/bufr/upbb.f @@ -0,0 +1,82 @@ + SUBROUTINE UPBB(NVAL,NBITS,IBIT,IBAY) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPBB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER +C CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1). +C THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPB, EXCEPT IN +C UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF ARGUMENTS IS +C DIFFERENT). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- +C LINING CODE WITH FPP DIRECTIVES +C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS +C IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- ADDED CHECK FOR NBITS EQUAL TO ZERO; +C MODIFIED LOGIC TO MAKE IT CONSISTENT WITH +C LOGIC IN UPB; UNIFIED/PORTABLE FOR WRF; +C ADDED DOCUMENTATION (INCLUDING HISTORY) +C +C USAGE: CALL UPBB (NVAL, NBITS, IBIT, IBAY) +C INPUT ARGUMENT LIST: +C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK +C NVAL +C IBIT - INTEGER: BIT POINTER WITHIN IBAY TO START UNPACKING +C FROM +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED +C NVAL +C +C OUTPUT ARGUMENT LIST: +C NVAL - INTEGER: UNPACKED INTEGER +C +C REMARKS: +C THIS ROUTINE CALLS: IREV +C THIS ROUTINE IS CALLED BY: RCSTPL RDTREE UFBGET UFBTAB +C UFBTAM UPB WRITLC +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION IBAY(*) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C IF NBITS=0, THEN JUST SET NVAL=0 AND RETURN +C ------------------------------------------- + + IF(NBITS.EQ.0)THEN + NVAL=0 + GOTO 100 + ENDIF + + NWD = IBIT/NBITW + 1 + NBT = MOD(IBIT,NBITW) + INT = ISHFT(IREV(IBAY(NWD)),NBT) + INT = ISHFT(INT,NBITS-NBITW) + LBT = NBT+NBITS + IF(LBT.GT.NBITW) THEN + JNT = IREV(IBAY(NWD+1)) + INT = IOR(INT,ISHFT(JNT,LBT-2*NBITW)) + ENDIF + NVAL = INT + +C EXIT +C ---- + +100 RETURN + END diff --git a/src/bufr/upc.f b/src/bufr/upc.f new file mode 100644 index 0000000000..61d4ed9fdf --- /dev/null +++ b/src/bufr/upc.f @@ -0,0 +1,81 @@ + SUBROUTINE UPC(CHR,NCHR,IBAY,IBIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPC +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF +C LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF IBAY, STARTING WITH BIT +C (IBIT+1). ON OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT +C WAS UNPACKED. NOTE THAT THE STRING TO BE UNPACKED DOES NOT +C NECESSARILY NEED TO BE ALIGNED ON A BYTE BOUNDARY WITHIN IBAY. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION +C 2009-03-23 J. ATOR -- TREAT NULL CHARACTERS AS BLANKS; +C PREVENT OVERFLOW OF CHR +C +C USAGE: CALL UPC (CHR, NCHR, IBAY, IBIT) +C INPUT ARGUMENT LIST: +C NCHR - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO +C UNPACK CHR (I,E, THE NUMBER OF CHARACTERS IN CHR) +C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED +C CHR +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER +C WHICH TO START UNPACKING +C +C OUTPUT ARGUMENT LIST: +C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING OF LENGTH +C NCHR +C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT +C THAT WAS UNPACKED +C +C REMARKS: +C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE +C PKC. +C +C THIS ROUTINE CALLS: IPKM IUPM UPB +C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE READLC STNDRD +C UFBGET UFBTAB UFBTAM WRCMPS +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + CHARACTER*(*) CHR + CHARACTER*8 CVAL + DIMENSION IBAY(*),IVAL(2) + EQUIVALENCE (CVAL,IVAL) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + LB = IORD(NBYTW) + CVAL = ' ' + + NUMCHR = MIN(NCHR,LEN(CHR)) + DO I=1,NUMCHR + CALL UPB(IVAL(1),8,IBAY,IBIT) + IF(IVAL(1).EQ.0) THEN + CHR(I:I) = ' ' + ELSE + CHR(I:I) = CVAL(LB:LB) + ENDIF + IF(IASCII.EQ.0) CALL IPKM(CHR(I:I),1,IATOE(IUPM(CHR(I:I),8))) + ENDDO + + RETURN + END diff --git a/src/bufr/upds3.f b/src/bufr/upds3.f new file mode 100644 index 0000000000..12dfb268ad --- /dev/null +++ b/src/bufr/upds3.f @@ -0,0 +1,81 @@ + SUBROUTINE UPDS3(MBAY,LCDS3,CDS3,NDS3) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPDS3 +C PRGMMR: ATOR ORG: NP12 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE DESCRIPTORS +C CONTAINED WITHIN SECTION 3 OF A BUFR MESSAGE STORED IN ARRAY MBAY. +C THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE +C ALIGNED ON THE FIRST FOUR BYTES OF MBAY. NOTE ALSO THAT THIS +C SUBROUTINE DOES NOT RECURSIVELY RESOLVE SEQUENCE DESCRIPTORS THAT +C APPEAR WITHIN SECTION 3; RATHER, WHAT IS RETURNED IS THE EXACT LIST +C OF DESCRIPTORS AS IT APPEARS WITHIN SECTION 3. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. ATOR -- ORIGINAL AUTHOR (WAS IN DECODER VERSION) +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF +C 2004-08-18 J. ATOR -- REMOVED IFIRST CHECK, SINCE WRDLEN NOW +C KEEPS TRACK OF WHETHER IT HAS BEEN CALLED +C 2005-11-29 J. ATOR -- USE GETLENS +C 2009-03-23 J. ATOR -- ADDED LCDS3 ARGUMENT AND CHECK +C +C USAGE: CALL UPDS3 (MBAY, LCDS3, CDS3, NDS3) +C INPUT ARGUMENT LIST: +C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE +C LCDS3 - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF CDS3; +C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT +C OVERFLOW THE CDS3 ARRAY +C +C OUTPUT ARGUMENT LIST: +C CDS3 - CHARACTER*6: *-WORD ARRAY CONTAINING UNPACKED LIST OF +C DESCRIPTORS (FIRST NDS3 WORDS FILLED) +C NDS3 - INTEGER: NUMBER OF DESCRIPTORS RETURNED +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT IUPB GETLENS +C WRDLEN +C THIS ROUTINE IS CALLED BY: READS3 +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + DIMENSION MBAY(*) + + CHARACTER*6 CDS3(*), ADN30 + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C Call subroutine WRDLEN to initialize some important information +C about the local machine, just in case subroutine OPENBF hasn't +C been called yet. + + CALL WRDLEN + +C Skip to the beginning of Section 3. + + CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) + IPT = LEN0 + LEN1 + LEN2 + +C Unpack the Section 3 descriptors. + + NDS3 = 0 + DO JJ = 8,(LEN3-1),2 + NDS3 = NDS3 + 1 + IF(NDS3.GT.LCDS3) GOTO 900 + CDS3(NDS3) = ADN30(IUPB(MBAY,IPT+JJ,16),6) + ENDDO + + RETURN +900 CALL BORT('BUFRLIB: UPDS3 - OVERFLOW OF OUTPUT DESCRIPTOR '// + . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + END diff --git a/src/bufr/upftbv.f b/src/bufr/upftbv.f new file mode 100644 index 0000000000..c8ef21ca15 --- /dev/null +++ b/src/bufr/upftbv.f @@ -0,0 +1,100 @@ + SUBROUTINE UPFTBV(LUNIT,NEMO,VAL,MXIB,IBIT,NIB) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPFTBV +C PRGMMR: JATOR ORG: NP12 DATE: 2005-11-29 +C +C ABSTRACT: GIVEN A MNEMONIC OF TYPE "FLAG TABLE" ALONG WITH ITS +C CORRESPONDING VALUE, THIS SUBROUTINE DETERMINES THE BIT SETTINGS +C EQUIVALANT TO THAT VALUE. NOTE THAT THIS SUBROUTINE IS THE +C LOGICAL INVERSE OF BUFRLIB SUBROUTINE PKFTBV. +C +C PROGRAM HISTORY LOG: +C 2005-11-29 J. ATOR -- ORIGINAL VERSION +C +C USAGE: UPFTBV (LUNIT,NEMO,VAL,MXIB,IBIT,NIB) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C NEMO - CHARACTER*(*): MNEMONIC OF TYPE "FLAG TABLE" +C VAL - REAL*8: VALUE CORRESPONDING TO NEMO +C MXIB - INTEGER: DIMENSIONED SIZE OF IBIT IN CALLING PROGRAM +C +C OUTPUT ARGUMENT LIST: +C IBIT - INTEGER(*): BIT NUMBERS WHICH WERE SET TO "ON" +C (I.E. SET TO "1") IN VAL +C NIB - INTEGER: NUMBER OF BIT NUMBERS RETURNED IN IBIT +C +C REMARKS: +C THIS ROUTINE CALLS: BORT NEMTAB STATUS VALX +C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + + REAL*8 VAL,R8VAL,R82I + + INTEGER IBIT (*) + + CHARACTER*(*) NEMO + CHARACTER*600 TABD + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*128 BORT_STR + CHARACTER*1 TAB + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + +C Perform some sanity checks. + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + + CALL NEMTAB(LUN,NEMO,IDN,TAB,N) + IF(N.EQ.0) GOTO 901 + IF(TABB(N,LUN)(71:74).NE.'FLAG') GOTO 902 + +C Figure out which bits are set. + + NIB = 0 + R8VAL = VAL + NBITS = VALX(TABB(N,LUN)(110:112)) + DO I=(NBITS-1),0,-1 + R82I = (2.)**I + IF(ABS(R8VAL-R82I).LT.(0.005)) THEN + NIB = NIB + 1 + IF(NIB.GT.MXIB) GOTO 903 + IBIT(NIB) = NBITS-I + RETURN + ELSEIF(R82I.LT.R8VAL) THEN + NIB = NIB + 1 + IF(NIB.GT.MXIB) GOTO 903 + IBIT(NIB) = NBITS-I + R8VAL = R8VAL - R82I + ENDIF + ENDDO + + RETURN +900 CALL BORT('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR INPUT') +901 WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'// + . '" NOT FOUND IN TABLE B")') NEMO + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'// + . '" IS NOT A FLAG TABLE")') NEMO + CALL BORT(BORT_STR) +903 CALL BORT('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW') + END diff --git a/src/bufr/ups.f b/src/bufr/ups.f new file mode 100644 index 0000000000..3fe67475d5 --- /dev/null +++ b/src/bufr/ups.f @@ -0,0 +1,97 @@ + REAL*8 FUNCTION UPS(IVAL,NODE) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPS +C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-03-02 +C +C ABSTRACT: THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED +C BUFR INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES. +C NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX +C NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*); +C HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A +C 2-03 OPERATOR IS IN EFFECT FOR THIS NODE. +C +C PROGRAM HISTORY LOG: +C 2012-03-02 J. ATOR -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL +C STATEMENT FUNCTION IN OTHER SUBROUTINES +C +C USAGE: UPS (IVAL,NODE) +C INPUT ARGUMENT LIST: +C IVAL - INTEGER: PACKED BUFR INTEGER +C NODE - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES +C +C OUTPUT ARGUMENT LIST: +C UPS - REAL*8: USER VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: None +C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE UFBGET UFBTAB +C UFBTAM +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), + . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV + + CHARACTER*10 TAG + CHARACTER*8 TAGNRV + CHARACTER*3 TYP + + REAL*8 TEN + + DATA TEN /10./ + +C----------------------------------------------------------------------- + + UPS = ( IVAL + IRF(NODE) ) * TEN**(-ISC(NODE)) + + IF ( NNRV .GT. 0 ) THEN + +C There are redefined reference values in the jump/link table, +C so we need to check if this node is affected by any of them. + + DO JJ = 1, NNRV + IF ( NODE .EQ. INODNRV(JJ) ) THEN + +C This node contains a redefined reference value. +C Per the rules of BUFR, negative values may be encoded +C as positive integers with the left-most bit set to 1. + + IMASK = 2**(IBT(NODE)-1) + IF ( IAND(IVAL,IMASK) .GT. 0 ) THEN + NRV(JJ) = (-1) * ( IVAL - IMASK ) + ELSE + NRV(JJ) = IVAL + END IF + UPS = NRV(JJ) + RETURN + ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND. + . ( NODE .GE. ISNRV(JJ) ) .AND. + . ( NODE .LE. IENRV(JJ) ) ) THEN + +C The corresponding redefinded reference value needs to +C be used when decoding this value. + + UPS = ( IVAL + NRV(JJ) ) * TEN**(-ISC(NODE)) + RETURN + END IF + END DO + + END IF + + RETURN + END diff --git a/src/bufr/uptdd.f b/src/bufr/uptdd.f new file mode 100644 index 0000000000..178522f9f9 --- /dev/null +++ b/src/bufr/uptdd.f @@ -0,0 +1,115 @@ + SUBROUTINE UPTDD(ID,LUN,IENT,IRET) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: UPTDD +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE RETURNS THE BIT-WISE REPRESENTATION OF THE +C FXY VALUE CORRESPONDING TO, SEQUENTIALLY, A PARTICULAR (IENT'th) +C "CHILD" MNEMONIC OF A TABLE D SEQUENCE ("PARENT") MNEMONIC. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL UPTDD (ID, LUN, IENT, IRET) +C INPUT ARGUMENT LIST: +C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN +C INTERNAL BUFR TABLE D ARRAY TABD +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C IENT - INTEGER: ORDINAL INDICATOR OF CHILD MNEMONIC TO RETURN +C FROM WITHIN TABD(ID,LUN) SEQUENCE: +C 0 = return a count of the total number of child +C mnemonics within TABD(ID,LUN) +C +C OUTPUT ARGUMENT LIST: +C IRET - INTEGER: RETURN VALUE (SEE REMARKS) +C +C REMARKS: +C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE INPUT +C VALUE IENT, AS FOLLOWS: +C +C IF ( IENT = 0 ) THEN +C IRET = a count of the total number of child mnemonics within +C TABD(ID,LUN) +C ELSE +C IRET = the bit-wise representation of the FXY value +C corresponding to the IENT'th child mnemonic of +C TABD(ID,LUN) +C END IF +C +C +C THIS ROUTINE CALLS: BORT IUPM +C THIS ROUTINE IS CALLED BY: NEMTBD RESTD +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*56 DXSTR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + LDD = LDXD(IDXV+1)+1 + +C CHECK IF IENT IS IN BOUNDS +C -------------------------- + + NDSC = IUPM(TABD(ID,LUN)(LDD:LDD),8) + + IF(IENT.EQ.0) THEN + IRET = NDSC + GOTO 100 + ELSEIF(IENT.LT.0 .OR. IENT.GT.NDSC) THEN + GOTO 900 + ENDIF + +C RETURN THE DESCRIPTOR INDICATED BY IENT +C --------------------------------------- + + IDSC = LDD+1 + (IENT-1)*2 + IRET = IUPM(TABD(ID,LUN)(IDSC:IDSC),16) + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: UPTDD - VALUE OF THIRD ARGUMENT IENT'// + . ' (INPUT) IS OUT OF RANGE (IENT =",I4,")")') IENT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/usrtpl.f b/src/bufr/usrtpl.f new file mode 100644 index 0000000000..f807195517 --- /dev/null +++ b/src/bufr/usrtpl.f @@ -0,0 +1,250 @@ + SUBROUTINE USRTPL(LUN,INVN,NBMP) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: USRTPL +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL +C SUBSET ARRAYS IN COMMON BLOCK /USRINT/ FOR CASES OF NODE EXPANSION +C (I.E. WHEN THE NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED +C REPLICATION FACTOR). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY) (INCOMPLETE); OUTPUTS MORE +C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY OR UNUSUAL THINGS +C HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO +C "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED +C PROBLEMS ON SOME FOREIGN MACHINES) +C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: CALL USRTPL (LUN, INVN, NBMP) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C INVN - INTEGER: STARTING JUMP/LINK TABLE INDEX OF THE NODE +C TO BE EXPANDED WITHIN THE SUBSET TEMPLATE +C NBMP - INTEGER: NUMBER OF TIMES BY WHICH INVN IS TO BE +C EXPANDED (I.E. NUMBER OF REPLICATIONS OF NODE) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT ERRWRT +C THIS ROUTINE IS CALLED BY: DRFINI DRSTPL MSGUPD OPENMB +C OPENMG RDCMPS TRYBUMP UFBGET +C UFBTAB UFBTAM WRCMPS WRITLC +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /QUIET / IPRT + + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*10 TAG + CHARACTER*3 TYP + DIMENSION ITMP(MAXJL) + LOGICAL DRP,DRS,DRB,DRX + REAL*8 VAL,VTMP(MAXJL) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I5,A,I5,A,A10)' ) + . 'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ', + . LUN, ':', INVN, ':', NBMP, ':', TAG(INODE(LUN)) + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + IF(NBMP.LE.0) THEN + IF(IPRT.GE.1) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT('BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN') + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + GOTO 100 + ENDIF + + DRP = .FALSE. + DRS = .FALSE. + DRX = .FALSE. + +C SET UP A NODE EXPANSION +C ----------------------- + + IF(INVN.EQ.1) THEN +c .... case where node is a Table A mnemonic (nodi is positional index) + NODI = INODE(LUN) + INV(1,LUN) = NODI + NVAL(LUN) = 1 + IF(NBMP.NE.1) GOTO 900 + ELSEIF(INVN.GT.0 .AND. INVN.LE.NVAL(LUN)) THEN +c .... case where node is (hopefully) a delayed replication factor + NODI = INV(INVN,LUN) + DRP = TYP(NODI) .EQ. 'DRP' + DRS = TYP(NODI) .EQ. 'DRS' + DRB = TYP(NODI) .EQ. 'DRB' + DRX = DRP .OR. DRS .OR. DRB + IVAL = VAL(INVN,LUN) + JVAL = 2**IBT(NODI)-1 + VAL(INVN,LUN) = IVAL+NBMP + IF(DRB.AND.NBMP.NE.1) GOTO 901 + IF(.NOT.DRX ) GOTO 902 + IF(IVAL.LT.0. ) GOTO 903 + IF(IVAL+NBMP.GT.JVAL) GOTO 904 + ELSE + GOTO 905 + ENDIF + +C RECALL A PRE-FAB NODE EXPANSION SEGMENT +C --------------------------------------- + + NEWN = 0 + N1 = ISEQ(NODI,1) + N2 = ISEQ(NODI,2) + + IF(N1.EQ.0 ) GOTO 906 + IF(N2-N1+1.GT.MAXJL) GOTO 907 + + DO N=N1,N2 + NEWN = NEWN+1 + ITMP(NEWN) = JSEQ(N) + VTMP(NEWN) = VALI(JSEQ(N)) + ENDDO + +C MOVE OLD NODES - STORE NEW ONES +C ------------------------------- + + IF(NVAL(LUN)+NEWN*NBMP.GT.MAXSS) GOTO 908 + + DO J=NVAL(LUN),INVN+1,-1 + INV(J+NEWN*NBMP,LUN) = INV(J,LUN) + VAL(J+NEWN*NBMP,LUN) = VAL(J,LUN) + ENDDO + + IF(DRP.OR.DRS) VTMP(1) = NEWN + KNVN = INVN + + DO I=1,NBMP + DO J=1,NEWN + KNVN = KNVN+1 + INV(KNVN,LUN) = ITMP(J) + VAL(KNVN,LUN) = VTMP(J) + ENDDO + ENDDO + +C RESET POINTERS AND COUNTERS +C --------------------------- + + NVAL(LUN) = NVAL(LUN) + NEWN*NBMP + + IF(IPRT.GE.2) THEN + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + WRITE ( UNIT=ERRSTR, FMT='(A,A,A10,3(A,I5))' ) + . 'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:', + . 'NVAL(LUN) = ', TAG(INV(INVN,LUN)), ':', NEWN, ':', + . NBMP, ':', NVAL(LUN) + CALL ERRWRT(ERRSTR) + DO I=1,NEWN + WRITE ( UNIT=ERRSTR, FMT='(2(A,I5),A,A10)' ) + . 'For I = ', I, ', ITMP(I) = ', ITMP(I), + . ', TAG(ITMP(I)) = ', TAG(ITMP(I)) + CALL ERRWRT(ERRSTR) + ENDDO + CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + + IF(DRX) THEN + NODE = NODI + INVR = INVN +4 NODE = JMPB(NODE) + IF(NODE.GT.0) THEN + IF(ITP(NODE).EQ.0) THEN + DO INVR=INVR-1,1,-1 + IF(INV(INVR,LUN).EQ.NODE) THEN + VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP + GOTO 4 + ENDIF + ENDDO + GOTO 909 + ELSE + GOTO 4 + ENDIF + ENDIF + ENDIF + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// + . 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '// + . 'NODE) (",A,")")') NBMP,TAG(NODI) + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// + . 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'// + . ' (",A,")")') NBMP,TAG(NODI) + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '// + . 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")') + . TYP(NODI),TAG(NODI) + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '// + . 'NEGATIVE (=",I5,") (",A,")")') IVAL,TAG(NODI) + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'// + . ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') JVAL,TAG(NODI) + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '// + . 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'// + . ') (",A,")")') INVN,NVAL(LUN),TAG(NODI) + CALL BORT(BORT_STR) +906 WRITE(BORT_STR,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'// + . 'A,")")') TAG(NODI) + CALL BORT(BORT_STR) +907 WRITE(BORT_STR,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '// + . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI) + CALL BORT(BORT_STR) +908 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'// + . ', EXCEEDS THE LIMIT (",I6,") (",A,")")') + . NVAL(LUN)+NEWN*NBMP,MAXSS,TAG(NODI) + CALL BORT(BORT_STR) +909 WRITE(BORT_STR,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'// + . '")")') TAG(NODI) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/valx.f b/src/bufr/valx.f new file mode 100644 index 0000000000..1052d13d34 --- /dev/null +++ b/src/bufr/valx.f @@ -0,0 +1,87 @@ + FUNCTION VALX(STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: VALX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS FUNCTION DECODES A REAL NUMBER FROM A CHARACTER +C STRING. IF THE DECODE FAILS, THEN THE VALUE BMISS IS +C RETURNED. NOTE THAT, UNLIKE FOR SUBROUTINE STRNUM, THE INPUT +C STRING MAY CONTAIN A LEADING SIGN CHARACTER (E.G. '+', '-'). +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- RENAMED THIS FUNCTION FROM "VAL$" TO "VALX" +C TO REMOVE THE POSSIBILITY OF THE "$" SYMBOL +C CAUSING PROBLEMS ON OTHER PLATFORMS +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 +C 2009-04-21 J. ATOR -- USE ERRWRT +C +C USAGE: VALX (STR) +C INPUT ARGUMENT LIST: +C STR - CHARACTER*(*): STRING CONTAINING ENCODED REAL VALUE +C +C OUTPUT ARGUMENT LIST: +C VALX - REAL: DECODED VALUE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT2 ERRWRT RJUST +C THIS ROUTINE IS CALLED BY: GETTBH NEMTBB UPFTBV +C Normally not called by any application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + CHARACTER*(*) STR + CHARACTER*128 BORT_STR1,BORT_STR2 + CHARACTER*99 BSTR + CHARACTER*8 FMT + + COMMON /QUIET / IPRT + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + LENS = LEN(STR) + IF(LENS.GT.99) GOTO 900 + BSTR(1:LENS) = STR + RJ = RJUST(BSTR(1:LENS)) + WRITE(FMT,'(''(F'',I2,''.0)'')') LENS + VALX = BMISS + READ(BSTR,FMT,ERR=800) VAL + VALX = VAL + GOTO 100 +800 IF(IPRT.GE.0) THEN + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT('BUFRLIB: VALX - ERROR READING STRING:') + CALL ERRWRT(BSTR(1:LENS)) + CALL ERRWRT('RETURN WITH VALX = MISSING') + CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') + CALL ERRWRT(' ') + ENDIF + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR1,'("STRING IS: ",A)') STR + WRITE(BORT_STR2,'("BUFRLIB: VALX - STRING LENGTH EXCEEDS LIMIT '// + . ' OF 99 CHARACTERS")') + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/bufr/wrcmps.f b/src/bufr/wrcmps.f new file mode 100644 index 0000000000..7374eaa493 --- /dev/null +++ b/src/bufr/wrcmps.f @@ -0,0 +1,472 @@ + SUBROUTINE WRCMPS(LUNIX) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRCMPS +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY +C (ARRAY IBAY IN COMMON BLOCK /BITBUF/), STORING IT FOR COMPRESSION. +C IT THEN TRIES TO ADD IT TO THE COMPRESSED BUFR MESSAGE THAT IS +C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNIX) (ARRAY MESG). IF THE +C SUBSET WILL NOT FIT INTO THE CURRENTLY OPEN MESSAGE, THEN THAT +C COMPRESSED MESSAGE IS FLUSHED TO LUNIX AND A NEW ONE IS CREATED IN +C ORDER TO HOLD THE CURRENT SUBSET (STILL STORED FOR COMPRESSION). +C THIS SUBROUTINE PERFORMS FUNCTIONS SIMILAR TO BUFR ARCHIVE LIBRARY +C SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); LOGICAL VARIABLES +C "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL +C MEMORY (IN COMMON BLOCK /COMPRS/), THIS +C FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD +C TO MESSAGES BEING WRITTEN OUT BEFORE THEY +C ARE FULL; UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-18 J. ATOR -- REMOVE CALL TO XMSGINI (CMSGINI NOW HAS +C SAME CAPABILITY); IMPROVE DOCUMENTATION; +C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS +C THE SAME FOR ALL SUBSETS IN A MESSAGE; +C MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2004-08-18 J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST' +C 2) ADDED 'KMISS' TO FIX BUG WHICH WOULD +C OCCASIONALLY SKIP OVER SUBSETS +C 3) ADDED LOGIC TO MAKE SURE MISSING VALUES +C ARE REPRESENTED BY INCREMENTS WITH ALL +C BITS ON +C 4) REMOVED TWO UNECESSARY REFERENCES TO +C 'WRIT1' +C 2005-11-29 J. ATOR -- FIX INITIALIZATION BUG FOR CHARACTER +C COMPRESSION; INCREASE MXCSB TO 4000; +C USE IUPBS01; CHECK EDITION NUMBER OF BUFR +C MESSAGE BEFORE PADDING TO AN EVEN BYTE COUNT +C 2009-03-23 J. ATOR -- ADDED SAVE FOR IBYT AND JBIT; USE MSGFULL +C 2009-08-11 J. WOOLLEN -- MADE CATX AND CSTR BIGGER TO HANDLE LONGER +C STRINGS. ALSO SEPARATED MATX,CATX,NCOL FROM +C OTHER VARS IN COMMON COMPRS FOR USE IN +C SUBROUTINE WRITLC. ALSO PASSED MBAY(1,LUN) +C AS ARRAY TO INITIAL CALL TO CMSGINI IN ORDER +C FOR USE BY WRITLC. +C 2012-02-17 J. ATOR -- FIXED A BUG INVOLVING COMPRESSED FILES WITH +C EMBEDDED DICTIONARY MESSAGES +C +C USAGE: CALL WRCMPS (LUNIX) +C INPUT ARGUMENT LIST: +C LUNIX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A +C "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT) +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CMSGINI IUPBS01 MSGFULL +C MSGWRT PKB PKC STATUS +C UPB UPC USRTPL +C THIS ROUTINE IS CALLED BY: CLOSMG WRITSA WRITSB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB) + COMMON /COMPRX/ KMIN(MXCDV),KMAX(MXCDV),KMIS(MXCDV),KBIT(MXCDV), + . ITYP(MXCDV),IWID(MXCDV),NROW,LUNC,KBYT,WRIT1, + . FLUSH,CSTR(MXCDV) + COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) + + CHARACTER*(MXLCC) CATX,CSTR + CHARACTER*128 BORT_STR + CHARACTER*10 TAG + CHARACTER*8 SUBSET,CMNEM + CHARACTER*3 TYP + + LOGICAL MSGFULL + + DIMENSION MESG(MXMSGLD4) + +C NOTE THE FOLLOWING LOGICAL FLAGS: +C FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE +C FIRST SUBSET OF A NEW MESSAGE +C FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED +C WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY +C PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY +C IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!) +C WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS +C TO BE WRITTEN OUT + + LOGICAL FIRST,FLUSH,WRIT1,KMIS,KMISS,EDGE4 + REAL*8 VAL + + DATA FIRST /.TRUE./ + + SAVE FIRST,IBYT,JBIT,SUBSET + +C----------------------------------------------------------------------- + RLN2 = 1./LOG(2.) +C----------------------------------------------------------------------- + +C GET THE UNIT AND SUBSET TAG +C --------------------------- + + LUNIT = ABS(LUNIX) + CALL STATUS(LUNIT,LUN,IL,IM) + +C IF THIS IS A "FIRST" CALL, THEN INITIALIZE SOME VALUES IN +C ORDER TO PREPARE FOR THE CREATION OF A NEW COMPRESSED BUFR +C MESSAGE FOR OUTPUT. + + 1 IF(FIRST) THEN + KBYT = 0 + NCOL = 0 + LUNC = LUN + NROW = NVAL(LUN) + SUBSET = TAG(INODE(LUN)) + FIRST = .FALSE. + FLUSH = .FALSE. + WRIT1 = .FALSE. + +C THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE +C HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY +C THE INFORMATION IN SECTIONS 0, 1, 2 AND 3. THIS WILL +C ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL +C FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB. LATER ON, +C A SEPARATE CALL TO CMSGINI WILL BE DONE TO ACTUALLY +C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED +C BUFR MESSAGE THAT WILL BE WRITTEN OUT. + + CALL CMSGINI(LUN,MBAY(1,LUN),SUBSET,IDATE(LUN),NCOL,KBYT) + +C CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED + + EDGE4 = .FALSE. + IF(NS01V.GT.0) THEN + II = 1 + DO WHILE ( (.NOT.EDGE4) .AND. (II.LE.NS01V) ) + IF( (CMNEM(II).EQ.'BEN') .AND. (IVMNEM(II).GE.4) ) THEN + EDGE4 = .TRUE. + ELSE + II = II+1 + ENDIF + ENDDO + ENDIF + + ENDIF + + IF(LUN.NE.LUNC) GOTO 900 + +C IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT +C THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE +C THE FINAL COMPRESSED BUFR MESSAGE. + + IF(LUNIX.LT.0) THEN + IF(NCOL.EQ.0) GOTO 100 + IF(NCOL.GT.0) THEN + FLUSH = .TRUE. + WRIT1 = .TRUE. + ICOL = 1 + GOTO 20 + ENDIF + ENDIF + +C CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS +C --------------------------------------------------- + + IF(NCOL+1.GT.MXCSB) THEN + GOTO 50 + ELSEIF(NVAL(LUN).NE.NROW) THEN + GOTO 50 + ELSEIF(NVAL(LUN).GT.MXCDV) THEN + GOTO 901 + ENDIF + +C STORE THE NEXT SUBSET FOR COMPRESSION +C ------------------------------------- + +C WILL THE CURRENT SUBSET FIT INTO THE CURRENT MESSAGE? +C (UNFORTUNATELY, THE ONLY WAY TO FIND OUT IS TO ACTUALLY +C RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL +C REFERENCE VALUES, INCREMENTS, ETC.) + + 10 NCOL = NCOL+1 + ICOL = NCOL + IBIT = 16 + DO I=1,NVAL(LUN) + NODE = INV(I,LUN) + ITYP(I) = ITP(NODE) + IWID(I) = IBT(NODE) + IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN + CALL UPB(MATX(I,NCOL),IBT(NODE),IBAY,IBIT) + ELSEIF(ITYP(I).EQ.3) THEN + CALL UPC(CATX(I,NCOL),IBT(NODE)/8,IBAY,IBIT) + ENDIF + ENDDO + +C COMPUTE THE MIN,MAX,WIDTH FOR EACH ROW - ACCUMULATE LENGTH +C ---------------------------------------------------------- + +C LDATA WILL HOLD THE LENGTH IN BITS OF THE COMPRESSED DATA +C (I.E. THE SUM TOTAL FOR ALL DATA VALUES FOR ALL SUBSETS +C IN THE MESSAGE) + + 20 LDATA = 0 + IF(NCOL.LE.0) GOTO 902 + DO I=1,NROW + IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) THEN + +C ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES, +C SO KMIS(I) WILL STORE: +C .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING" +C .TRUE. OTHERWISE + + IMISS = 2**IWID(I)-1 + IF(ICOL.EQ.1) THEN + KMIN(I) = IMISS + KMAX(I) = 0 + KMIS(I) = .FALSE. + ENDIF + DO J=ICOL,NCOL + IF(MATX(I,J).LT.IMISS) THEN + KMIN(I) = MIN(KMIN(I),MATX(I,J)) + KMAX(I) = MAX(KMAX(I),MATX(I,J)) + ELSE + KMIS(I) = .TRUE. + ENDIF + ENDDO + KMISS = KMIS(I).AND.KMIN(I).LT.IMISS + RANGE = MAX(1,KMAX(I)-KMIN(I)+1) + IF(ITYP(I).EQ.1.AND.RANGE.GT.1) THEN + +C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX +C ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE +C NOT ALL IDENTICAL (I.E. RANGE.GT.1), SO WE CANNOT +C COMPRESS ALL OF THESE SUBSETS INTO THE SAME MESSAGE. +C ASSUMING THAT NONE OF THE VALUES ARE "MISSING", +C EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN +C OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN. + + IF(KMISS) GOTO 903 + WRIT1 = .TRUE. + NCOL = NCOL-1 + ICOL = 1 + GOTO 20 + ELSEIF(ITYP(I).EQ.2.AND.(RANGE.GT.1..OR.KMISS)) THEN + +C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX +C ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL. +C COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE +C LARGEST OF THE INCREMENTS. + + KBIT(I) = NINT(LOG(RANGE)*RLN2) + IF(2**KBIT(I)-1.LE.RANGE) KBIT(I) = KBIT(I)+1 + +C HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER +C EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING +C DESCRIPTOR! + + IF(KBIT(I).GT.IWID(I)) KBIT(I) = IWID(I) + ELSE + +C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX +C ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE +C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. + + KBIT(I) = 0 + ENDIF + LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) + ELSEIF(ITYP(I).EQ.3) THEN + +C ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES, +C SO KMIS(I) WILL STORE: +C .FALSE. IF ALL SUCH VALUES ARE IDENTICAL +C .TRUE. OTHERWISE + + IF(ICOL.EQ.1) THEN + CSTR(I) = CATX(I,1) + KMIS(I) = .FALSE. + ENDIF + DO J=ICOL,NCOL + IF ( (.NOT.KMIS(I)) .AND. (CSTR(I).NE.CATX(I,J)) ) THEN + KMIS(I) = .TRUE. + ENDIF + ENDDO + IF (KMIS(I)) THEN + +C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX +C ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL. + + KBIT(I) = IWID(I) + ELSE + +C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX +C ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE +C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. + + KBIT(I) = 0 + ENDIF + LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) + ENDIF + ENDDO + +C ROUND DATA LENGTH UP TO A WHOLE BYTE COUNT +C ------------------------------------------ + + IBYT = (LDATA+8-MOD(LDATA,8))/8 + +C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE +C THAT WE ROUND TO AN EVEN BYTE COUNT + + IF( (.NOT.EDGE4) .AND. (MOD(IBYT,2).NE.0) ) IBYT = IBYT+1 + + JBIT = IBYT*8-LDATA + +C CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN +C ------------------------------------------------------------------ + + IF(MSGFULL(IBYT,KBYT,MAXCMB)) THEN + +C THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE. +C SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED, +C THEN GO BACK AND RE-COMPRESS THE SECTION 4 DATA FOR THIS +C MESSAGE WHILE *EXCLUDING* THE DATA FOR THE CURRENT SUBSET +C (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A +C NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!). + + WRIT1 = .TRUE. + NCOL = NCOL-1 + ICOL = 1 + GOTO 20 + ELSEIF(.NOT.WRIT1) THEN + +C ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN. + + CALL USRTPL(LUN,1,1) + NSUB(LUN) = -NCOL + GOTO 100 + ENDIF + +C WRITE THE COMPLETE COMPRESSED MESSAGE +C ------------------------------------- + +C NOW IT IS TIME TO DO THE "REAL" CALL TO CMSGINI TO ACTUALLY +C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED +C BUFR MESSAGE THAT WILL BE WRITTEN OUT. + + 50 CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL,IBYT) + +C NOW ADD THE SECTION 4 DATA. + + IBIT = IBYT*8 + DO I=1,NROW + IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN + CALL PKB(KMIN(I),IWID(I),MESG,IBIT) + CALL PKB(KBIT(I), 6,MESG,IBIT) + IF(KBIT(I).GT.0) THEN + DO J=1,NCOL + IF(MATX(I,J).LT.2**IWID(I)-1) THEN + INCR = MATX(I,J)-KMIN(I) + ELSE + INCR = 2**KBIT(I)-1 + ENDIF + CALL PKB(INCR,KBIT(I),MESG,IBIT) + ENDDO + ENDIF + ELSEIF(ITYP(I).EQ.3) THEN + NCHR = IWID(I)/8 + IF(KBIT(I).GT.0) THEN + CALL PKB( 0,IWID(I),MESG,IBIT) + CALL PKB(NCHR, 6,MESG,IBIT) + DO J=1,NCOL + CALL PKC(CATX(I,J),NCHR,MESG,IBIT) + ENDDO + ELSE + CALL PKC(CSTR(I),NCHR,MESG,IBIT) + CALL PKB( 0, 6,MESG,IBIT) + ENDIF + ENDIF + ENDDO + +C FILL IN THE END OF THE MESSAGE +C ------------------------------ + +C PAD THE END OF SECTION 4 WITH ZEROES UP TO THE NECESSARY +C BYTE COUNT. + + CALL PKB( 0,JBIT,MESG,IBIT) + +C ADD SECTION 5. + + CALL PKC('7777', 4,MESG,IBIT) + +C SEE THAT THE MESSAGE BYTE COUNTERS AGREE THEN WRITE A MESSAGE +C ------------------------------------------------------------- + + IF(MOD(IBIT,8).NE.0) GOTO 904 + LBYT = IUPBS01(MESG,'LENM') + NBYT = IBIT/8 + IF(NBYT.NE.LBYT) GOTO 905 + + CALL MSGWRT(LUNIT,MESG,NBYT) + + MAXROW = MAX(MAXROW,NROW) + MAXCOL = MAX(MAXCOL,NCOL) + NCMSGS = NCMSGS+1 + NCSUBS = NCSUBS+NCOL + NCBYTS = NCBYTS+NBYT + +C RESET +C ----- + +C NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK +C AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE +C WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT. + + FIRST = .TRUE. + IF(.NOT.FLUSH) GOTO 1 + +C EXITS +C ----- + +100 RETURN +900 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '// + . 'CALL (",I3,") .NE. I/O STREAM INDEX FOR INITIAL CALL (",I3,")'// + . ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC,LUNIX + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// + . 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE '// + . 'COMPRESSION MATRIX (",I6,")")') NVAL(LUN),MXCDV + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// + . 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL + CALL BORT(BORT_STR) +903 CALL BORT('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR') +904 CALL BORT('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// + . 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '// + . ' A BYTE BOUNDARY') +905 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// + . 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'// + .',I6,")")') LBYT,NBYT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/wrdesc.c b/src/bufr/wrdesc.c new file mode 100644 index 0000000000..d6df3fc957 --- /dev/null +++ b/src/bufr/wrdesc.c @@ -0,0 +1,59 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRDESC +C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 +C +C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF A DESCRIPTOR, +C THIS ROUTINE ADDS IT TO AN ONGOING ARRAY OF DESCRIPTORS, AFTER +C FIRST MAKING SURE THAT THERE IS ENOUGH ROOM IN THE ARRAY. +C IF AN ARRAY OVERFLOW OCCURS, THEN AN APPROPRIATE ERROR MESSAGE +C WILL BE WRITTEN VIA BORT. +C +C PROGRAM HISTORY LOG: +C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR +C +C USAGE: CALL WRDESC( DESC, DESCARY, NDESCARY ) +C INPUT ARGUMENT LIST: +C DESC - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR +C TO BE WRITTEN INTO DESCARY +C DESCARY - INTEGER: ARRAY OF DESCRIPTORS +C NDESCARY - INTEGER: NUMBER OF DESCRIPTORS WRITTEN SO FAR +C INTO DESCARY +C +C OUTPUT ARGUMENT LIST: +C DESCARY - INTEGER: ARRAY OF DESCRIPTORS +C NDESCARY - INTEGER: NUMBER OF DESCRIPTORS WRITTEN SO FAR +C INTO DESCARY +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: RESTD +C Normally not called by application +C programs but it could be. +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$*/ + +#include "bufrlib.h" + +void wrdesc( f77int desc, f77int descary[], f77int *ndescary ) +{ + char errstr[129]; + +/* +** Is there room in descary for desc ? +*/ + if ( ( *ndescary + 1 ) < MAXNC ) { + descary[(*ndescary)++] = desc; + } + else { + sprintf( errstr, "BUFRLIB: WRDESC - EXPANDED SECTION 3 CONTAINS" + " MORE THAN %d DESCRIPTORS", MAXNC ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } + + return; +} diff --git a/src/bufr/wrdlen.F b/src/bufr/wrdlen.F new file mode 100755 index 0000000000..75591d31e4 --- /dev/null +++ b/src/bufr/wrdlen.F @@ -0,0 +1,482 @@ + SUBROUTINE WRDLEN + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRDLEN +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE FIGURES OUT SOME IMPORTANT INFORMATION +C ABOUT THE LOCAL MACHINE ON WHICH THE BUFR ARCHIVE LIBRARY SOFTWARE +C IS BEING RUN AND STORES THIS INTO COMMON BLOCK /HRDWRD/. SUCH +C INFORMATION INCLUDES DETERMINING THE NUMBER OF BITS AND THE NUMBER +C OF BYTES IN A MACHINE WORD AS WELL AS DETERMINING WHETHER THE +C MACHINE USES THE ASCII OR EBCDIC CHARACTER SET. +C +C NOTE: IT IS ONLY NECESSARY FOR THIS SUBROUTINE TO BE CALLED ONCE, +C AND THIS IS NORMALLY DONE DURING THE FIRST CALL TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF. HOWEVER, THE SUBROUTINE DOES KEEP TRACK +C OF WHETHER IT HAS ALREADY BEEN CALLED; THUS, IF IT IS CALLED AGAIN +C LATER BY A DIFFERENT BUFR ARCHIVE LIBRARY SUBROUTINE, IT WILL JUST +C QUIETLY RETURN WITHOUT (RE)COMPUTING ALL OF THE INFORMATION WITHIN +C COMMON BLOCK /HRDWRD/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY OR FOR INFORMATIONAL PURPOSES; +C NBYTW INITIALIZED AS ZERO THE FIRST TIME +C THIS ROUTINE IS CALLED (BEFORE WAS +C UNDEFINED WHEN FIRST REFERENCED) +C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST FLAG AND IMMEDIATE +C RETURN IF IFIRST=1 +C 2007-01-19 J. ATOR -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW +C DETERMINED AT COMPILE TIME AND CONFIGURED +C WITHIN BUFRLIB VIA CONDITIONAL COMPILATION +C DIRECTIVES +C 2009-03-23 J. ATOR -- CALL BVERS TO GET VERSION NUMBER +C +C USAGE: CALL WRDLEN +C +C REMARKS: +C THIS ROUTINE CALLS: BORT BVERS ERRWRT IUPM +C THIS ROUTINE IS CALLED BY: COBFL COPYBF DATEBF DATELEN +C DUMPBF IUPBS01 MESGBC MESGBF +C OPENBF RDMTBB UPDS3 +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) + COMMON /QUIET / IPRT + + CHARACTER*128 BORT_STR,ERRSTR + CHARACTER*8 CINT,DINT,CVSTR + CHARACTER*6 CNDIAN,CLANG + EQUIVALENCE (CINT,INT) + EQUIVALENCE (DINT,JNT) + LOGICAL PRINT + + DATA IFIRST/0/ + + SAVE IFIRST + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C HAS THIS SUBROUTINE ALREADY BEEN CALLED? + + IF(IFIRST.EQ.0) THEN + +C NO, SO CHECK WHETHER DIAGNOSTIC INFORMATION SHOULD BE PRINTED +C AND THEN PROCEED THROUGH THE REST OF THE SUBROUTINE. + + PRINT = IPRT.GE.1 + IFIRST = 1 + ELSE + +C YES, SO THERE IS NO NEED TO PROCEED ANY FURTHER. + + RETURN + ENDIF + +C COUNT THE BITS IN A WORD - MAX 64 ALLOWED +C ----------------------------------------- + + INT = 1 + DO I=1,65 + INT = ISHFT(INT,1) + IF(INT.EQ.0) GOTO 10 + ENDDO +c .... DK: Can the below ever happen since upper loop bounds is 65? + 10 IF(I.GE.65) GOTO 900 + IF(MOD(I,8).NE.0) GOTO 901 + +C NBITW is no. of bits in a word, NBYTW is no. of bytes in a word +C --------------------------------------------------------------- + + NBITW = I + NBYTW = I/8 + +C INDEX THE BYTE STORAGE ORDER - HIGH BYTE TO LOW BYTE +C ----------------------------------------------------- + + JNT = 0 + + DO I = 1,8 + IORD(I) = 9999 + ENDDO + + DO I=1,NBYTW + INT = ISHFT(1,(NBYTW-I)*8) + DO J=1,NBYTW + IF(CINT(J:J).NE.DINT(J:J)) GOTO 20 + ENDDO +c .... DK: Can the below ever happen since upper loop bounds is NBYTW? + 20 IF(J.GT.NBYTW) GOTO 902 + IORD(I) = J + ENDDO + +C SETUP AN ASCII/EBCDIC TRANSLATOR AND DETERMINE WHICH IS NATIVE +C -------------------------------------------------------------- + + IA = IUPM('A',8) + IF(IA.EQ. 65) THEN + IASCII = 1 + CLANG = 'ASCII ' + ELSEIF(IA.EQ.193) THEN + IASCII = 0 + CLANG = 'EBCDIC' + ELSE + GOTO 903 + ENDIF + + DO I=0,255 + IETOA(I) = 0 + IATOE(I) = 0 + ENDDO + + IETOA( 1) = 1 + IATOE( 1) = 1 + IETOA( 2) = 2 + IATOE( 2) = 2 + IETOA( 3) = 3 + IATOE( 3) = 3 + IETOA( 5) = 9 + IATOE( 9) = 5 + IETOA( 7) = 127 + IATOE(127) = 7 + IETOA( 11) = 11 + IATOE( 11) = 11 + IETOA( 12) = 12 + IATOE( 12) = 12 + IETOA( 13) = 13 + IATOE( 13) = 13 + IETOA( 14) = 14 + IATOE( 14) = 14 + IETOA( 15) = 15 + IATOE( 15) = 15 + IETOA( 16) = 16 + IATOE( 16) = 16 + IETOA( 17) = 17 + IATOE( 17) = 17 + IETOA( 18) = 18 + IATOE( 18) = 18 + IETOA( 19) = 19 + IATOE( 19) = 19 + IETOA( 22) = 8 + IATOE( 8) = 22 + IETOA( 24) = 24 + IATOE( 24) = 24 + IETOA( 25) = 25 + IATOE( 25) = 25 + IETOA( 29) = 29 + IATOE( 29) = 29 + IETOA( 31) = 31 + IATOE( 31) = 31 + IETOA( 34) = 28 + IATOE( 28) = 34 + IETOA( 37) = 10 + IATOE( 10) = 37 + IETOA( 38) = 23 + IATOE( 23) = 38 + IETOA( 39) = 27 + IATOE( 27) = 39 + IETOA( 45) = 5 + IATOE( 5) = 45 + IETOA( 46) = 6 + IATOE( 6) = 46 + IETOA( 47) = 7 + IATOE( 7) = 47 + IETOA( 50) = 22 + IATOE( 22) = 50 + IETOA( 53) = 30 + IATOE( 30) = 53 + IETOA( 55) = 4 + IATOE( 4) = 55 + IETOA( 60) = 20 + IATOE( 20) = 60 + IETOA( 61) = 21 + IATOE( 21) = 61 + IETOA( 63) = 26 + IATOE( 26) = 63 + IETOA( 64) = 32 + IATOE( 32) = 64 + IETOA( 74) = 91 + IATOE( 91) = 74 + IETOA( 75) = 46 + IATOE( 46) = 75 + IETOA( 76) = 60 + IATOE( 60) = 76 + IETOA( 77) = 40 + IATOE( 40) = 77 + IETOA( 78) = 43 + IATOE( 43) = 78 + IETOA( 79) = 33 + IATOE( 33) = 79 + IETOA( 80) = 38 + IATOE( 38) = 80 + IETOA( 90) = 93 + IATOE( 93) = 90 + IETOA( 91) = 36 + IATOE( 36) = 91 + IETOA( 92) = 42 + IATOE( 42) = 92 + IETOA( 93) = 41 + IATOE( 41) = 93 + IETOA( 94) = 59 + IATOE( 59) = 94 + IETOA( 95) = 94 + IATOE( 94) = 95 + IETOA( 96) = 45 + IATOE( 45) = 96 + IETOA( 97) = 47 + IATOE( 47) = 97 + IETOA(106) = 124 + IATOE(124) = 106 + IETOA(107) = 44 + IATOE( 44) = 107 + IETOA(108) = 37 + IATOE( 37) = 108 + IETOA(109) = 95 + IATOE( 95) = 109 + IETOA(110) = 62 + IATOE( 62) = 110 + IETOA(111) = 63 + IATOE( 63) = 111 + IETOA(121) = 96 + IATOE( 96) = 121 + IETOA(122) = 58 + IATOE( 58) = 122 + IETOA(123) = 35 + IATOE( 35) = 123 + IETOA(124) = 64 + IATOE( 64) = 124 + IETOA(125) = 39 + IATOE( 39) = 125 + IETOA(126) = 61 + IATOE( 61) = 126 + IETOA(127) = 34 + IATOE( 34) = 127 + IETOA(129) = 97 + IATOE( 97) = 129 + IETOA(130) = 98 + IATOE( 98) = 130 + IETOA(131) = 99 + IATOE( 99) = 131 + IETOA(132) = 100 + IATOE(100) = 132 + IETOA(133) = 101 + IATOE(101) = 133 + IETOA(134) = 102 + IATOE(102) = 134 + IETOA(135) = 103 + IATOE(103) = 135 + IETOA(136) = 104 + IATOE(104) = 136 + IETOA(137) = 105 + IATOE(105) = 137 + IETOA(145) = 106 + IATOE(106) = 145 + IETOA(146) = 107 + IATOE(107) = 146 + IETOA(147) = 108 + IATOE(108) = 147 + IETOA(148) = 109 + IATOE(109) = 148 + IETOA(149) = 110 + IATOE(110) = 149 + IETOA(150) = 111 + IATOE(111) = 150 + IETOA(151) = 112 + IATOE(112) = 151 + IETOA(152) = 113 + IATOE(113) = 152 + IETOA(153) = 114 + IATOE(114) = 153 + IETOA(161) = 126 + IATOE(126) = 161 + IETOA(162) = 115 + IATOE(115) = 162 + IETOA(163) = 116 + IATOE(116) = 163 + IETOA(164) = 117 + IATOE(117) = 164 + IETOA(165) = 118 + IATOE(118) = 165 + IETOA(166) = 119 + IATOE(119) = 166 + IETOA(167) = 120 + IATOE(120) = 167 + IETOA(168) = 121 + IATOE(121) = 168 + IETOA(169) = 122 + IATOE(122) = 169 + IETOA(173) = 91 + IATOE( 91) = 173 + IETOA(176) = 48 + IATOE( 48) = 176 + IETOA(177) = 49 + IATOE( 49) = 177 + IETOA(178) = 50 + IATOE( 50) = 178 + IETOA(179) = 51 + IATOE( 51) = 179 + IETOA(180) = 52 + IATOE( 52) = 180 + IETOA(181) = 53 + IATOE( 53) = 181 + IETOA(182) = 54 + IATOE( 54) = 182 + IETOA(183) = 55 + IATOE( 55) = 183 + IETOA(184) = 56 + IATOE( 56) = 184 + IETOA(185) = 57 + IATOE( 57) = 185 + IETOA(189) = 93 + IATOE( 93) = 189 + IETOA(192) = 123 + IATOE(123) = 192 + IETOA(193) = 65 + IATOE( 65) = 193 + IETOA(194) = 66 + IATOE( 66) = 194 + IETOA(195) = 67 + IATOE( 67) = 195 + IETOA(196) = 68 + IATOE( 68) = 196 + IETOA(197) = 69 + IATOE( 69) = 197 + IETOA(198) = 70 + IATOE( 70) = 198 + IETOA(199) = 71 + IATOE( 71) = 199 + IETOA(200) = 72 + IATOE( 72) = 200 + IETOA(201) = 73 + IATOE( 73) = 201 + IETOA(208) = 125 + IATOE(125) = 208 + IETOA(209) = 74 + IATOE( 74) = 209 + IETOA(210) = 75 + IATOE( 75) = 210 + IETOA(211) = 76 + IATOE( 76) = 211 + IETOA(212) = 77 + IATOE( 77) = 212 + IETOA(213) = 78 + IATOE( 78) = 213 + IETOA(214) = 79 + IATOE( 79) = 214 + IETOA(215) = 80 + IATOE( 80) = 215 + IETOA(216) = 81 + IATOE( 81) = 216 + IETOA(217) = 82 + IATOE( 82) = 217 + IETOA(224) = 92 + IATOE( 92) = 224 + IETOA(226) = 83 + IATOE( 83) = 226 + IETOA(227) = 84 + IATOE( 84) = 227 + IETOA(228) = 85 + IATOE( 85) = 228 + IETOA(229) = 86 + IATOE( 86) = 229 + IETOA(230) = 87 + IATOE( 87) = 230 + IETOA(231) = 88 + IATOE( 88) = 231 + IETOA(232) = 89 + IATOE( 89) = 232 + IETOA(233) = 90 + IATOE( 90) = 233 + IETOA(240) = 48 + IATOE( 48) = 240 + IETOA(241) = 49 + IATOE( 49) = 241 + IETOA(242) = 50 + IATOE( 50) = 242 + IETOA(243) = 51 + IATOE( 51) = 243 + IETOA(244) = 52 + IATOE( 52) = 244 + IETOA(245) = 53 + IATOE( 53) = 245 + IETOA(246) = 54 + IATOE( 54) = 246 + IETOA(247) = 55 + IATOE( 55) = 247 + IETOA(248) = 56 + IATOE( 56) = 248 + IETOA(249) = 57 + IATOE( 57) = 249 + +C SHOW SOME RESULTS +C ----------------- + + IF(PRINT) THEN + CALL BVERS(CVSTR) +#ifdef BIG_ENDIAN + CNDIAN = ' BIG ' +#else + CNDIAN = 'LITTLE' +#endif + ERRSTR = '=============== ' // + . 'WELCOME TO THE BUFR ARCHIVE LIBRARY' // ' ==============' + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I2)' ) + . ' MACHINE CHARACTERISTICS: NUMBER OF BYTES PER WORD =', NBYTW + CALL ERRWRT(ERRSTR) + WRITE ( UNIT=ERRSTR, FMT='(A,I3)' ) + . ' NUMBER OF BITS PER WORD =', NBITW + CALL ERRWRT(ERRSTR) + ERRSTR = ' BYTE ORDER IS ' // CNDIAN // + . ' ENDIAN' + CALL ERRWRT(ERRSTR) + ERRSTR = ' ' // CLANG // + . ' IS THE NATIVE LANGUAGE' + CALL ERRWRT(ERRSTR) + ERRSTR = '====================== VERSION: ' // CVSTR // + . '==========================' + CALL ERRWRT(ERRSTR) + CALL ERRWRT(' ') + ENDIF + +C EXITS +C ----- + + RETURN + 900 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH IS '// + . 'LIMITED TO 64 BITS (THIS MACHINE APPARENTLY HAS",I4," BIT '// + . 'WORDS!)")') I + CALL BORT(BORT_STR) + 901 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH (",I4,"'// + . ') IS NOT A MULTIPLE OF 8 (THIS MACHINE HAS WORDS NOT ON WHOLE'// + . ' BYTE BOUNDARIES!)")') I + CALL BORT(BORT_STR) + 902 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - BYTE ORDER CHECKING MISTAKE'// + . ', LOOP INDEX J (HERE =",I3,") IS .GT. NO. OF BYTES PER WORD '// + . 'ON THIS MACHINE (",I3,")")') J,NBYTW + CALL BORT(BORT_STR) + 903 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - CAN''T DETERMINE MACHINE '// + . 'NATIVE LANGUAGE (CHAR. A UNPACKS TO INT.",I4," NEITHER ASCII '// + . ' (65) NOR EBCDIC (193)")') IA + CALL BORT(BORT_STR) + END diff --git a/src/bufr/wrdxtb.f b/src/bufr/wrdxtb.f new file mode 100644 index 0000000000..5d010cb037 --- /dev/null +++ b/src/bufr/wrdxtb.f @@ -0,0 +1,182 @@ + SUBROUTINE WRDXTB(LUNDX,LUNOT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRDXTB +C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 +C +C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES +C ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE BUFR FILE IN LUNOT. +C BOTH UNITS MUST BE OPENED VIA PREVIOUS CALLS TO BUFR ARCHIVE +C LIBRARY SUBROUTINE OPENBF, AND IN PARTICULAR LUNOT MUST HAVE +C BEEN OPENED FOR OUTPUT. THE TABLE MESSAGES ARE GENERATED FROM +C ARRAYS IN INTERNAL MEMORY (COMMON BLOCK /TABABD/). LUNDX CAN BE +C THE SAME AS LUNOT IF IT IS DESIRED TO APPEND TO LUNOT WITH BUFR +C MESSAGES GENERATED FROM ITS OWN INTERNAL TABLES. +C +C PROGRAM HISTORY LOG: +C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC FROM WRITDX +C 2012-04-06 J. ATOR -- PREVENT STORING OF MORE THAN 255 TABLE A, +C TABLE B OR TABLE D DESCRIPTORS IN ANY +C SINGLE DX MESSAGE +C +C USAGE: CALL WRDXTB (LUNDX,LUNOT) +C INPUT ARGUMENT LIST: +C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED +C WITH DX (DICTIONARY) TABLES TO BE WRITTEN OUT; +C CAN BE SAME AS LUNOT +C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C TO BE APPENDED WITH TABLES ASSOCIATED WITH LUNDX +C +C REMARKS: +C THIS ROUTINE CALLS: ADN30 BORT CPBFDX DXMINI +C GETLENS IPKM IUPM MSGFULL +C MSGWRT PKB PKC STATUS +C THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), + . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), + . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), + . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), + . TABD(MAXTBD,NFILES) + COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), + . LD30(10),DXSTR(10) + + CHARACTER*600 TABD + CHARACTER*128 BORT_STR + CHARACTER*128 TABB + CHARACTER*128 TABA + CHARACTER*56 DXSTR + CHARACTER*6 ADN30 + CHARACTER*1 MOCT(MXMSGL) + + LOGICAL MSGFULL + + DIMENSION MBAY(MXMSGLD4) + + EQUIVALENCE (MOCT(1),MBAY(1)) + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK FILE STATUSES +C ------------------- + + CALL STATUS(LUNOT,LOT,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + + CALL STATUS(LUNDX,LDX,IL,IM) + IF(IL.EQ.0) GOTO 902 + +C IF FILES ARE DIFFERENT, COPY INTERNAL TABLE +C INFORMATION FROM LUNDX TO LUNOT +C ------------------------------------------- + + IF(LUNDX.NE.LUNOT) CALL CPBFDX(LDX,LOT) + +C GENERATE AND WRITE OUT BUFR DICTIONARY MESSAGES TO LUNOT +C -------------------------------------------------------- + + CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) + + LDA = LDXA(IDXV+1) + LDB = LDXB(IDXV+1) + LDD = LDXD(IDXV+1) + L30 = LD30(IDXV+1) + +C Table A information + + DO I=1,NTBA(LOT) + IF(MSGFULL(MBYT,LDA,MAXDX).OR. + + (IUPM(MOCT(MBYA),8).EQ.255)) THEN + CALL MSGWRT(LUNOT,MBAY,MBYT) + CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) + ENDIF + CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDA) + CALL IPKM(MOCT(MBYA),1,IUPM(MOCT(MBYA), 8)+ 1) + MBIT = 8*(MBYB-1) + CALL PKC(TABA(I,LOT),LDA,MBAY,MBIT) + CALL PKB( 0, 8,MBAY,MBIT) + CALL PKB( 0, 8,MBAY,MBIT) + MBYT = MBYT+LDA + MBYB = MBYB+LDA + MBYD = MBYD+LDA + ENDDO + +C Table B information + + DO I=1,NTBB(LOT) + IF(MSGFULL(MBYT,LDB,MAXDX).OR. + + (IUPM(MOCT(MBYB),8).EQ.255)) THEN + CALL MSGWRT(LUNOT,MBAY,MBYT) + CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) + ENDIF + CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDB) + CALL IPKM(MOCT(MBYB),1,IUPM(MOCT(MBYB), 8)+ 1) + MBIT = 8*(MBYD-1) + CALL PKC(TABB(I,LOT),LDB,MBAY,MBIT) + CALL PKB( 0, 8,MBAY,MBIT) + MBYT = MBYT+LDB + MBYD = MBYD+LDB + ENDDO + +C Table D information + + DO I=1,NTBD(LOT) + NSEQ = IUPM(TABD(I,LOT)(LDD+1:LDD+1),8) + LEND = LDD+1 + L30*NSEQ + IF(MSGFULL(MBYT,LEND,MAXDX).OR. + + (IUPM(MOCT(MBYD),8).EQ.255)) THEN + CALL MSGWRT(LUNOT,MBAY,MBYT) + CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) + ENDIF + CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LEND) + CALL IPKM(MOCT(MBYD),1,IUPM(MOCT(MBYD), 8)+ 1) + MBIT = 8*(MBYT-4) + CALL PKC(TABD(I,LOT),LDD,MBAY,MBIT) + CALL PKB( NSEQ, 8,MBAY,MBIT) + DO J=1,NSEQ + JJ = LDD+2 + (J-1)*2 + IDN = IUPM(TABD(I,LOT)(JJ:JJ),16) + CALL PKC(ADN30(IDN,L30),L30,MBAY,MBIT) + ENDDO + MBYT = MBYT+LEND + ENDDO + +C Write the unwritten (leftover) message. + + CALL MSGWRT(LUNOT,MBAY,MBYT) + +C Write out one additional (dummy) DX message containing zero +C subsets. This will serve as a delimiter for this set of +C table messages within output unit LUNOT, just in case the +C next thing written to LUNOT ends up being another set of +C table messages. + + CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) + CALL GETLENS(MBAY,2,LEN0,LEN1,LEN2,L3,L4,L5) + MBIT = (LEN0+LEN1+LEN2+4)*8 + CALL PKB(0,16,MBAY,MBIT) + CALL MSGWRT(LUNOT,MBAY,MBYT) + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT '// + . 'MUST BE OPEN') + END diff --git a/src/bufr/writcp.f b/src/bufr/writcp.f new file mode 100644 index 0000000000..0dd3cad62f --- /dev/null +++ b/src/bufr/writcp.f @@ -0,0 +1,51 @@ + SUBROUTINE WRITCP(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRITCP +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C LUNIT HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT NOW SIMPLY CALLS +C BUFR ARCHIVE LIBRARY SUBROUTINE CMPMSG TO TOGGLE ON MESSAGE +C COMPRESSION, FOLLOWED BY A CALL TO WRITSB TO PACK UP THE CURRENT +C SUBSET WITHIN MEMORY AND TRY TO ADD IT TO THE COMPRESSED BUFR +C MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT, +C FOLLOWED BY ANOTHER CALL TO CMPMSG TO TOGGLE OFF MESSAGE +C COMPRESSION. THIS SUBROUTINE USES THE SAME INPUT AND OUTPUT +C PARAMETERS AS WRITSB. +C +C PROGRAM HISTORY LOG: +C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2005-03-09 J. ATOR -- MODIFIED TO USE CMPMSG AND WRITSB +C +C USAGE: CALL WRITCP (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: CMPMSG WRITSB +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CALL CMPMSG('Y') + + CALL WRITSB(LUNIT) + + CALL CMPMSG('N') + + RETURN + END diff --git a/src/bufr/writdx.f b/src/bufr/writdx.f new file mode 100644 index 0000000000..47c9cc1682 --- /dev/null +++ b/src/bufr/writdx.f @@ -0,0 +1,88 @@ + SUBROUTINE WRITDX(LUNIT,LUN,LUNDX) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRITDX +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES TO +C THE BEGINNING OF AN OUTPUT BUFR FILE IN LUNIT. THE TABLE MESSAGES +C ARE READ FROM ARRAYS IN INTERNAL MEMORY (COMMON BLOCK /TABABD/). +C AN INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READDX GENERATES +C THESE INTERNAL ARRAYS. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE +C ARRAYS IN ORDER TO HANDLE BIGGER FILES +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2009-03-23 J. ATOR -- USE WRDXTB +C +C USAGE: CALL WRITDX (LUNIT, LUN, LUNDX) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C BEING WRITTEN +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) +C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING +C DICTIONARY TABLE INFORMATION TO BE USED (BY READDX) TO +C CREATE INTERNAL TABLES WRITTEN TO LUNIT (SEE READDX); +C IF SET EQUAL TO LUNIT, THIS SUBROUTINE CALLS BORT +C +C REMARKS: +C THIS ROUTINE CALLS: BORT READDX WRDXTB +C THIS ROUTINE IS CALLED BY: OPENBF +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK UNITS, TABLE MUST BE COMING FROM AN INPUT FILE +C ---------------------------------------------------- + + IF(LUNIT.EQ.LUNDX) GOTO 900 + +C MUST FIRST CALL READDX TO GENERATE INTERNAL DICTIONARY TABLE ARRAYS +C ------------------------------------------------------------------- + + CALL READDX(LUNIT,LUN,LUNDX) + +C NOW CALL WRDXTB TO WRITE OUT DICTIONARY MESSAGES FROM THESE ARRAYS +C ------------------------------------------------------------------ + + CALL WRDXTB(LUNIT,LUNIT) + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: WRITDX - FILES CONTAINING BUFR DATA '// + . 'AND DICTIONARY TABLE CANNOT BE THE SAME (HERE BOTH SHARE '// + . 'FORTRAN UNIT NUMBER ",I3,")")') LUNIT + CALL BORT(BORT_STR) + END diff --git a/src/bufr/writlc.f b/src/bufr/writlc.f new file mode 100644 index 0000000000..b4de2442a3 --- /dev/null +++ b/src/bufr/writlc.f @@ -0,0 +1,222 @@ + SUBROUTINE WRITLC(LUNIT,CHR,STR) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRITLC +C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 +C +C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER DATA ELEMENT ASSOCIATED +C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER +C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS DESIGNED TO BE USED +C TO STORE CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT +C BYTES. NOTE THAT SUBROUTINE WRITSB OR WRITSA MUST HAVE ALREADY +C BEEN CALLED TO STORE ALL OTHER ELEMENTS OF THE SUBSET BEFORE THIS +C SUBROUTINE CAN BE CALLED TO FILL IN ANY LONG CHARACTER STRINGS. +C +C PROGRAM HISTORY LOG: +C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-11-29 J. ATOR -- USE GETLENS +C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR +C 2009-03-23 J. ATOR -- ADDED '#' OPTION FOR MORE THAN ONE +C OCCURRENCE OF STR +c 2009-08-11 J. WOOLLEN -- ADDED COMMON COMPRS ALONG WITH LOGIC TO +c WRITE LONG STRINGS INTO COMPRESSED SUBSETS +C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS +C WHEN USED WITH '#' OCCURRENCE CODE +C +C USAGE: CALL WRITLC (LUNIT, CHR, STR) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., +C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) +C STR - CHARACTER*(*): MNEMONIC ASSOCIATED WITH STRING IN CHR +C +C REMARKS: +C THIS ROUTINE CALLS: BORT GETLENS IUPBS3 PARSTR +C PARUTG PKC STATUS UPB +C UPBB USRTPL +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), + . INODE(NFILES),IDATE(NFILES) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB) + + CHARACTER*(*) CHR,STR + CHARACTER*128 BORT_STR + CHARACTER*(MXLCC) CATX + CHARACTER*10 TAG,CTAG + CHARACTER*14 TGS(10) + CHARACTER*3 TYP + REAL*8 VAL + + DATA MAXTG /10/ + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE) +C ------------------------------------------------------------------ + + CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) + IF(NTG.GT.1) GOTO 903 + +C Check if a specific occurrence of the input string was requested; +C if not, then the default is to write the first occurrence. + + CALL PARUTG(LUN,1,TGS(1),NNOD,KON,ROID) + IF(KON.EQ.6) THEN + IOID=NINT(ROID) + IF(IOID.LE.0) IOID = 1 + CTAG = ' ' + II = 1 + DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#')) + CTAG(II:II)=TGS(1)(II:II) + II = II + 1 + ENDDO + ELSE + IOID = 1 + CTAG = TGS(1)(1:10) + ENDIF + +C USE THIS LEG FOR STRINGING COMPRESSED DATA (UP TO MXLCC CHARACTERS) +C ---------------------------------------------------------------- + + IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN + N = 1 + ITAGCT = 0 + CALL USRTPL(LUN,N,N) + DO WHILE (N+1.LE.NVAL(LUN)) + N = N+1 + NODE = INV(N,LUN) + IF(ITP(NODE).EQ.1) THEN + CALL USRTPL(LUN,N,MATX(N,NCOL)) + ELSEIF(CTAG.EQ.TAG(NODE)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.IOID) THEN + IF(ITP(NODE).NE.3) GOTO 904 + CATX(N,NCOL)=' ' +C -------------------------------------------------- +C Note: the following stmt enforces a limit of MXLCC +C characters per long character string when writing +C compressed messages. This limit keeps the static +C array CATX to a reasonable dimensioned size. +C -------------------------------------------------- + NCHR=MIN(MXLCC,IBT(NODE)/8) + CATX(N,NCOL)=CHR(1:NCHR) + CALL USRTPL(LUN,1,1) + GOTO 100 + ENDIF + ENDIF + ENDDO + GOTO 906 + ENDIF + +C OTHERWISE LOCATE THE BEGINNING OF THE DATA (SECTION 4) IN THE MESSAGE +C --------------------------------------------------------------------- + + CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5) + MBYTE = LEN0 + LEN1 + LEN2 + LEN3 + 4 + NSUBS = 1 + +C FIND THE MOST RECENTLY WRITTEN SUBSET IN THE MESSAGE +C ---------------------------------------------------- + + DO WHILE(NSUBS.LT.NSUB(LUN)) + IBIT = MBYTE*8 + CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) + MBYTE = MBYTE + NBYT + NSUBS = NSUBS + 1 + ENDDO + + IF(NSUBS.NE.NSUB(LUN)) GOTO 905 + +C LOCATE AND WRITE THE LONG CHARACTER STRING WITHIN THIS SUBSET +C ------------------------------------------------------------- + + ITAGCT = 0 + MBIT = MBYTE*8 + 16 + NBIT = 0 + N = 1 + CALL USRTPL(LUN,N,N) + DO WHILE (N+1.LE.NVAL(LUN)) + N = N+1 + NODE = INV(N,LUN) + MBIT = MBIT+NBIT + NBIT = IBT(NODE) + IF(ITP(NODE).EQ.1) THEN + CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) + CALL USRTPL(LUN,N,IVAL) + ELSEIF(CTAG.EQ.TAG(NODE)) THEN + ITAGCT = ITAGCT + 1 + IF(ITAGCT.EQ.IOID) THEN + IF(ITP(NODE).NE.3) GOTO 904 + NCHR = NBIT/8 + IBIT = MBIT + DO J=1,NCHR + CALL PKC(' ',1,MBAY(1,LUN),IBIT) + ENDDO + CALL PKC(CHR,NCHR,MBAY(1,LUN),MBIT) + CALL USRTPL(LUN,1,1) + GOTO 100 + ENDIF + ENDIF + ENDDO + GOTO 906 + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') +903 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// + . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'// + . ',")")') STR,NTG + CALL BORT(BORT_STR) +904 WRITE(BORT_STR,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '// + . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') TGS(1),TYP(NODE) + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '// + . ' SUBSET NO. (",I3,") IN MSG .NE. THE STORED VALUE FOR THE NO.'// + . ' OF SUBSETS (",I3,") IN MSG")') NSUBS,NSUB(LUN) + CALL BORT(BORT_STR) +906 WRITE(BORT_STR,'("BUFRLB: WRITLC - UNABLE TO FIND ",A," IN '// + . 'SUBSET")') TGS(1) + CALL BORT(BORT_STR) + END diff --git a/src/bufr/writsa.f b/src/bufr/writsa.f new file mode 100644 index 0000000000..2f253501e7 --- /dev/null +++ b/src/bufr/writsa.f @@ -0,0 +1,180 @@ + SUBROUTINE WRITSA(LUNXX,LMSGT,MSGT,MSGL) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRITSA +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C ABS(LUNXX) HAS BEEN OPENED FOR OUTPUT OPERATIONS. +C +C WHEN LUNXX IS GREATER THAN ZERO, IT PACKS UP THE CURRENT SUBSET +C WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE BUFR MESSAGE THAT IS +C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNXX). THE DETERMINATION AS +C TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO THE MESSAGE IS MADE +C VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE LIBRARY SUBROUTINES +C WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT THE MESSAGE IS +C COMPRESSED. IF IT TURNS OUT THAT THE SUBSET CANNOT BE ADDED TO THE +C CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO ABS(LUNXX) +C AND A NEW ONE IS CREATED IN ORDER TO HOLD THE SUBSET. AS LONG AS +C LUNXX IS GREATER THAN ZERO, WRITSA FUNCTIONS EXACTLY LIKE BUFR +C ARCHIVE LIBRARY SUBROUTINE WRITSB, EXCEPT THAT WRITSA ALSO RETURNS +C A COPY OF EACH COMPLETED BUFR MESSAGE TO THE APPLICATION PROGRAM +C IN THE FIRST MSGL WORDS OF ARRAY MSGT. +C +C ALTERNATIVELY, WHEN LUNXX IS LESS THAN ZERO, THIS IS A SIGNAL TO +C FORCE ANY CURRENT MESSAGE IN MEMORY TO BE FLUSHED TO ABS(LUNXX) AND +C RETURNED IN ARRAY MSGT. IN SUCH CASES, ANY CURRENT SUBSET IN MEMORY +C IS IGNORED. THIS OPTION IS NECESSARY BECAUSE ANY MESSAGE RETURNED +C IN MSGT FROM A CALL TO THIS ROUTINE NEVER CONTAINS THE ACTUAL SUBSET +C THAT WAS PACKED UP AND STORED DURING THE SAME CALL TO THIS ROUTINE. +C THEREFORE, THE ONLY WAY TO ENSURE THAT EVERY LAST BUFR SUBSET IS +C RETURNED WITHIN A BUFR MESSAGE IN MSGT BEFORE, E.G., EXITING THE +C APPLICATION PROGRAM, IS TO DO ONE FINAL CALL TO THIS ROUTINE WITH +C LUNXX LESS THAN ZERO IN ORDER TO FORCIBLY FLUSH OUT AND RETURN ONE +C FINAL BUFR MESSAGE. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED +C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS +C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE +C TERMINATES ABNORMALLY +C 2004-08-18 J. ATOR -- ADD POST-MSGUPD CHECK FOR AND RETURN OF +C MESSAGE WITHIN MSGT IN ORDER TO PREVENT +C LOSS OF MESSAGE IN CERTAIN SITUATIONS; +C MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2005-03-09 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES +C 2009-03-23 J. ATOR -- ADDED LMSGT ARGUMENT AND CHECK +C +C USAGE: CALL WRITSA (LUNXX, LMSGT, MSGT, MSGL) +C INPUT ARGUMENT LIST: +C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER +C FOR BUFR FILE {IF LUNXX IS LESS THAN ZERO, THEN ANY +C CURRENT MESSAGE IN MEMORY WILL BE FORCIBLY FLUSHED TO +C ABS(LUNXX) AND TO ARRAY MSGT} +C LMSGT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGT; +C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT +C OVERFLOW THE MSGT ARRAY +C +C OUTPUT ARGUMENT LIST: +C MSGT - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR +C MESSAGE (FIRST MSGL WORDS FILLED) +C MSGL - INTEGER: NUMBER OF WORDS FILLED IN MSGT +C 0 = no message was returned +C +C REMARKS: +C THIS ROUTINE CALLS: BORT CLOSMG MSGUPD STATUS +C WRCMPS WRTREE +C THIS ROUTINE IS CALLED BY: None +C Normally called only by application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) + COMMON /MSGCMP/ CCMF + + CHARACTER*1 CCMF + + DIMENSION MSGT(*) + +C---------------------------------------------------------------------- +C---------------------------------------------------------------------- + + LUNIT = ABS(LUNXX) + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C IF LUNXX < 0, FORCE MEMORY MSG TO BE WRITTEN (W/O ANY CURRENT SUBSET) +C --------------------------------------------------------------------- + + IF(LUNXX.LT.0) CALL CLOSMG(LUNIT) + +C IS THERE A COMPLETED BUFR MESSAGE TO BE RETURNED? +C ------------------------------------------------- + + IF(MSGLEN.GT.0) THEN + IF(MSGLEN.GT.LMSGT) GOTO 904 + MSGL = MSGLEN + DO N=1,MSGL + MSGT(N) = MSGTXT(N) + ENDDO + MSGLEN = 0 + ELSE + MSGL = 0 + ENDIF + + IF(LUNXX.LT.0) GOTO 100 + +C PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE +C ---------------------------------------------- + + CALL WRTREE(LUN) + IF( CCMF.EQ.'Y' ) THEN + CALL WRCMPS(LUNIT) + ELSE + CALL MSGUPD(LUNIT,LUN) + ENDIF + +C IF THE JUST-COMPLETED CALL TO WRCMPS OR MSGUPD FOR THIS SUBSET CAUSED +C A PREVIOUS MESSAGE TO BE FLUSHED TO ABS(LUNXX), THEN RETRIEVE AND +C RETURN THAT MESSAGE NOW. OTHERWISE, WE RUN THE RISK THAT THE NEXT +C CALL TO OPENMB OR OPENMG MIGHT CAUSE A NEWER MESSAGE (WHICH WOULD +C CONTAIN THE CURRENT SUBSET!) TO BE FLUSHED AND THUS OVERWRITE THE +C PREVIOUS MESSAGE WITHIN ARRAY MSGTXT BEFORE WE HAD THE CHANCE TO +C RETRIEVE IT DURING THE NEXT CALL TO WRITSA! + +C NOTE ALSO THAT, IF THE MOST RECENT CALL TO OPENMB OR OPENMG HAD +C CAUSED A MESSAGE TO BE FLUSHED, IT WOULD HAVE DONE SO IN ORDER TO +C CREATE A NEW MESSAGE TO HOLD THE CURRENT SUBSET. THUS, IN SUCH +C CASES, IT SHOULD NOT BE POSSIBLE THAT THE JUST-COMPLETED CALL TO +C WRCMPS OR MSGUPD (FOR THIS SAME SUBSET!) WOULD HAVE ALSO CAUSED A +C MESSAGE TO BE FLUSHED, AND THUS IT SHOULD NOT BE POSSIBLE TO HAVE +C TWO (2) SEPARATE BUFR MESSAGES RETURNED FROM ONE (1) CALL TO WRITSA! + + IF(MSGLEN.GT.0) THEN + IF(MSGL.NE.0) GOTO 903 + IF(MSGLEN.GT.LMSGT) GOTO 904 + MSGL = MSGLEN + DO N=1,MSGL + MSGT(N) = MSGTXT(N) + ENDDO + MSGLEN = 0 + ENDIF + +C EXITS +C ----- + +100 RETURN +900 CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') +903 CALL BORT('BUFRLIB: WRITSA - TWO BUFR MESSAGES WERE RETRIEVED '// + . 'BY ONE CALL TO THIS ROUTINE') +904 CALL BORT('BUFRLIB: WRITSA - OVERFLOW OF OUTPUT BUFR MESSAGE '// + . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + END diff --git a/src/bufr/writsb.f b/src/bufr/writsb.f new file mode 100644 index 0000000000..af65d83520 --- /dev/null +++ b/src/bufr/writsb.f @@ -0,0 +1,85 @@ + SUBROUTINE WRITSB(LUNIT) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRITSB +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT +C LUNIT HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT PACKS UP THE +C CURRENT SUBSET WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE +C BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT. +C THE DETERMINATION AS TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO +C THE MESSAGE IS MADE VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE +C LIBRARY SUBROUTINES WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT +C THE MESSAGE IS COMPRESSED. IF IT TURNS OUT THAT THE SUBSET CANNOT +C BE ADDED TO THE CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS +C FLUSHED TO LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE +C SUBSET. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C 2005-03-09 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES +C +C USAGE: CALL WRITSB (LUNIT) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C +C REMARKS: +C THIS ROUTINE CALLS: BORT MSGUPD STATUS WRCMPS +C WRTREE +C THIS ROUTINE IS CALLED BY: COPYSB WRITCP +C Also called by application programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + COMMON /MSGCMP/ CCMF + + CHARACTER*1 CCMF + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK THE FILE STATUS +C --------------------- + + CALL STATUS(LUNIT,LUN,IL,IM) + IF(IL.EQ.0) GOTO 900 + IF(IL.LT.0) GOTO 901 + IF(IM.EQ.0) GOTO 902 + +C PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE +C ---------------------------------------------- + + CALL WRTREE(LUN) + IF( CCMF.EQ.'Y' ) THEN + CALL WRCMPS(LUNIT) + ELSE + CALL MSGUPD(LUNIT,LUN) + ENDIF + +C EXITS +C ----- + + RETURN +900 CALL BORT('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS CLOSED, IT '// + . 'MUST BE OPEN FOR OUTPUT') +901 CALL BORT('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS OPEN FOR '// + . 'INPUT, IT MUST BE OPEN FOR OUTPUT') +902 CALL BORT('BUFRLIB: WRITSB - A MESSAGE MUST BE OPEN IN OUTPUT '// + . 'BUFR FILE, NONE ARE') + END diff --git a/src/bufr/wrtree.f b/src/bufr/wrtree.f new file mode 100644 index 0000000000..caf7deb207 --- /dev/null +++ b/src/bufr/wrtree.f @@ -0,0 +1,155 @@ + SUBROUTINE WRTREE(LUN) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRTREE +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS +C AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- CORRECTED SOME MINOR ERRORS +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 10,000 TO 20,000 BYTES +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) +C INCREASED FROM 15000 TO 16000 (WAS IN +C VERIFICATION VERSION); UNIFIED/PORTABLE FOR +C WRF; ADDED DOCUMENTATION (INCLUDING +C HISTORY); REPL. "IVAL(N)=ANINT(PKS(NODE))" +C WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER +C CAUSED PROBLEMS ON SOME FOREIGN MACHINES) +C 2004-03-10 J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8 +C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM +C 20,000 TO 50,000 BYTES +C 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER +C THAN 8 CHARACTERS; USE FUNCTION IBFMS +C 2009-08-03 J. WOOLLEN -- ADDED CAPABILITY TO COPY LONG STRINGS VIA +C UFBCPY USING FILE POINTER STORED IN NEW +C COMMON UFBCPL +C 2012-03-02 J. ATOR -- USE IPKS TO HANDLE 2-03 OPERATOR CASES +C 2012-06-04 J. ATOR -- ENSURE "MISSING" CHARACTER FIELDS ARE +C PROPERLY ENCODED WITH ALL BITS SET TO 1 +C +C USAGE: CALL WRTREE (LUN) +C INPUT ARGUMENT LIST: +C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS +C +C REMARKS: +C THIS ROUTINE CALLS: IBFMS IPKM PKB PKC +C IPKS READLC +C THIS ROUTINE IS CALLED BY: WRITSA WRITSB +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), + . MBAY(MXMSGLD4,NFILES) + COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), + . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), + . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), + . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), + . ISEQ(MAXJL,2),JSEQ(MAXJL) + COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) + COMMON /UFBCPL/ LUNCPY(NFILES) + + CHARACTER*120 LSTR + CHARACTER*10 TAG + CHARACTER*8 CVAL + CHARACTER*3 TYP + DIMENSION IVAL(MAXSS) + EQUIVALENCE (CVAL,RVAL) + REAL*8 VAL,RVAL + +C----------------------------------------------------------------------- + +C CONVERT USER NUMBERS INTO SCALED INTEGERS +C ----------------------------------------- + + DO N=1,NVAL(LUN) + NODE = INV(N,LUN) + IF(ITP(NODE).EQ.1) THEN + IVAL(N) = VAL(N,LUN) + ELSEIF(TYP(NODE).EQ.'NUM') THEN + IF(IBFMS(VAL(N,LUN)).EQ.0) THEN + IVAL(N) = IPKS(VAL(N,LUN),NODE) + ELSE + IVAL(N) = -1 + ENDIF + ENDIF + ENDDO + +C PACK THE USER ARRAY INTO THE SUBSET BUFFER +C ------------------------------------------ + + IBIT = 16 + + DO N=1,NVAL(LUN) + NODE = INV(N,LUN) + IF(ITP(NODE).LT.3) THEN + +C The value to be packed is numeric. + + CALL PKB(IVAL(N),IBT(NODE),IBAY,IBIT) + ELSE + +C The value to be packed is a character string. + + NCR=IBT(NODE)/8 + IF ( NCR.GT.8 .AND. LUNCPY(LUN).NE.0 ) THEN + +C The string is longer than 8 characters and there was a +C preceeding call to UFBCPY involving this output unit, so +C read the long string with READLC and write it into the +C output buffer using PKC. + + CALL READLC(LUNCPY(LUN),LSTR,TAG(NODE)) + CALL PKC(LSTR,NCR,IBAY,IBIT) + ELSE + RVAL = VAL(N,LUN) + IF(IBFMS(RVAL).NE.0) THEN + +C The value is "missing", so set all bits to 1 before +C packing the field as a character string. + + NUMCHR = MIN(NCR,LEN(LSTR)) + DO JJ = 1, NUMCHR + CALL IPKM(LSTR(JJ:JJ),1,255) + ENDDO + CALL PKC(LSTR,NUMCHR,IBAY,IBIT) + ELSE + +C The value is not "missing", so pack the equivalenced +C character string. Note that a maximum of 8 characters +C will be packed here, so a separate subsequent call to +C BUFR archive library subroutine WRITLC will be needed to +C fully encode any string longer than 8 characters. + + CALL PKC(CVAL,NCR,IBAY,IBIT) + ENDIF + ENDIF + + ENDIF + ENDDO + +C RESET UFBCPY FILE POINTER +C ------------------------- + + LUNCPY(LUN)=0 + + RETURN + END diff --git a/src/bufr/wtstat.f b/src/bufr/wtstat.f new file mode 100644 index 0000000000..6fb685af2a --- /dev/null +++ b/src/bufr/wtstat.f @@ -0,0 +1,121 @@ + SUBROUTINE WTSTAT(LUNIT,LUN,IL,IM) + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WTSTAT +C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 +C +C ABSTRACT: THIS SUBROUTINE EITHER DISCONNECTS THE INPUT LOGICAL UNIT +C NUMBER LUNIT (AND ITS ASSOCIATED BUFR FILE) FROM THE BUFR ARCHIVE +C LIBRARY SOFTWARE OR IT CONNECTS IT AS EITHER AN INPUT OR OUPUT FILE +C AND DEFINES A BUFR MESSAGE AS BEING EITHER OPENED OR CLOSED IN +C MEMORY FOR THE BUFR FILE IN LUNIT. THIS INFORMATION IS STORED IN +C THE INTERNAL ARRAYS IOLUN AND IOMSG IN COMMON BLOCK /STBFR/. +C +C PROGRAM HISTORY LOG: +C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR +C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE +C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB +C ROUTINE "BORT" +C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE +C OPENED AT ONE TIME INCREASED FROM 10 TO 32 +C (NECESSARY IN ORDER TO PROCESS MULTIPLE +C BUFR FILES UNDER THE MPI) +C 2003-11-04 J. ATOR -- CORRECTED A "TYPO" IN TEST FOR VALID VALUE +C FOR "IM"; ADDED DOCUMENTATION +C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE +C INTERDEPENDENCIES +C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY +C DOCUMENTATION; OUTPUTS MORE COMPLETE +C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES +C ABNORMALLY +C +C USAGE: CALL WTSTAT (LUNIT, LUN, IL, IM) +C INPUT ARGUMENT LIST: +C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE +C LUN - INTEGER: I/O STREAM INDEX ASSOCIATED WITH LOGICAL UNIT +C LUNIT +C IL - INTEGER: LOGICAL UNIT STATUS INDICATOR: +C 0 = disconnect LUNIT w.r.t. BUFR Archive +C Library software (all information +C associated with LUNIT is deleted from +C within internal arrays) +C 1 = connect LUNIT as an output file w.r.t. to +C BUFR Archive Library software +C -1 = connect LUNIT as an input file w.r.t. to +C BUFR Archive Library software +C IM - INTEGER: DEFINES WHETHER THERE IS A BUFR MESSAGE +C CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT (IF IT IS +C CONNECTED, I.E., IL .NE. ZERO): +C 0 = no +C 1 = yes +C +C REMARKS: +C THIS ROUTINE CALLS: BORT +C THIS ROUTINE IS CALLED BY: CLOSBF CLOSMG OPENBF OPENMB +C OPENMG RDMEMM READERME REWNBF +C READMG +C Normally not called by any application +C programs. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: PORTABLE TO ALL PLATFORMS +C +C$$$ + + INCLUDE 'bufrlib.prm' + + COMMON /STBFR/ IOLUN(NFILES),IOMSG(NFILES) + + CHARACTER*128 BORT_STR + +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + +C CHECK ON THE ARGUMENTS +C ---------------------- + + IF(LUNIT.LE.0) GOTO 900 + IF(LUN .LE.0) GOTO 901 + IF(IL.LT.-1 .OR. IL.GT.1) GOTO 902 + IF(IM.LT. 0 .OR. IM.GT.1) GOTO 903 + +C CHECK ON LUNIT-LUN COMBINATION +C ------------------------------ + + IF(ABS(IOLUN(LUN)).NE.LUNIT) THEN + IF(IOLUN(LUN).NE.0) GOTO 905 + ENDIF + +C RESET THE FILE STATUSES +C ----------------------- + + IF(IL.NE.0) THEN + IOLUN(LUN) = SIGN(LUNIT,IL) + IOMSG(LUN) = IM + ELSE + IOLUN(LUN) = 0 + IOMSG(LUN) = 0 + ENDIF + +C EXITS +C ----- + + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED '// + . ' INTO FIRST ARGUMENT (INPUT) (=",I3,")")') LUNIT + CALL BORT(BORT_STR) +901 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID I/O STREAM INDEX '// + . 'PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') LUN + CALL BORT(BORT_STR) +902 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS'// + . ' INDICATOR PASSED INTO THIRD ARGUMENT (INPUT) (=",I4,")")') IL + CALL BORT(BORT_STR) +903 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS'// + . ' INDICATOR PASSED INTO FOURTH ARGUMENT (INPUT) (=",I4,")")') IM + CALL BORT(BORT_STR) +905 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE '// + . 'EXISTING FILE UNIT (LOGICAL UNIT NUMBER ",I3,")")') IOLUN(LUN) + CALL BORT(BORT_STR) + END diff --git a/src/enkf/gridio_wrf.f90 b/src/enkf/gridio_wrf.f90 index 6eabcd256f..2717b1e0b6 100644 --- a/src/enkf/gridio_wrf.f90 +++ b/src/enkf/gridio_wrf.f90 @@ -45,8 +45,8 @@ module gridio !------------------------------------------------------------------------- ! Define all public subroutines within this module private - public :: readgriddata - public :: writegriddata + public :: readgriddata, readgriddata_pnc + public :: writegriddata, writegriddata_pnc, WRITEINCREMENT, WRITEINCREMENT_PNC !------------------------------------------------------------------------- @@ -1347,4 +1347,57 @@ subroutine readpressure_arw(filename, znu, znw, mu, mub, ptop) end subroutine readpressure_arw + subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use constants, only: max_varname_length + use params, only: nbackgrounds + implicit none + integer, intent(in) :: nanal1,nanal2 + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + end subroutine writeincrement + + subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use constants, only: max_varname_length + use params, only: nbackgrounds + implicit none + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + end subroutine writeincrement_pnc + + subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & + fileprefixes,filesfcprefixes,reducedgrid,grdin,qsat) + use constants, only: max_varname_length + implicit none + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d, n3d + integer, dimension(0:n3d), intent(in) :: levels + integer, intent(in) :: ndim, ntimes + character(len=120), dimension(7), intent(in) :: fileprefixes + character(len=120), dimension(7), intent(in) :: filesfcprefixes + logical, intent(in) :: reducedgrid + real(r_single), dimension(npts,ndim,ntimes,1), intent(out) :: grdin + real(r_double), dimension(npts,nlevs,ntimes,1), intent(out) :: qsat + end subroutine readgriddata_pnc + + subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + use constants, only: max_varname_length + use params, only: nbackgrounds + implicit none + character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d + character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d + integer, intent(in) :: n2d,n3d,ndim + integer, dimension(0:n3d), intent(in) :: levels + real(r_single), dimension(npts,ndim,nbackgrounds,1), intent(inout) :: grdin + logical, intent(in) :: no_inflate_flag + end subroutine writegriddata_pnc + end module gridio diff --git a/src/gsi/.CMakeLists.txt.swp b/src/gsi/.CMakeLists.txt.swp new file mode 100644 index 0000000000000000000000000000000000000000..0159a8f5a989dc0467b329ac421a6265fb0b4394 GIT binary patch literal 16384 zcmeHNPmJSM8F#x-SYQhjkSG%DBeT%VFinQtvSpDd^*GK<*h~_fWV#C#uE%*v%sNi6 zot+u2M!P^I)B^{~g`zHk3j%}$stOmx38~_SsMIa$a^i%<1ynAj2l#!@&xw=CWM;}1 zfn-ZR&DehLd+&Y!zt7oP*(`0ahjR}pxZa~EwST<)<@;BL*J||BvhcKfPN~z72dGcmmi2P5`&=Rg`CeA@B%r8u;@mMR^YJ z0Ts9lP=H^(OHsZBTm!1W8Gr$&ftTKicfg~--`}AqKLWl7JOg|axD4a~1-NxmQCz5u+6X36(~n}7>k0qVd9 zfuEw$@)Mu|ycZz8zY;fFaNIk1F=n+|rt56^mcN@la}7VVsIRMrUMQDV_gKB5HcA>3 zkDHBB*{mDd9$Qox3wW4Kj%6AAGy`PJpzF8JTx;>IVaE)H?Y6VCmtmT!t?R5*Y3N2p zEwfB!QCVp5w&QUYb~*E`9%sXVw^+OHGmvHVuI1wv1exWvXphVZ*|rmQ*}(4)xF0$^ z5U(81c84v_T8Ts|Y%(Bna1b$B*|`SH?><}u7WkR~0UsW=lI zK0d&}3cKP2#9Cs4*fJOnO1LXljYhNcBo-F(a_k_k-g(B~be z?^$jhFAvx!i`ZJx3MF+-*dK$7Af6cdMs*Vg-q1IajA5C1JojvP39Dmn`%cKsUcZ%V zUs#Fk`i{``xz(B^3n@*XVS)L)*T2eHbgE@Yl3bkw@5V^G`X2W}wl#Fz5M1f;?JoB@ z<8HunB)~{?!p27`Ep$aZ8d<1(bg=#f;c(0Jf>3hd(DAeMmEoGl@8p~b4U!WllxR}- z=Smrx)bX9xm|X#$7!g;svRbc`Y6?XGuU#udV2SNYgpgQ!mzfoSh}U*HL*LqRIer1f zh9SZlMVn<|@IA}%7-Ex@8X}h8?};})4?@;&Ppa+$v)UotgXOwo$|3ZewfF$WN3ym1 z2wz!}Eh8z2E!hLtUtDHeR=}CduW}bVNf>;j9>f${k%&td%OJlYBETq++I{TR=?z@o z!&(+C9V{mm=U|n%;&`nK&w9GnUwI=z<@Y%}Y z|0s>2%pmOg{b8p&$@66v4DBun87^jdWNlJ(bT!7%eW+0Ayo^Y9MScgIFUT#%#;OcEv)_CFB$Rm>#q!-rzFZ?m9Skq;Ubu!UG57 zexXn?Cl6OBaBXR^m~cY}YZHwBs8Xk)Ff;PT&=4u}*t=ohlo8^j;@~3rlU9iH zBxDpFFrGGfz{py9jFy2gVA_J5NI~(hOie*gzocuzT!PStRI_kf`Xxl0T3OX}ma$zc z2r~E!b48Xb9hitZvESLtEHZ4xhO|QtpPn>Y7$>|2Tzrc(Mi7&s8ONTxAUTT6*o#q^ zJN|;g+eE1V6YFLvVPPXmbDg=^?b3x6L?F0dWJFU(14l+@p*14fU}=*=Fue@vVWi$0)j|`Avq7!r0^xMd>8gU{|>xPy{-cJD)qNMCpuc~7Pt?19d-U~;6>m!z)j$3U>E2CXMrs60PqrO z{}+HR@EU6UUjt78RQvxP^*#sA03QPG2krrWj5>b@co_IF@K@CM&ja58bl^5>`lo=? zzz2Z$1OGxD|2u$c{I3BwfFh(52 zeE1lUUMUC09H3-|F4fT1OPe}FXQ5H5pn(E2irqx1f|g3TY}O3DSh}>AN5+y5C@r(2 zM4skHvHtQ==PNXaE~8m#ls1mG?v~>z)GNW-uA6PB#+u%cO#ljcdw40YsC`f_$l4vv z6H$Gcql|<)By078R<1S+^66!I_C<`C9JTGYab9|-UuqaCUREyZM$~|q?z4=^j~RoB zWwoYi7n5WkEa&nEQd}<-Kb0H|F*J?x)D!9qjh6#0k#SL}*_hyi>>7=Rn#f>j+tbhK znOHb(d#q2bnCuIUsO>TEJhXg-Qncf|E3zj??JFSyAr??Zj7v1=#64)xn$vHP=IM=R4dUhN2Rh3|7Wr?n=tJ2xHDJbIgQIvZ%meWB4rxc$N_y`7=d6) zt+`r8=lVz#XYW0-sEF9OYkEiaK4srCY**+M){ct4y?F+6pbm^!HFLQ+(?~%g*C4+L zh_T6U0b+ZjZvjz_HsNkWi=WhuvgSx8qb~$eEAlAc2#5e}X6%P#J3HYF;{q>gT8|c_ z5hQ)Ay{gvry{Y9QZ`mwT5Z?cJ0+X0N@_np=&l5uVU0_k31J|Z% Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif +#endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +ENDIF + return diff --git a/src/wrflib/ext_ncd_get_var_td.code b/src/wrflib/ext_ncd_get_var_td.code new file mode 100644 index 0000000000..bd28dc38a3 --- /dev/null +++ b/src/wrflib/ext_ncd_get_var_td.code @@ -0,0 +1,227 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + TYPE_DATA + TYPE_COUNT + TYPE_OUTCOUNT + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + TYPE_BUFFER ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_VARID(NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_TYPE) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) & +'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = LENGTH + VCount(2) = 1 +#ifndef CHAR_TYPE + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_ROUTINE (NCID,VarID,VStart,VCount,Buffer) +#else + if(Len1 > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) & +'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = '' + stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif +#ifndef CHAR_TYPE + COPY + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif +#endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return diff --git a/src/wrflib/ext_ncd_get_var_ti.code b/src/wrflib/ext_ncd_get_var_ti.code new file mode 100644 index 0000000000..47a161ba99 --- /dev/null +++ b/src/wrflib/ext_ncd_get_var_ti.code @@ -0,0 +1,174 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + TYPE_DATA + TYPE_COUNT + TYPE_OUTCOUNT + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + TYPE_BUFFER + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_TYPE) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif +#ifndef CHAR_TYPE + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) +#else + if(XLen > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) & +'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + COPY +#ifndef CHAR_TYPE + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif +#endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return diff --git a/src/wrflib/ext_ncd_put_dom_ti.code b/src/wrflib/ext_ncd_put_dom_ti.code new file mode 100644 index 0000000000..2d5b1a3e9e --- /dev/null +++ b/src/wrflib/ext_ncd_put_dom_ti.code @@ -0,0 +1,164 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + TYPE_DATA + TYPE_COUNT + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to write time-independent domain metadata. +IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then +#ifdef LOG + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) + deallocate(Buffer, STAT=stat2) + if(stat2/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#else + stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif +#ifdef LOG + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) + deallocate(Buffer, STAT=stat2) + if(stat2/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#else + stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +ENDIF + return diff --git a/src/wrflib/ext_ncd_put_var_td.code b/src/wrflib/ext_ncd_put_var_td.code new file mode 100644 index 0000000000..750e1ecd37 --- /dev/null +++ b/src/wrflib/ext_ncd_put_var_td.code @@ -0,0 +1,233 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + TYPE_DATA + TYPE_COUNT + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(LENGTH < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%MDVarNames(NVar) == NO_NAME) then + DH%MDVarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == LENGTH) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),LENGTH,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = LENGTH + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) & +'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%MDVarDimLens(NVar) = LENGTH + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + stat = NF_DEF_VAR(NCID,Name,NF_TYPE,2,VDims,DH%MDVarIDs(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + exit + elseif(DH%MDVarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) & +'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(LENGTH > DH%MDVarDimLens(NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) & +'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(LENGTH < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) & +'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = LENGTH + VCount(2) = 1 +#ifdef LOG + allocate(Buffer(LENGTH), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) + deallocate(Buffer, STAT=stat2) + if(stat2/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#else + stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return diff --git a/src/wrflib/ext_ncd_put_var_ti.code b/src/wrflib/ext_ncd_put_var_ti.code new file mode 100644 index 0000000000..05bfc64ca3 --- /dev/null +++ b/src/wrflib/ext_ncd_put_var_ti.code @@ -0,0 +1,144 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + TYPE_DATA + TYPE_COUNT + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) & +'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo +#ifdef LOG + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo +#endif +#ifdef CHAR_TYPE + if(len_trim(Data).le.0) then + stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) + else + stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) + endif +#else + stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif +#ifdef LOG + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return diff --git a/src/wrflib/field_routines.F90 b/src/wrflib/field_routines.F90 new file mode 100644 index 0000000000..cd9bcfa7bf --- /dev/null +++ b/src/wrflib/field_routines.F90 @@ -0,0 +1,175 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- +subroutine ext_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: NCID + integer ,intent(in) :: VarID + integer ,dimension(NVarDims),intent(in) :: VStart + integer ,dimension(NVarDims),intent(in) :: VCount + real, dimension(*) ,intent(inout) :: Data + integer ,intent(out) :: Status + integer :: stat + + if(IO == 'write') then + stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data) + else + stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + return +end subroutine ext_ncd_RealFieldIO + +subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: NCID + integer ,intent(in) :: VarID + integer ,dimension(NVarDims),intent(in) :: VStart + integer ,dimension(NVarDims),intent(in) :: VCount + real*8 ,intent(inout) :: Data + integer ,intent(out) :: Status + integer :: stat + + if(IO == 'write') then + stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) + else + stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + return +end subroutine ext_ncd_DoubleFieldIO + +subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: NCID + integer ,intent(in) :: VarID + integer ,dimension(NVarDims),intent(in) :: VStart + integer ,dimension(NVarDims),intent(in) :: VCount + integer ,intent(inout) :: Data + integer ,intent(out) :: Status + integer :: stat + + if(IO == 'write') then + stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data) + else + stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + return +end subroutine ext_ncd_IntFieldIO + +subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: NCID + integer ,intent(in) :: VarID + integer,dimension(NVarDims) ,intent(in) :: VStart + integer,dimension(NVarDims) ,intent(in) :: VCount + logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data + integer ,intent(out) :: Status + integer,dimension(:,:,:),allocatable :: Buffer + integer :: stat + integer :: i,j,k + + allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(IO == 'write') then + do k=1,VCount(3) + do j=1,VCount(2) + do i=1,VCount(1) + if(data(i,j,k)) then + Buffer(i,j,k)=1 + else + Buffer(i,j,k)=0 + endif + enddo + enddo + enddo + stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer) + else + stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer) + Data = Buffer == 1 + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_LogicalFieldIO diff --git a/src/wrflib/io_int_stubs.f90 b/src/wrflib/io_int_stubs.f90 new file mode 100755 index 0000000000..83c580a57d --- /dev/null +++ b/src/wrflib/io_int_stubs.f90 @@ -0,0 +1,157 @@ +! Stubs version of wrf io spi subroutines +! +!--- get_dom_ti_real +SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: Element + REAL , INTENT(INOUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(INOUT) :: Outcount + INTEGER , INTENT(INOUT) :: Status + + write(6,*) 'Calling dummy 1' +RETURN +END SUBROUTINE ext_int_get_dom_ti_real + + +SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) + + write(6,*) 'Calling dummy 2' +RETURN +END SUBROUTINE ext_int_get_dom_ti_integer + + +!--- get_dom_ti_char +SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element, Data, Status ) + write(6,*) 'Calling dummy 3' + +RETURN +END SUBROUTINE ext_int_get_dom_ti_char + + +!--- get_var_info +SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & + DomainStart , DomainEnd , WrfType, Status ) + + write(6,*) 'Calling dummy 4' +RETURN +END SUBROUTINE ext_int_get_var_info + + +!--- read_field +SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + write(6,*) 'Calling dummy 5' + RETURN + +END SUBROUTINE ext_int_read_field + + +!--- close +SUBROUTINE ext_int_ioclose ( DataHandle, Status ) + + write(6,*) 'Calling dummy 6' + RETURN +END SUBROUTINE ext_int_ioclose + + +!--- initialize +SUBROUTINE ext_int_ioinit( SysDepInfo, Status ) + + write(6,*) 'Calling dummy 7' +END SUBROUTINE ext_int_ioinit + + + +!--- open_for_read +SUBROUTINE ext_int_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) + + write(6,*) 'Calling dummy 8' + RETURN +END SUBROUTINE ext_int_open_for_read + + + +!SUBROUTINE int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & +! DataHandle, Data, Count, code ) + +! write(6,*) 'Calling dummy 9' +!RETURN +!END SUBROUTINE int_get_ti_header_c + + +! NETCDF STUBS +!SUBROUTINE ext_ncd_ioinit(SysDepInfo, Status) + +!RETURN +!END SUBROUTINE ext_ncd_ioinit + + +!subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) + +!RETURN +!END subroutine ext_ncd_open_for_read + + +!subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) + +!RETURN +!END subroutine ext_ncd_get_dom_ti_integer + + +!subroutine ext_ncd_ioclose(DataHandle, Status) + +! return +!end subroutine ext_ncd_ioclose + + +!subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) + +! return +!end subroutine ext_ncd_get_dom_ti_char + + +!subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,Status) + +! return +!end subroutine ext_ncd_get_dom_ti_real + + +!subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder, & +! Stagger,DomainStart,DomainEnd,WrfType,Status) + +! return +!end subroutine ext_ncd_get_var_info + + +!subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & +! IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & +! DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) + +! return +!end subroutine ext_ncd_read_field + + +!subroutine wrf_error_fatal(massage) + +!stop +!end subroutine wrf_error_fatal + + +!subroutine int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & +! DataHandle, Data, Count, code ) +! write(6,*) 'Calling dummy 10' +!RETURN +!END SUBROUTINE int_gen_ti_header_c + + + + + + + diff --git a/src/wrflib/model_data_order.inc b/src/wrflib/model_data_order.inc new file mode 100644 index 0000000000..91a5098b8f --- /dev/null +++ b/src/wrflib/model_data_order.inc @@ -0,0 +1,8 @@ +!STARTOFREGISTRYGENERATEDINCLUDE 'inc/model_data_order.inc' +! +! WARNING This file is generated automatically by use_registry +! using the data base in the file named Registry. +! Do not edit. Your changes to this file will be lost. +! +INTEGER , PARAMETER :: model_data_order = DATA_ORDER_XZY +!ENDOFREGISTRYGENERATEDINCLUDE diff --git a/src/wrflib/module_driver_constants.F90 b/src/wrflib/module_driver_constants.F90 new file mode 100644 index 0000000000..e5e7f71872 --- /dev/null +++ b/src/wrflib/module_driver_constants.F90 @@ -0,0 +1,180 @@ +!WRF:DRIVER_LAYER:CONSTANTS +! +! This MODULE contains all of the constants used in the model. These +! are separated by usage within the code. + +#define MAX_DOMAINS_F 21 +# define IWORDSIZE 4 +# define DWORDSIZE 8 +# define RWORDSIZE 4 +# define LWORDSIZE 4 + +MODULE module_driver_constants + + ! 0. The following tells the rest of the model what data ordering we are + ! using + + INTEGER , PARAMETER :: DATA_ORDER_XYZ = 1 + INTEGER , PARAMETER :: DATA_ORDER_YXZ = 2 + INTEGER , PARAMETER :: DATA_ORDER_ZXY = 3 + INTEGER , PARAMETER :: DATA_ORDER_ZYX = 4 + INTEGER , PARAMETER :: DATA_ORDER_XZY = 5 + INTEGER , PARAMETER :: DATA_ORDER_YZX = 6 + INTEGER , PARAMETER :: DATA_ORDER_XY = DATA_ORDER_XYZ + INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ + + +#include "model_data_order.inc" + + ! 1. Following are constants for use in defining maximal values for array + ! definitions. + ! + + ! The maximum number of levels in the model is how deeply the domains may + ! be nested. + + INTEGER , PARAMETER :: max_levels = 20 + + ! The maximum number of nests that can depend on a single parent and other way round + + INTEGER , PARAMETER :: max_nests = 20 + + ! The maximum number of parents that a nest can have (simplified assumption -> one only) + + INTEGER , PARAMETER :: max_parents = 1 + + ! The maximum number of domains is how many grids the model will be running. + + INTEGER , PARAMETER :: max_domains = ( MAX_DOMAINS_F - 1 ) / 2 + 1 + + ! The maximum number of nest move specifications allowed in a namelist + + INTEGER , PARAMETER :: max_moves = 50 + + ! The maximum number of eta levels + !DJW 140701 Increased from 501 to 1001 since I can imagine using more than + !501 total vertical levels across multiple nested domains. Now that the + !code is modified to allow specification of all domains eta_levels using a + !array of length max_eta, this will need to be larger. I'll also add a check + !in module_initialize_real to ensure we don't exceed this value. + + INTEGER , PARAMETER :: max_eta = 1001 + + ! The maximum number of ocean levels in the 3d U Miami ocean. + + INTEGER , PARAMETER :: max_ocean = 501 + + ! The maximum number of pressure levels to interpolate to, for diagnostics + + INTEGER , PARAMETER :: max_plevs = 100 + + ! The maximum number of height levels to interpolate to, for diagnostics + + INTEGER , PARAMETER :: max_zlevs = 100 + + ! The maximum number of trackchem + + INTEGER , PARAMETER :: max_trackchem = 100 + + ! The maximum number of outer iterations (for DA minimisation) + + INTEGER , PARAMETER :: max_outer_iterations = 100 + + ! The maximum number of instruments (for radiance DA) + + INTEGER , PARAMETER :: max_instruments = 30 + + ! The maximum number of obs indexes (for conventional DA obs) + + INTEGER , PARAMETER :: num_ob_indexes = 28 + + + ! The maximum number of bogus storms + + INTEGER , PARAMETER :: max_bogus = 5 + + ! The maximum number of fields that can be sent or received in coupled mode + + INTEGER , PARAMETER :: max_cplfld = 20 + + ! The maximum number of domains used by the external model with which wrf is communicating in coupled mode + + INTEGER , PARAMETER :: max_extdomains = 5 + + ! 2. Following related to driver level data structures for DM_PARALLEL communications + +#ifdef DM_PARALLEL + INTEGER , PARAMETER :: max_comms = 1024 +#else + INTEGER , PARAMETER :: max_comms = 1 +#endif + + ! 3. Following is information related to the file I/O. + + ! These are the bounds of the available FORTRAN logical unit numbers for the file I/O. + ! Only logical unit numbers within these bounds will be chosen for I/O unit numbers. + + INTEGER , PARAMETER :: min_file_unit = 10 + INTEGER , PARAMETER :: max_file_unit = 99 + + ! 4. Unfortunately, the following definition is needed here (rather + ! than the more logical place in share/module_model_constants.F) + ! for the namelist reads in frame/module_configure.F, and for some + ! conversions in share/set_timekeeping.F + ! Actually, using it here will mean that we don't need to set it + ! in share/module_model_constants.F, since this file will be + ! included (USEd) in: + ! frame/module_configure.F + ! which will be USEd in: + ! share/module_bc.F + ! which will be USEd in: + ! phys/module_radiation_driver.F + ! which is the other important place for it to be, and where + ! it is passed as a subroutine parameter to any physics subroutine. + ! + ! P2SI is the number of SI seconds in an planetary solar day + ! divided by the number of SI seconds in an earth solar day +#if defined MARS + ! For Mars, P2SI = 88775.2/86400. + REAL , PARAMETER :: P2SI = 1.0274907 +#elif defined TITAN + ! For Titan, P2SI = 1378080.0/86400. + REAL , PARAMETER :: P2SI = 15.95 +#else + ! Default for Earth + REAL , PARAMETER :: P2SI = 1.0 +#endif + CONTAINS + SUBROUTINE init_module_driver_constants + END SUBROUTINE init_module_driver_constants + END MODULE module_driver_constants + +! routines that external packages can call to get at WRF stuff that isn't available +! through argument lists; since they are external we don't want them using WRF +! modules unnecessarily (complicates the build even more) + SUBROUTINE inquire_of_wrf_data_order_xyz( data_order ) + USE module_driver_constants, ONLY : DATA_ORDER_XYZ + IMPLICIT NONE + INTEGER, INTENT(OUT) :: data_order + data_order = DATA_ORDER_XYZ + END SUBROUTINE inquire_of_wrf_data_order_xyz + + SUBROUTINE inquire_of_wrf_data_order_xzy( data_order ) + USE module_driver_constants, ONLY : DATA_ORDER_XZY + IMPLICIT NONE + INTEGER, INTENT(OUT) :: data_order + data_order = DATA_ORDER_XZY + END SUBROUTINE inquire_of_wrf_data_order_xzy + + SUBROUTINE inquire_of_wrf_iwordsize( iwordsz ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: iwordsz + iwordsz = IWORDSIZE + END SUBROUTINE inquire_of_wrf_iwordsize + + SUBROUTINE inquire_of_wrf_rwordsize( rwordsz ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: rwordsz + rwordsz = RWORDSIZE + END SUBROUTINE inquire_of_wrf_rwordsize + diff --git a/src/wrflib/module_machine.F90 b/src/wrflib/module_machine.F90 new file mode 100644 index 0000000000..1888337f39 --- /dev/null +++ b/src/wrflib/module_machine.F90 @@ -0,0 +1,175 @@ +!WRF:DRIVER_LAYER:DECOMPOSITION +! +# define IWORDSIZE 4 +# define DWORDSIZE 8 +# define RWORDSIZE 4 +# define LWORDSIZE 4 + +MODULE module_machine + + USE module_driver_constants + + ! Machine characteristics and utilities here. + + ! Tile strategy defined constants + INTEGER, PARAMETER :: TILE_NONE = 0, TILE_X = 1, TILE_Y = 2, TILE_XY = 3 + + CONTAINS + + RECURSIVE SUBROUTINE rlocproc(p,maxi,nproc,ml,mr,ret) + IMPLICIT NONE + INTEGER, INTENT(IN) :: p, maxi, nproc, ml, mr + INTEGER, INTENT(OUT) :: ret + INTEGER :: width, rem, ret2, bl, br, mid, adjust, & + p_r, maxi_r, nproc_r, zero + adjust = 0 + rem = mod( maxi, nproc ) + width = maxi / nproc + mid = maxi / 2 + IF ( rem>0 .AND. (((mod(rem,2).EQ.0).OR.(rem.GT.2)).OR.(p.LE.mid))) THEN + width = width + 1 + END IF + IF ( p.LE.mid .AND. mod(rem,2).NE.0 ) THEN + adjust = adjust + 1 + END IF + bl = max(width,ml) ; + br = max(width,mr) ; + IF (pmaxi-br-1) THEN + ret = nproc-1 + ELSE + p_r = p - bl + maxi_r = maxi-bl-br+adjust + nproc_r = max(nproc-2,1) + zero = 0 + CALL rlocproc( p_r, maxi_r, nproc_r, zero, zero, ret2 ) ! Recursive + ret = ret2 + 1 + END IF + RETURN + END SUBROUTINE rlocproc + + INTEGER FUNCTION locproc( i, m, numpart ) + implicit none + integer, intent(in) :: i, m, numpart + integer :: retval, ii, im, inumpart, zero + ii = i + im = m + inumpart = numpart + zero = 0 + CALL rlocproc( ii, im, inumpart, zero, zero, retval ) + locproc = retval + RETURN + END FUNCTION locproc + + SUBROUTINE patchmap( res, y, x, py, px ) + implicit none + INTEGER, INTENT(IN) :: y, x, py, px + INTEGER, DIMENSION(x,y), INTENT(OUT) :: res + INTEGER :: i, j, p_min, p_maj + DO j = 0,y-1 + p_maj = locproc( j, y, py ) + DO i = 0,x-1 + p_min = locproc( i, x, px ) + res(i+1,j+1) = p_min + px*p_maj + END DO + END DO + RETURN + END SUBROUTINE patchmap + + SUBROUTINE region_bounds( region_start, region_end, & + num_p, p, & + patch_start, patch_end ) + ! 1-D decomposition routine: Given starting and ending indices of a + ! vector, the number of patches dividing the vector, and the number of + ! the patch, give the start and ending indices of the patch within the + ! vector. This will work with tiles too. Implementation note. This is + ! implemented somewhat inefficiently, now, with a loop, so we can use the + ! locproc function above, which returns processor number for a given + ! index, whereas what we want is index for a given processor number. + ! With a little thought and a lot of debugging, we can come up with a + ! direct expression for what we want. For time being, we loop... + ! Remember that processor numbering starts with zero. + + IMPLICIT NONE + INTEGER, INTENT(IN) :: region_start, region_end, num_p, p + INTEGER, INTENT(OUT) :: patch_start, patch_end + INTEGER :: offset, i + patch_end = -999999999 + patch_start = 999999999 + offset = region_start + do i = 0, region_end - offset + if ( locproc( i, region_end-region_start+1, num_p ) == p ) then + patch_end = max(patch_end,i) + patch_start = min(patch_start,i) + endif + enddo + patch_start = patch_start + offset + patch_end = patch_end + offset + RETURN + END SUBROUTINE region_bounds + + SUBROUTINE least_aspect( nparts, minparts_y, minparts_x, nparts_y, nparts_x ) + IMPLICIT NONE + ! Input data. + INTEGER, INTENT(IN) :: nparts, & + minparts_y, minparts_x + ! Output data. + INTEGER, INTENT(OUT) :: nparts_y, nparts_x + ! Local data. + INTEGER :: x, y, mini + mini = 2*nparts + nparts_y = 1 + nparts_x = nparts + DO y = 1, nparts + IF ( mod( nparts, y ) .eq. 0 ) THEN + x = nparts / y + IF ( abs( y-x ) .LT. mini & + .AND. y .GE. minparts_y & + .AND. x .GE. minparts_x ) THEN + mini = abs( y-x ) + nparts_y = y + nparts_x = x + END IF + END IF + END DO + END SUBROUTINE least_aspect + + SUBROUTINE init_module_machine + RETURN + END SUBROUTINE init_module_machine + +END MODULE module_machine + +SUBROUTINE wrf_sizeof_integer( retval ) + IMPLICIT NONE + INTEGER retval +! IWORDSIZE is defined by CPP + retval = IWORDSIZE + RETURN +END SUBROUTINE wrf_sizeof_integer + +SUBROUTINE wrf_sizeof_real( retval ) + IMPLICIT NONE + INTEGER retval +! RWORDSIZE is defined by CPP + retval = RWORDSIZE + RETURN +END SUBROUTINE wrf_sizeof_real + +SUBROUTINE wrf_sizeof_doubleprecision( retval ) + IMPLICIT NONE + INTEGER retval +! DWORDSIZE is defined by CPP + retval = DWORDSIZE + RETURN +END SUBROUTINE wrf_sizeof_doubleprecision + +SUBROUTINE wrf_sizeof_logical( retval ) + IMPLICIT NONE + INTEGER retval +! LWORDSIZE is defined by CPP + retval = LWORDSIZE + RETURN +END SUBROUTINE wrf_sizeof_logical + diff --git a/src/wrflib/pack_utils.c b/src/wrflib/pack_utils.c new file mode 100644 index 0000000000..3caa8cc04f --- /dev/null +++ b/src/wrflib/pack_utils.c @@ -0,0 +1,390 @@ +#ifndef MS_SUA +# include +# include +#endif +#include +#include "streams.h" + +#ifndef CRAY +# ifdef NOUNDERSCORE +# define INT_PACK_DATA int_pack_data +# define INT_GET_TI_HEADER_C int_get_ti_header_c +# define INT_GEN_TI_HEADER_C int_gen_ti_header_c +# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c +# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c +# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c +# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field +# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field +# define PERTURB_REAL perturb_real +# define INSPECT_HEADER inspect_header +# define RESET_MASK reset_mask +# define SET_MASK set_mask +# define GET_MASK get_mask +# else +# ifdef F2CSTYLE +# define INT_PACK_DATA int_pack_data__ +# define INT_GET_TI_HEADER_C int_get_ti_header_c__ +# define INT_GEN_TI_HEADER_C int_gen_ti_header_c__ +# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c__ +# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c__ +# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c__ +# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field__ +# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field__ +# define PERTURB_REAL perturb_real__ +# define INSPECT_HEADER inspect_header__ +# define RESET_MASK reset_mask__ +# define SET_MASK set_mask__ +# define GET_MASK get_mask__ +# else +# define INT_PACK_DATA int_pack_data_ +# define INT_GET_TI_HEADER_C int_get_ti_header_c_ +# define INT_GEN_TI_HEADER_C int_gen_ti_header_c_ +# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c_ +# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c_ +# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c_ +# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field_ +# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field_ +# define PERTURB_REAL perturb_real_ +# define INSPECT_HEADER inspect_header_ +# define RESET_MASK reset_mask_ +# define SET_MASK set_mask_ +# define GET_MASK get_mask_ +# endif +# endif +#endif + +#ifdef MEMCPY_FOR_BCOPY +# define bcopy(A,B,C) memcpy((B),(A),(C)) +#endif + +/* CALL int_pack_data ( hdrbuf , hdrbufsiz * inttypesize , int_local_output_buffer, int_local_output_cursor ) */ + +void INT_PACK_DATA ( unsigned char *buf , int *ninbytes , unsigned char *obuf, int *cursor ) +{ + int i, lcurs ; + lcurs = *cursor - 1 ; + for ( i = 0 ; i < *ninbytes ; i++ ) + { + obuf[lcurs++] = buf[i] ; + } + *cursor = lcurs+1 ; +} + +int +INT_GEN_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, /* hdrbufsize is in bytes */ + int * itypesize, int * typesize, + int * DataHandle, char * Data, + int * Count, int * code ) +{ + int i ; + char * p ; + p = hdrbuf ; + p += sizeof(int) ; + bcopy( code, p, sizeof(int) ) ; p += sizeof(int) ; /* 2 */ + bcopy( DataHandle, p, sizeof(int) ) ; p += sizeof(int) ; /* 3 */ + bcopy( typesize, p, sizeof(int) ) ; p += sizeof(int) ; /* 4 */ + bcopy( Count, p, sizeof(int) ) ; p += sizeof(int) ; /* 5 */ + bcopy( Data, p, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */ + *hdrbufsize = (int) (p - hdrbuf) ; + bcopy( hdrbufsize, hdrbuf, sizeof(int) ) ; + return(0) ; +} + +int +INT_GET_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, int * n, /* hdrbufsize and n are in bytes */ + int * itypesize, int * typesize, + int * DataHandle, char * Data, + int * Count, int * code ) +{ + int i ; + char * p ; + p = hdrbuf ; + bcopy( p, hdrbufsize, sizeof(int) ) ; p += sizeof(int) ; /* 1 */ + bcopy( p, code, sizeof(int) ) ; p += sizeof(int) ; /* 2 */ + bcopy( p, DataHandle, sizeof(int) ) ; p += sizeof(int) ; /* 3 */ + bcopy( p, typesize, sizeof(int) ) ; p += sizeof(int) ; /* 4 */ + bcopy( p, Count, sizeof(int) ) ; p += sizeof(int) ; /* 5 */ + if ( *Count * *typesize > 0 ) { + bcopy( p, Data, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */ + } + *n = (int)( p - hdrbuf ) ; + return(0) ; +} + +#define MAX_FLDS 2000 +static char fld_name[MAX_FLDS][256] ; +static char *fld_cache[MAX_FLDS] ; +static int fld_curs[MAX_FLDS] ; +static int fld_bufsize[MAX_FLDS] ; +static int fld = 0 ; +static int numflds = 0 ; +static int frst = 1 ; + +int INIT_STORE_PIECE_OF_FIELD () +{ + int i ; + if ( frst ) { + for ( i = 0 ; i < MAX_FLDS ; i++ ) { + fld_cache[i] = NULL ; + } + frst = 0 ; + } + numflds = 0 ; + for ( i = 0 ; i < MAX_FLDS ; i++ ) { + strcpy( fld_name[i], "" ) ; + if ( fld_cache[i] != NULL ) free( fld_cache[i] ) ; + fld_cache[i] = NULL ; + fld_curs[i] = 0 ; + fld_bufsize[i] = 0 ; + } + return(0) ; +} + +int INIT_RETRIEVE_PIECES_OF_FIELD () +{ + fld = 0 ; + return(0) ; +} + +int +ADD_TO_BUFSIZE_FOR_FIELD_C ( int varname[], int * chunksize ) +{ + int i, n ; + int found ; + char vname[256] ; + + n = varname[0] ; + for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; } + vname[n] = '\0' ; + + found = -1 ; + for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } } + if ( found == -1 ) { + found = numflds++ ; + strcpy( fld_name[found], vname ) ; + fld_bufsize[found] = *chunksize ; + } + else + { + fld_bufsize[found] += *chunksize ; + } + if ( fld_cache[found] != NULL ) { free( fld_cache[found] ) ; } + fld_cache[found] = NULL ; + return(0) ; +} + +int +STORE_PIECE_OF_FIELD_C ( char * buf , int varname[], int * chunksize, int *retval ) +{ + int i, n ; + int found ; + char vname[256] ; + + n = varname[0] ; + for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; } + vname[n] = '\0' ; + + found = -1 ; + for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } } + if ( found == -1 ) { +#ifndef MS_SUA + fprintf(stderr,"frame/pack_utils.c: field (%s) not found; was not set up with add_to_bufsize_for_field\n",vname ) ; +#endif + *retval = 1 ; + return(0) ; + } + + if ( fld_cache[found] == NULL ) { + fld_cache[found] = (char *) malloc( fld_bufsize[found] ) ; + fld_curs[found] = 0 ; + } + + if ( fld_curs[found] + *chunksize > fld_bufsize[found] ) { +#ifndef MS_SUA + fprintf(stderr, +"frame/pack_utils.c: %s would overwrite %d + %d > %d [%d]\n",vname, fld_curs[found], *chunksize, fld_bufsize[found], found ) ; +#endif + *retval = 1 ; + return(0) ; + } + + bcopy( buf, fld_cache[found]+fld_curs[found], *chunksize ) ; + fld_curs[found] += *chunksize ; + *retval = 0 ; + return(0) ; +} + +int +RETRIEVE_PIECES_OF_FIELD_C ( char * buf , int varname[], int * insize, int * outsize, int *retval ) +{ + int i, n ; + int found ; + char vname[256] ; + + if ( fld < numflds ) { +#ifndef MS_SUA + if ( fld_curs[fld] > *insize ) { + fprintf(stderr,"retrieve: fld_curs[%d] (%d) > *insize (%d)\n",fld,fld_curs[fld], *insize ) ; + } +#endif + *outsize = ( fld_curs[fld] <= *insize ) ? fld_curs[fld] : *insize ; + bcopy( fld_cache[fld], buf, *outsize ) ; + varname[0] = (int) strlen( fld_name[fld] ) ; + for ( i = 1 ; i <= varname[0] ; i++ ) varname[i] = fld_name[fld][i-1] ; + if ( fld_cache[fld] != NULL ) free ( fld_cache[fld] ) ; + fld_cache[fld] = NULL ; + fld_bufsize[fld] = 0 ; + fld++ ; + *retval = 0 ; + } + else { + numflds = 0 ; + *retval = -1 ; + } + return(0) ; +} + +#define INDEX_2(A,B,NB) ( (B) + (A)*(NB) ) +#define INDEX_3(A,B,C) INDEX_2( (A), INDEX_2( (B), (C), (me[1]-ms[1]+1) ), (me[1]-ms[1]+1)*(me[0]-ms[0]+1) ) +/* flip low order bit of fp number */ +int +PERTURB_REAL ( float * field, int ds[], int de[], int ms[], int me[], int ps[], int pe[] ) +{ + int i,j,k ; + int le ; /* index of little end */ + float x = 2.0 ; + unsigned int y ; + unsigned char a[4], *p ; + if ( sizeof(float) != 4 ) return(-1) ; + /* check endianness of machine */ + bcopy ( &x, a, 4 ) ; + le = 0 ; + if ( a[0] == 0x40 ) le = 3 ; + for ( k = ps[2]-ms[2] ; k <= pe[2]-ms[2] ; k++ ) + for ( j = ps[1]-ms[1] ; j <= pe[1]-ms[1] ; j++ ) + for ( i = ps[0]-ms[0] ; i <= pe[0]-ms[0] ; i++ ) + { + /* do not change zeros */ + if ( field[ INDEX_3(k,j,i) ] != 0.0 ) { + p = (unsigned char *)&(field[ INDEX_3(k,j,i) ] ) ; + if ( *(p+le) & 1 ) { *(p+le) &= 0x7e ; } + else { *(p+le) |= 1 ; } + } + } + return(0) ; +} + +int INSPECT_HEADER ( char * buf, int * sz, int * line ) +{ + int i ; +#ifndef MS_SUA + fprintf(stderr,"INSPECT_HEADER: line = %d ", *line ) ; + if ( buf != NULL && sz != NULL ) { + for ( i = 0 ; i < *sz && i < 256 ; i++ ) { if ( (buf[i] >= 'a' && buf[i] <= 'z') || buf[i] == '_' || + (buf[i] >= 'A' && buf[i] <= 'Z') || + (buf[i] >= '0' && buf[i] <= '9') ) fprintf(stderr,"%c",buf[i]) ; + } + fprintf(stderr,"\n") ; + } +#endif + return(0) ; +} + +/* note that these work the same as the routines in tools/misc.c, but are Fortran callable. + They must be kept in sync, functionally. */ + +void +RESET_MASK ( unsigned int * mask , int *e ) +{ + int w ; + unsigned int m, n ; + + w = *e / (8*sizeof(int)-1) ; + n = 1 ; + m = ~( n << *e % (8*sizeof(int)-1) ) ; + if ( w >= 0 && w < IO_MASK_SIZE ) { + mask[w] &= m ; + } +} + +void +SET_MASK ( unsigned int * mask , int *e ) +{ + int w ; + unsigned int m, n ; + + w = *e / (8*sizeof(int)-1) ; + n = 1 ; + m = ( n << *e % (8*sizeof(int)-1) ) ; + if ( w >= 0 && w < IO_MASK_SIZE ) { + mask[w] |= m ; + } +} + +/* this is slightly different from in tools dir since it returns result as argument, not function */ +/* definition of IO_MASK_SIZE comes from build and must be uniform with frame/module_domain_type.F and + version of this function in tools dir */ +void +GET_MASK ( unsigned int * mask , int *e , int * retval ) +{ + int w ; + unsigned int m, n ; + + w = *e / (8*sizeof(int)-1) ; /* 8 is number of bits per byte */ + if ( w >= 0 && w < IO_MASK_SIZE ) { + m = mask[w] ; + n = ( 1 << *e % (8*sizeof(int)-1) ) ;; + *retval = ( (m & n) != 0 ) ; + } else { + *retval = 0 ; + } +} + +#ifdef WRAP_MALLOC +# ifndef WRAP_MALLOC_ALIGNMENT +# define WRAP_MALLOC_ALIGNMENT 128 +# endif +# define _XOPEN_SOURCE 600 +# include +void *malloc(size_t size) +{ + void *tmp; + if (posix_memalign(&tmp, WRAP_MALLOC_ALIGNMENT, size) == 0) + return tmp; + else { + errno = ENOMEM; + return NULL; + } +} +#endif + +#ifndef DM_PARALLEL +# ifndef CRAY +# ifdef NOUNDERSCORE +# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock +# else +# ifdef F2CSTYLE +# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock__ +# else +# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock_ +# endif +# endif +# endif +# if !defined(MS_SUA) && !defined(_WIN32) +# include +int RSL_INTERNAL_MICROCLOCK () +{ + struct timeval tb ; + struct timezone tzp ; + int isec ; /* seconds */ + int usec ; /* microseconds */ + int msecs ; + gettimeofday( &tb, &tzp ) ; + isec = tb.tv_sec ; + usec = tb.tv_usec ; + msecs = 1000000 * isec + usec ; + return(msecs) ; +} +# endif +#endif + diff --git a/src/wrflib/streams.h b/src/wrflib/streams.h new file mode 100644 index 0000000000..645b02d855 --- /dev/null +++ b/src/wrflib/streams.h @@ -0,0 +1,16 @@ +#ifndef MAX_HISTORY +# define MAX_HISTORY 12 +#endif +#ifndef IWORDSIZE +# define IWORDSIZE 4 +#endif +#define HISTORY_STREAM 0 +#define INPUT_STREAM ((HISTORY_STREAM)+(MAX_HISTORY)) +#if 0 + max streams is MAX_HISTORY plus equal number of input streams plus 1 restart + 1 boundary +#endif +#define MAX_STREAMS (2*(MAX_HISTORY)+2) +#define BOUNDARY_STREAM (2*(MAX_HISTORY)+1) +#define RESTART_STREAM (2*(MAX_HISTORY)+2) +#define IO_MASK_SIZE ((MAX_STREAMS)/(IWORDSIZE*8)+1) + diff --git a/src/wrflib/transpose.code b/src/wrflib/transpose.code new file mode 100644 index 0000000000..746be42fcb --- /dev/null +++ b/src/wrflib/transpose.code @@ -0,0 +1,40 @@ + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 + +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + DFIELD = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = DFIELD + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + + return diff --git a/src/wrflib/wrf_io.F90.orig b/src/wrflib/wrf_io.F90.orig new file mode 100644 index 0000000000..4288b98e68 --- /dev/null +++ b/src/wrflib/wrf_io.F90.orig @@ -0,0 +1,3685 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + +module wrf_data + + integer , parameter :: FATAL = 1 + integer , parameter :: WARN = 1 + integer , parameter :: WrfDataHandleMax = 99 + integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS +#if(WRF_CHEM == 1) + integer , parameter :: MaxVars = 10000 +#else + integer , parameter :: MaxVars = 3000 +#endif + integer , parameter :: MaxTimes = 10000 + integer , parameter :: DateStrLen = 19 + integer , parameter :: VarNameLen = 31 + integer , parameter :: NO_DIM = 0 + integer , parameter :: NVarDims = 4 + integer , parameter :: NMDVarDims = 2 + character (8) , parameter :: NO_NAME = 'NULL' + character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' + +#include "wrf_io_flags.h" + + character (256) :: msg + logical :: WrfIOnotInitialized = .true. + + type :: wrf_data_handle + character (255) :: FileName + integer :: FileStatus + integer :: Comm + integer :: NCID + logical :: Free + logical :: Write + character (5) :: TimesName + integer :: TimeIndex + integer :: CurrentTime !Only used for read + integer :: NumberTimes !Only used for read + character (DateStrLen), pointer :: Times(:) + integer :: TimesVarID + integer , pointer :: DimLengths(:) + integer , pointer :: DimIDs(:) + character (31) , pointer :: DimNames(:) + integer :: DimUnlimID + character (9) :: DimUnlimName + integer , dimension(NVarDims) :: DimID + integer , dimension(NVarDims) :: Dimension + integer , pointer :: MDVarIDs(:) + integer , pointer :: MDVarDimLens(:) + character (80) , pointer :: MDVarNames(:) + integer , pointer :: VarIDs(:) + integer , pointer :: VarDimLens(:,:) + character (VarNameLen), pointer :: VarNames(:) + integer :: CurrentVariable !Only used for read + integer :: NumVars +! first_operation is set to .TRUE. when a new handle is allocated +! or when open-for-write or open-for-read are committed. It is set +! to .FALSE. when the first field is read or written. + logical :: first_operation + logical :: R4OnOutput + logical :: nofill + logical :: use_netcdf_classic + end type wrf_data_handle + type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) +end module wrf_data + +module ext_ncd_support_routines + + implicit none + +CONTAINS + +subroutine allocHandle(DataHandle,DH,Comm,Status) + use wrf_data + include 'wrf_status_codes.h' + integer ,intent(out) :: DataHandle + type(wrf_data_handle),pointer :: DH + integer ,intent(IN) :: Comm + integer ,intent(out) :: Status + integer :: i + integer :: stat + + do i=1,WrfDataHandleMax + if(WrfDataHandles(i)%Free) then + DH => WrfDataHandles(i) + DataHandle = i + allocate(DH%Times(MaxTimes), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%DimLengths(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%DimIDs(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%DimNames(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%MDVarIDs(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%MDVarDimLens(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%MDVarNames(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%VarIDs(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%VarNames(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + exit + endif + if(i==WrfDataHandleMax) then + Status = WRF_WARN_TOO_MANY_FILES + write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) 'Did you call ext_ncd_ioinit?' + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + DH%Free =.false. + DH%Comm = Comm + DH%Write =.false. + DH%first_operation = .TRUE. + DH%R4OnOutput = .false. + DH%nofill = .false. + Status = WRF_NO_ERR +end subroutine allocHandle + +subroutine deallocHandle(DataHandle, Status) + use wrf_data + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN + if(.NOT. WrfDataHandles(DataHandle)%Free) then + DH => WrfDataHandles(DataHandle) + deallocate(DH%Times, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DimLengths, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DimIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DimNames, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDVarIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDVarDimLens, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDVarNames, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%VarIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%VarDimLens, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%VarNames, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + DH%Free =.TRUE. + endif + ENDIF + Status = WRF_NO_ERR +end subroutine deallocHandle + +subroutine GetDH(DataHandle,DH,Status) + use wrf_data + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + type(wrf_data_handle) ,pointer :: DH + integer ,intent(out) :: Status + + if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then + Status = WRF_WARN_BAD_DATA_HANDLE + return + endif + DH => WrfDataHandles(DataHandle) + if(DH%Free) then + Status = WRF_WARN_BAD_DATA_HANDLE + return + endif + Status = WRF_NO_ERR + return +end subroutine GetDH + +subroutine DateCheck(Date,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Date + integer ,intent(out) :: Status + + if(len(Date) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + else + Status = WRF_NO_ERR + endif + return +end subroutine DateCheck + +subroutine GetName(Element,Var,Name,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Name + integer ,intent(out) :: Status + character (VarNameLen) :: VarName + character (1) :: c + integer :: i + integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') + + VarName = Var + Name = 'MD___'//trim(Element)//VarName + do i=1,len(Name) + c=Name(i:i) + if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) + if(c=='-'.or.c==':') Name(i:i)='_' + enddo + Status = WRF_NO_ERR + return +end subroutine GetName + +subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + use wrf_data + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: TimeIndex + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: VStart(2) + integer :: VCount(2) + integer :: stat + integer :: i + + DH => WrfDataHandles(DataHandle) + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_WARN_DATESTR_ERROR + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(IO == 'write') then + TimeIndex = DH%TimeIndex + if(TimeIndex <= 0) then + TimeIndex = 1 + elseif(DateStr == DH%Times(TimeIndex)) then + Status = WRF_NO_ERR + return + else + TimeIndex = TimeIndex +1 + if(TimeIndex > MaxTimes) then + Status = WRF_WARN_TIME_EOF + write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + DH%TimeIndex = TimeIndex + DH%Times(TimeIndex) = DateStr + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = DateStrLen + VCount(2) = 1 + stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + else + do i=1,MaxTimes + if(DH%Times(i)==DateStr) then + Status = WRF_NO_ERR + TimeIndex = i + exit + endif + if(i==MaxTimes) then + Status = WRF_WARN_TIME_NF + write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + endif + return +end subroutine GetTimeIndex + +subroutine GetDim(MemoryOrder,NDim,Status) + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(out) :: NDim + integer ,intent(out) :: Status + character*3 :: MemOrd + + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') + NDim = 3 + case ('xy','yx','xs','xe','ys','ye','cc') + NDim = 2 + case ('z','c') + NDim = 1 + case ('0') ! NDim=0 for scalars. TBH: 20060502 + NDim = 0 + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine GetDim + +#ifdef USE_NETCDF4_FEATURES +subroutine set_chunking(MemoryOrder,need_chunking) + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + logical ,intent(out) :: need_chunking + character*3 :: MemOrd + + call LowerCase(MemoryOrder,MemOrd) + if(len(MemOrd) >= 2) then + select case (MemOrd) + case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') + need_chunking = .true. + case ('xy','yx') + need_chunking = .true. + case default + need_chunking = .false. + return + end select + endif +end subroutine set_chunking +#endif + +subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) + integer ,intent(in) :: NDim + integer ,dimension(*),intent(in) :: Start,End + integer ,intent(out) :: i1,i2,j1,j2,k1,k2 + + i1=1 + i2=1 + j1=1 + j2=1 + k1=1 + k2=1 + if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 + i1 = Start(1) + i2 = End (1) + if(NDim == 1) return + j1 = Start(2) + j2 = End (2) + if(NDim == 2) return + k1 = Start(3) + k2 = End (3) + return +end subroutine GetIndices + +logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer,dimension(*) ,intent(in) :: Vector + integer ,intent(out) :: Status + integer :: NDim + integer,dimension(NVarDims) :: temp + character*3 :: MemOrd + logical zero_length + + call GetDim(MemoryOrder,NDim,Status) + temp(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + zero_length = .false. + select case (MemOrd) + case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy','yzx') + zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 + case ('xy','yx','xyz','yxz') + zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 + case ('zxy','zyx') + zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 + case default + Status = WRF_WARN_BAD_MEMORYORDER + ZeroLengthHorzDim = .true. + return + end select + Status = WRF_NO_ERR + ZeroLengthHorzDim = zero_length + return +end function ZeroLengthHorzDim + +subroutine ExtOrder(MemoryOrder,Vector,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer,dimension(*) ,intent(inout) :: Vector + integer ,intent(out) :: Status + integer :: NDim + integer,dimension(NVarDims) :: temp + character*3 :: MemOrd + + call GetDim(MemoryOrder,NDim,Status) + temp(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy') + Vector(2) = temp(3) + Vector(3) = temp(2) + case ('yxz') + Vector(1) = temp(2) + Vector(2) = temp(1) + case ('yzx') + Vector(1) = temp(3) + Vector(2) = temp(1) + Vector(3) = temp(2) + case ('zxy') + Vector(1) = temp(2) + Vector(2) = temp(3) + Vector(3) = temp(1) + case ('zyx') + Vector(1) = temp(3) + Vector(3) = temp(1) + case ('yx') + Vector(1) = temp(2) + Vector(2) = temp(1) + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrder + +subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*(*),dimension(*) ,intent(in) :: Vector + character(80),dimension(NVarDims),intent(out) :: ROVector + integer ,intent(out) :: Status + integer :: NDim + character*3 :: MemOrd + + call GetDim(MemoryOrder,NDim,Status) + ROVector(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy') + ROVector(2) = Vector(3) + ROVector(3) = Vector(2) + case ('yxz') + ROVector(1) = Vector(2) + ROVector(2) = Vector(1) + case ('yzx') + ROVector(1) = Vector(3) + ROVector(2) = Vector(1) + ROVector(3) = Vector(2) + case ('zxy') + ROVector(1) = Vector(2) + ROVector(2) = Vector(3) + ROVector(3) = Vector(1) + case ('zyx') + ROVector(1) = Vector(3) + ROVector(3) = Vector(1) + case ('yx') + ROVector(1) = Vector(2) + ROVector(2) = Vector(1) + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrderStr + + +subroutine LowerCase(MemoryOrder,MemOrd) + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(out) :: MemOrd + character*1 :: c + integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') + integer :: i,N + + MemOrd = ' ' + N = len(MemoryOrder) + MemOrd(1:N) = MemoryOrder(1:N) + do i=1,N + c = MemoryOrder(i:i) + if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) + enddo + return +end subroutine LowerCase + +subroutine UpperCase(MemoryOrder,MemOrd) + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(out) :: MemOrd + character*1 :: c + integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') + integer :: i,N + + MemOrd = ' ' + N = len(MemoryOrder) + MemOrd(1:N) = MemoryOrder(1:N) + do i=1,N + c = MemoryOrder(i:i) + if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) + enddo + return +end subroutine UpperCase + +subroutine netcdf_err(err,Status) + use wrf_data + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: err + integer ,intent(out) :: Status + character(len=80) :: errmsg + integer :: stat + + if( err==NF_NOERR )then + Status = WRF_NO_ERR + else + errmsg = NF_STRERROR(err) + write(msg,*) 'NetCDF error: ',errmsg + call wrf_debug ( WARN , TRIM(msg)) + Status = WRF_WARN_NETCDF + endif + return +end subroutine netcdf_err + +subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & + ,FieldType,NCID,VarID,XField,Status) + use wrf_data + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer,dimension(NVarDims),intent(in) :: Length + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: FieldType + integer ,intent(in) :: NCID + integer ,intent(in) :: VarID + integer,dimension(*) ,intent(inout) :: XField + integer ,intent(out) :: Status + integer :: TimeIndex + integer :: NDim + integer,dimension(NVarDims) :: VStart + integer,dimension(NVarDims) :: VCount +! include 'wrf_io_flags.h' + + call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' Bad time index for DateStr = ',DateStr + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDim(MemoryOrder,NDim,Status) + VStart(:) = 1 + VCount(:) = 1 + VStart(1:NDim) = 1 + VCount(1:NDim) = Length(1:NDim) + VStart(NDim+1) = TimeIndex + VCount(NDim+1) = 1 + + ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE + IF (FieldType == WRF_REAL) THEN + call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + ELSE IF (FieldType == WRF_DOUBLE) THEN + call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + ELSE IF (FieldType == WRF_INTEGER) THEN + call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + ELSE IF (FieldType == WRF_LOGICAL) THEN + call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + if(Status /= WRF_NO_ERR) return + ELSE + write(6,*) 'WARNING---- some missing calls commented out' + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + END IF + + return +end subroutine FieldIO + +subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + character*(*) ,intent(in) :: IO + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: l1,l2,m1,m2,n1,n2 + integer ,intent(in) :: di + integer ,intent(in) :: x1,x2,y1,y2,z1,z2 + integer ,intent(in) :: i1,i2,j1,j2,k1,k2 + integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) +!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) + integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) + character*3 :: MemOrd + character*3 :: MemO + integer ,parameter :: MaxUpperCase=IACHAR('Z') + integer :: i,j,k,ix,jx,kx + + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + +#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) +! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) + + case ('xzy') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(i,k,j)) +#include "transpose.code" + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(i,j,k)) +#include "transpose.code" + case ('yxz') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(j,i,k)) +#include "transpose.code" + case ('zxy') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(k,i,j)) +#include "transpose.code" + case ('yzx') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(j,k,i)) +#include "transpose.code" + case ('zyx') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(k,j,i)) +#include "transpose.code" + case ('yx') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(j,i,k)) +#include "transpose.code" + end select + return +end subroutine Transpose + +subroutine reorder (MemoryOrder,MemO) + character*(*) ,intent(in) :: MemoryOrder + character*3 ,intent(out) :: MemO + character*3 :: MemOrd + integer :: N,i,i1,i2,i3 + + MemO = MemoryOrder + N = len_trim(MemoryOrder) + if(N == 1) return + call lowercase(MemoryOrder,MemOrd) +! never invert the boundary codes + select case ( MemOrd ) + case ( 'xsz','xez','ysz','yez' ) + return + case default + continue + end select + i1 = 1 + i3 = 1 + do i=2,N + if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i + if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i + enddo + if(N == 2) then + i2=i3 + else + i2 = 6-i1-i3 + endif + MemO(1:1) = MemoryOrder(i1:i1) + MemO(2:2) = MemoryOrder(i2:i2) + if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) + if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then + MemO(1:N-1) = MemO(2:N) + MemO(N:N ) = MemoryOrder(i1:i1) + endif + return +end subroutine reorder + +! Returns .TRUE. iff it is OK to write time-independent domain metadata to the +! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is +! returned. +LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) + USE wrf_data + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, first_output, retval + call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + first_output = ncd_is_first_operation( DataHandle ) + retval = .NOT. dryrun .AND. first_output + ENDIF + ncd_ok_to_put_dom_ti = retval + RETURN +END FUNCTION ncd_ok_to_put_dom_ti + +! Returns .TRUE. iff it is OK to read time-independent domain metadata from the +! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is +! returned. +LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) + USE wrf_data + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, retval + call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + retval = .NOT. dryrun + ENDIF + ncd_ok_to_get_dom_ti = retval + RETURN +END FUNCTION ncd_ok_to_get_dom_ti + +! Returns .TRUE. iff nothing has been read from or written to the file +! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. +LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) + USE wrf_data + INCLUDE 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + TYPE(wrf_data_handle) ,POINTER :: DH + INTEGER :: Status + LOGICAL :: retval + CALL GetDH( DataHandle, DH, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + retval = DH%first_operation + ENDIF + ncd_is_first_operation = retval + RETURN +END FUNCTION ncd_is_first_operation + +subroutine upgrade_filename(FileName) + implicit none + + character*(*), intent(inout) :: FileName + integer :: i + + do i = 1, len(trim(FileName)) + if(FileName(i:i) == '-') then + FileName(i:i) = '_' + else if(FileName(i:i) == ':') then + FileName(i:i) = '_' + endif + enddo + +end subroutine upgrade_filename + +end module ext_ncd_support_routines + +subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + + use ext_ncd_support_routines + + character*(*) ,intent(in) :: IO + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: l1,l2,m1,m2,n1,n2 + integer ,intent(in) :: di + integer ,intent(in) :: x1,x2,y1,y2,z1,z2 + integer ,intent(in) :: i1,i2,j1,j2,k1,k2 + real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) + real*4 ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) + character*3 :: MemOrd + character*3 :: MemO + integer ,parameter :: MaxUpperCase=IACHAR('Z') + integer :: i,j,k,ix,jx,kx + + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + +!#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) +! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) + + case ('xzy') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(i,k,j)) +#include "transpose.code" + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(i,j,k)) +#include "transpose.code" + case ('yxz') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(j,i,k)) +#include "transpose.code" + case ('zxy') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(k,i,j)) +#include "transpose.code" + case ('yzx') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(j,k,i)) +#include "transpose.code" + case ('zyx') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(k,j,i)) +#include "transpose.code" + case ('yx') +#undef DFIELD +#define DFIELD XField(1:di,XDEX(j,i,k)) +#include "transpose.code" + end select + return +end subroutine TransposeToR4 + +subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character *(*), INTENT(IN) :: DatasetName + integer , INTENT(IN) :: Comm1, Comm2 + character *(*), INTENT(IN) :: SysDepInfo + integer , INTENT(OUT) :: DataHandle + integer , INTENT(OUT) :: Status + DataHandle = 0 ! dummy setting to quiet warning message + CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) + IF ( Status .EQ. WRF_NO_ERR ) THEN + CALL ext_ncd_open_for_read_commit( DataHandle, Status ) + ENDIF + return +end subroutine ext_ncd_open_for_read + +!ends training phase; switches internal flag to enable input +!must be paired with call to ext_ncd_open_for_read_begin +subroutine ext_ncd_open_for_read_commit(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer, intent(in) :: DataHandle + integer, intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_READ + DH%first_operation = .TRUE. + Status = WRF_NO_ERR + return +end subroutine ext_ncd_open_for_read_commit + +subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character*(*) ,intent(INOUT) :: FileName + integer ,intent(IN) :: Comm + integer ,intent(IN) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: VarID + integer :: StoredDim + integer :: NAtts + integer :: DimIDs(2) + integer :: VStart(2) + integer :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + character (NF_MAX_NAME) :: Name + +#ifdef USE_NETCDF4_FEATURES + integer :: open_mode +#endif + + !call upgrade_filename(FileName) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(XType/=NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(1) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(2) > MaxTimes) then + Status = WRF_ERR_FATAL_TOO_MANY_TIMES + write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + VStart(1) = 1 + VStart(2) = 1 + stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NumVars = 0 + do i=1,TotalNumVars + stat = NF_INQ_VARNAME(DH%NCID,i,Name) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then + NumVars = NumVars+1 + DH%VarNames(NumVars) = Name + DH%VarIDs(NumVars) = i + endif + enddo + DH%NumVars = NumVars + DH%NumberTimes = VLen(2) + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = trim(FileName) + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimesVarID = VarID + DH%TimeIndex = 0 + return +end subroutine ext_ncd_open_for_read_begin + +subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character*(*) ,intent(INOUT) :: FileName + integer ,intent(IN) :: Comm + integer ,intent(IN) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: VarID + integer :: StoredDim + integer :: NAtts + integer :: DimIDs(2) + integer :: VStart(2) + integer :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + character (NF_MAX_NAME) :: Name + +#ifdef USE_NETCDF4_FEATURES + integer :: open_mode +#endif + + !call upgrade_filename(FileName) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(XType/=NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(1) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(2) > MaxTimes) then + Status = WRF_ERR_FATAL_TOO_MANY_TIMES + write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + VStart(1) = 1 + VStart(2) = 1 + stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NumVars = 0 + do i=1,TotalNumVars + stat = NF_INQ_VARNAME(DH%NCID,i,Name) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then + NumVars = NumVars+1 + DH%VarNames(NumVars) = Name + DH%VarIDs(NumVars) = i + endif + enddo + DH%NumVars = NumVars + DH%NumberTimes = VLen(2) + DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE + DH%FileName = trim(FileName) + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimesVarID = VarID + DH%TimeIndex = 0 + return +end subroutine ext_ncd_open_for_update + + +SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character*(*) ,intent(inout) :: FileName + integer ,intent(in) :: Comm + integer ,intent(in) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + character (7) :: Buffer + integer :: VDimIDs(2) + +#ifdef USE_NETCDF4_FEATURES + integer :: create_mode + integer, parameter :: cache_size = 32, & + cache_nelem = 37, & + cache_preemption = 100 +#endif + + !call upgrade_filename(FileName) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + DH%TimeIndex = 0 + DH%Times = ZeroDate +#ifdef USE_NETCDF4_FEATURES +! create_mode = IOR(nf_netcdf4, nf_classic_model) + if ( DH%use_netcdf_classic ) then + write(msg,*) 'output will be in classic NetCDF format' + call wrf_debug ( WARN , TRIM(msg)) +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) +#else + stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) +#endif + else + create_mode = nf_netcdf4 + stat = NF_CREATE(FileName, create_mode, DH%NCID) + stat = NF_SET_CHUNK_CACHE(cache_size, cache_nelem, cache_preemption) + endif +#else +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) +#else + stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) +#endif +#endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = trim(FileName) + stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%VarNames (1:MaxVars) = NO_NAME + DH%MDVarNames(1:MaxVars) = NO_NAME + do i=1,MaxDims + write(Buffer,FMT="('DIM',i4.4)") i + DH%DimNames (i) = Buffer + DH%DimLengths(i) = NO_DIM + enddo + DH%DimNames(1) = 'DateStrLen' + stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VDimIDs(1) = DH%DimIDs(1) + VDimIDs(2) = DH%DimUnlimID + stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(1) = DateStrLen + + if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then + DH%R4OnOutput = .true. + end if +!toggle on nofill mode + if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then + DH%nofill = .true. + end if + + return +end subroutine ext_ncd_open_for_write_begin + +!stub +!opens a file for writing or coupler datastream for sending messages. +!no training phase for this version of the open stmt. +subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & + SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character *(*), intent(in) ::DatasetName + integer , intent(in) ::Comm1, Comm2 + character *(*), intent(in) ::SysDepInfo + integer , intent(out) :: DataHandle + integer , intent(out) :: Status + Status=WRF_WARN_NOOP + DataHandle = 0 ! dummy setting to quiet warning message + return +end subroutine ext_ncd_open_for_write + +SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + integer :: oldmode ! for nf_set_fill, not used + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if ( DH%nofill ) then + Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode ) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName) + call wrf_debug ( WARN , TRIM(msg)) + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE + DH%first_operation = .TRUE. + return +end subroutine ext_ncd_open_for_write_commit + +subroutine ext_ncd_ioclose(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_CLOSE + write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + continue + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + + stat = NF_CLOSE(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + CALL deallocHandle( DataHandle, Status ) + DH%Free=.true. + return +end subroutine ext_ncd_ioclose + +subroutine ext_ncd_iosync( DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + continue + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_SYNC(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + return +end subroutine ext_ncd_iosync + + + +subroutine ext_ncd_redef( DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_FILE_OPEN_FOR_READ + write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + return +end subroutine ext_ncd_redef + +subroutine ext_ncd_enddef( DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_FILE_OPEN_FOR_READ + write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE + return +end subroutine ext_ncd_enddef + +subroutine ext_ncd_ioinit(SysDepInfo, Status) + use wrf_data + implicit none + include 'wrf_status_codes.h' + CHARACTER*(*), INTENT(IN) :: SysDepInfo + INTEGER ,INTENT(INOUT) :: Status + + WrfIOnotInitialized = .false. + WrfDataHandles(1:WrfDataHandleMax)%Free = .true. + WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' + WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' + WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED + if(trim(SysDepInfo) == "use_netcdf_classic" ) then + WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true. + else + WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false. + endif + Status = WRF_NO_ERR + return +end subroutine ext_ncd_ioinit + + +subroutine ext_ncd_inquiry (Inquiry, Result, Status) + use wrf_data + implicit none + include 'wrf_status_codes.h' + character *(*), INTENT(IN) :: Inquiry + character *(*), INTENT(OUT) :: Result + integer ,INTENT(INOUT) :: Status + SELECT CASE (Inquiry) + CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") + Result='ALLOW' + CASE ("OPEN_READ","OPEN_COMMIT_WRITE") + Result='REQUIRE' + CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") + Result='NO' + CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") + Result='YES' + CASE ("MEDIUM") + Result ='FILE' + CASE DEFAULT + Result = 'No Result for that inquiry!' + END SELECT + Status=WRF_NO_ERR + return +end subroutine ext_ncd_inquiry + + + + +subroutine ext_ncd_ioexit(Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer , INTENT(INOUT) ::Status + integer :: error + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,WrfDataHandleMax + CALL deallocHandle( i , stat ) + enddo + return +end subroutine ext_ncd_ioexit + +subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) +#define ROUTINE_TYPE 'REAL' +#define TYPE_DATA real,intent(out) :: Data(*) +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCOunt +#define TYPE_BUFFER real,allocatable :: Buffer(:) +#define NF_TYPE NF_FLOAT +#define NF_ROUTINE NF_GET_ATT_REAL +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) +#include "ext_ncd_get_dom_ti.code" +end subroutine ext_ncd_get_dom_ti_real + +subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'INTEGER' +#define TYPE_DATA integer,intent(out) :: Data(*) +#define TYPE_BUFFER integer,allocatable :: Buffer(:) +#define NF_TYPE NF_INT +#define NF_ROUTINE NF_GET_ATT_INT +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) +#include "ext_ncd_get_dom_ti.code" +end subroutine ext_ncd_get_dom_ti_integer + +subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'DOUBLE' +#define TYPE_DATA real*8,intent(out) :: Data(*) +#define TYPE_BUFFER real*8,allocatable :: Buffer(:) +#define NF_TYPE NF_DOUBLE +#define NF_ROUTINE NF_GET_ATT_DOUBLE +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) +#include "ext_ncd_get_dom_ti.code" +end subroutine ext_ncd_get_dom_ti_double + +subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'LOGICAL' +#define TYPE_DATA logical,intent(out) :: Data(*) +#define TYPE_BUFFER integer,allocatable :: Buffer(:) +#define NF_TYPE NF_INT +#define NF_ROUTINE NF_GET_ATT_INT +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 +#include "ext_ncd_get_dom_ti.code" +end subroutine ext_ncd_get_dom_ti_logical + +subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef TYPE_BUFFER +#undef NF_TYPE +#define ROUTINE_TYPE 'CHAR' +#define TYPE_DATA character*(*),intent(out) :: Data +#define TYPE_COUNT +#define TYPE_OUTCOUNT +#define TYPE_BUFFER +#define NF_TYPE NF_CHAR +#define CHAR_TYPE +#include "ext_ncd_get_dom_ti.code" +#undef CHAR_TYPE +end subroutine ext_ncd_get_dom_ti_char + +subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'REAL' +#define TYPE_DATA real ,intent(in) :: Data(*) +#define TYPE_COUNT integer,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_REAL +#define ARGS NF_FLOAT,Count,Data +#include "ext_ncd_put_dom_ti.code" +end subroutine ext_ncd_put_dom_ti_real + +subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'INTEGER' +#define TYPE_DATA integer,intent(in) :: Data(*) +#define TYPE_COUNT integer,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_INT +#define ARGS NF_INT,Count,Data +#include "ext_ncd_put_dom_ti.code" +end subroutine ext_ncd_put_dom_ti_integer + +subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'DOUBLE' +#define TYPE_DATA real*8 ,intent(in) :: Data(*) +#define TYPE_COUNT integer,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_DOUBLE +#define ARGS NF_DOUBLE,Count,Data +#include "ext_ncd_put_dom_ti.code" +end subroutine ext_ncd_put_dom_ti_double + +subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#define ROUTINE_TYPE 'LOGICAL' +#define TYPE_DATA logical,intent(in) :: Data(*) +#define TYPE_COUNT integer,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_INT +#define ARGS NF_INT,Count,Buffer +#define LOG +#include "ext_ncd_put_dom_ti.code" +end subroutine ext_ncd_put_dom_ti_logical + +subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'CHAR' +#define TYPE_DATA character*(*),intent(in) :: Data +#define TYPE_COUNT integer,parameter :: Count=1 +#define NF_ROUTINE NF_PUT_ATT_TEXT +#define ARGS len_trim(Data),Data +#include "ext_ncd_put_dom_ti.code" +end subroutine ext_ncd_put_dom_ti_char + +subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'REAL' +#define TYPE_DATA real ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_REAL +#define ARGS NF_FLOAT,Count,Data +#include "ext_ncd_put_var_ti.code" +end subroutine ext_ncd_put_var_ti_real + +subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef NF_TYPE +#undef LENGTH +#undef ARG +#undef LOG +#define ROUTINE_TYPE 'REAL' +#define TYPE_DATA real ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_VARA_REAL +#define NF_TYPE NF_FLOAT +#define LENGTH Count +#define ARG +#include "ext_ncd_put_var_td.code" +end subroutine ext_ncd_put_var_td_real + +subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'DOUBLE' +#define TYPE_DATA real*8 ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_DOUBLE +#define ARGS NF_DOUBLE,Count,Data +#include "ext_ncd_put_var_ti.code" +end subroutine ext_ncd_put_var_ti_double + +subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef NF_TYPE +#undef LENGTH +#undef ARG +#undef LOG +#define ROUTINE_TYPE 'DOUBLE' +#define TYPE_DATA real*8,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_VARA_DOUBLE +#define NF_TYPE NF_DOUBLE +#define LENGTH Count +#define ARG +#include "ext_ncd_put_var_td.code" +end subroutine ext_ncd_put_var_td_double + +subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'INTEGER' +#define TYPE_DATA integer ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_INT +#define ARGS NF_INT,Count,Data +#include "ext_ncd_put_var_ti.code" +end subroutine ext_ncd_put_var_ti_integer + +subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef NF_TYPE +#undef LENGTH +#undef ARG +#undef LOG +#define ROUTINE_TYPE 'INTEGER' +#define TYPE_DATA integer ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_VARA_INT +#define NF_TYPE NF_INT +#define LENGTH Count +#define ARG +#include "ext_ncd_put_var_td.code" +end subroutine ext_ncd_put_var_td_integer + +subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#define ROUTINE_TYPE 'LOGICAL' +#define TYPE_DATA logical ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_ATT_INT +#define LOG +#define ARGS NF_INT,Count,Buffer +#include "ext_ncd_put_var_ti.code" +end subroutine ext_ncd_put_var_ti_logical + +subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef NF_TYPE +#undef LENGTH +#undef ARG +#define ROUTINE_TYPE 'LOGICAL' +#define TYPE_DATA logical ,intent(in) :: Data(*) +#define TYPE_COUNT integer ,intent(in) :: Count +#define NF_ROUTINE NF_PUT_VARA_INT +#define NF_TYPE NF_INT +#define LOG +#define LENGTH Count +#define ARG +#include "ext_ncd_put_var_td.code" +end subroutine ext_ncd_put_var_td_logical + +subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef ARGS +#undef LOG +#define ROUTINE_TYPE 'CHAR' +#define TYPE_DATA character*(*) ,intent(in) :: Data +#define TYPE_COUNT +#define NF_ROUTINE NF_PUT_ATT_TEXT +#define ARGS len_trim(Data),trim(Data) +#define CHAR_TYPE +#include "ext_ncd_put_var_ti.code" +#undef CHAR_TYPE +end subroutine ext_ncd_put_var_ti_char + +subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_COUNT +#undef NF_ROUTINE +#undef NF_TYPE +#undef LENGTH +#undef ARG +#undef LOG +#define ROUTINE_TYPE 'CHAR' +#define TYPE_DATA character*(*) ,intent(in) :: Data +#define TYPE_COUNT +#define NF_ROUTINE NF_PUT_VARA_TEXT +#define NF_TYPE NF_CHAR +#define LENGTH len(Data) +#include "ext_ncd_put_var_td.code" +end subroutine ext_ncd_put_var_td_char + +subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'REAL' +#define TYPE_DATA real ,intent(out) :: Data(*) +#define TYPE_BUFFER real ,allocatable :: Buffer(:) +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_FLOAT +#define NF_ROUTINE NF_GET_ATT_REAL +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) +#include "ext_ncd_get_var_ti.code" +end subroutine ext_ncd_get_var_ti_real + +subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef LENGTH +#undef COPY +#define ROUTINE_TYPE 'REAL' +#define TYPE_DATA real ,intent(out) :: Data(*) +#define TYPE_BUFFER real +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_FLOAT +#define NF_ROUTINE NF_GET_VARA_REAL +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) +#include "ext_ncd_get_var_td.code" +end subroutine ext_ncd_get_var_td_real + +subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'DOUBLE' +#define TYPE_DATA real*8 ,intent(out) :: Data(*) +#define TYPE_BUFFER real*8 ,allocatable :: Buffer(:) +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_DOUBLE +#define NF_ROUTINE NF_GET_ATT_DOUBLE +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) +#include "ext_ncd_get_var_ti.code" +end subroutine ext_ncd_get_var_ti_double + +subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef LENGTH +#undef COPY +#define ROUTINE_TYPE 'DOUBLE' +#define TYPE_DATA real*8 ,intent(out) :: Data(*) +#define TYPE_BUFFER real*8 +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_DOUBLE +#define NF_ROUTINE NF_GET_VARA_DOUBLE +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) +#include "ext_ncd_get_var_td.code" +end subroutine ext_ncd_get_var_td_double + +subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'INTEGER' +#define TYPE_DATA integer,intent(out) :: Data(*) +#define TYPE_BUFFER integer,allocatable :: Buffer(:) +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_INT +#define NF_ROUTINE NF_GET_ATT_INT +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) +#include "ext_ncd_get_var_ti.code" +end subroutine ext_ncd_get_var_ti_integer + +subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef LENGTH +#undef COPY +#define ROUTINE_TYPE 'INTEGER' +#define TYPE_DATA integer,intent(out) :: Data(*) +#define TYPE_BUFFER integer +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_INT +#define NF_ROUTINE NF_GET_VARA_INT +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) +#include "ext_ncd_get_var_td.code" +end subroutine ext_ncd_get_var_td_integer + +subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'LOGICAL' +#define TYPE_DATA logical,intent(out) :: Data(*) +#define TYPE_BUFFER integer,allocatable :: Buffer(:) +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_INT +#define NF_ROUTINE NF_GET_ATT_INT +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 +#include "ext_ncd_get_var_ti.code" +end subroutine ext_ncd_get_var_ti_logical + +subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef LENGTH +#undef COPY +#define ROUTINE_TYPE 'LOGICAL' +#define TYPE_DATA logical,intent(out) :: Data(*) +#define TYPE_BUFFER integer +#define TYPE_COUNT integer,intent(in) :: Count +#define TYPE_OUTCOUNT integer,intent(out) :: OutCount +#define NF_TYPE NF_INT +#define NF_ROUTINE NF_GET_VARA_INT +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 +#include "ext_ncd_get_var_td.code" +end subroutine ext_ncd_get_var_td_logical + +subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef COPY +#define ROUTINE_TYPE 'CHAR' +#define TYPE_DATA character*(*) ,intent(out) :: Data +#define TYPE_BUFFER +#define TYPE_COUNT integer :: Count = 1 +#define TYPE_OUTCOUNT +#define NF_TYPE NF_CHAR +#define NF_ROUTINE NF_GET_ATT_TEXT +#define COPY +#define CHAR_TYPE +#include "ext_ncd_get_var_ti.code" +#undef CHAR_TYPE +end subroutine ext_ncd_get_var_ti_char + +subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) +#undef ROUTINE_TYPE +#undef TYPE_DATA +#undef TYPE_BUFFER +#undef TYPE_COUNT +#undef TYPE_OUTCOUNT +#undef NF_TYPE +#undef NF_ROUTINE +#undef LENGTH +#define ROUTINE_TYPE 'CHAR' +#define TYPE_DATA character*(*) ,intent(out) :: Data +#define TYPE_BUFFER character (80) +#define TYPE_COUNT integer :: Count = 1 +#define TYPE_OUTCOUNT +#define NF_TYPE NF_CHAR +#define NF_ROUTINE NF_GET_VARA_TEXT +#define LENGTH Len1 +#define CHAR_TYPE +#include "ext_ncd_get_var_td.code" +#undef CHAR_TYPE +end subroutine ext_ncd_get_var_td_char + +subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_real + +subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_integer + +subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_double + +subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_logical + +subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + + call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_ncd_put_dom_td_char + +subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_real + +subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_integer + +subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_double + +subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_logical + +subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(out) :: Data + integer ,intent(out) :: Status + call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_ncd_get_dom_td_char + +subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, & + Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(inout) :: Field(*) + integer ,intent(in) :: FieldTypeIn + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrdIn + character*(*) ,intent(in) :: Stagger ! Dummy for now + character*(*) ,dimension(*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + integer :: FieldType + character (3) :: MemoryOrder + type(wrf_data_handle) ,pointer :: DH + integer :: NCID + integer :: NDim + character (VarNameLen) :: VarName + character (3) :: MemO + character (3) :: UCMemO + integer :: VarID + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: VDimIDs + character(80),dimension(NVarDims) :: RODimNames + integer ,dimension(NVarDims) :: StoredStart + integer ,dimension(:,:,:,:),allocatable :: XField + integer :: stat + integer :: NVar + integer :: i,j + integer :: i1,i2,j1,j2,k1,k2 + integer :: x1,x2,y1,y2,z1,z2 + integer :: l1,l2,m1,m2,n1,n2 + integer :: XType + integer :: di + character (80) :: NullName + logical :: NotFound + +#ifdef USE_NETCDF4_FEATURES + integer, parameter :: cache_size = 32000000 + integer,dimension(NVarDims) :: chunks + logical :: need_chunking + integer :: compression_level + integer :: block_size +#endif + + MemoryOrder = trim(adjustl(MemoryOrdIn)) + NullName=char(0) + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NCID = DH%NCID + +#ifdef USE_NETCDF4_FEATURES +if ( .not. DH%use_netcdf_classic ) then + call set_chunking(MemoryOrder,need_chunking) + compression_level = 2 +else + need_chunking = .false. +endif +#endif + + if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then + FieldType = WRF_REAL + else + FieldType = FieldTypeIn + end if + + write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) + +!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 + + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + + IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN + write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring' + call wrf_debug ( WARN , TRIM(msg)) + return + ENDIF + + call ExtOrder(MemoryOrder,Length,Status) + call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == VarName ) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = VarName + DH%NumVars = NVar + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + do j = 1,NDim + if(RODimNames(j) == NullName .or. RODimNames(j) == '') then + do i=1,MaxDims + if(DH%DimLengths(i) == Length(j)) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(i) = Length(j) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + else !look for input name and check if already defined + NotFound = .true. + do i=1,MaxDims + if (DH%DimNames(i) == RODimNames(j)) then + if (DH%DimLengths(i) == Length(j)) then + NotFound = .false. + exit + else + Status = WRF_WARN_DIMNAME_REDEFINED + write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & + TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + enddo + if (NotFound) then + do i=1,MaxDims + if (DH%DimLengths(i) == NO_DIM) then + DH%DimNames(i) = RODimNames(j) + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(i) = Length(j) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + endif + endif + VDimIDs(j) = DH%DimIDs(i) + DH%VarDimLens(j,NVar) = Length(j) + enddo + VDimIDs(NDim+1) = DH%DimUnlimID + + ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE + IF (FieldType == WRF_REAL) THEN + XType = NF_FLOAT + ELSE IF (FieldType == WRF_DOUBLE) THEN + Xtype = NF_DOUBLE + ELSE IF (FieldType == WRF_INTEGER) THEN + XType = NF_INT + ELSE IF (FieldType == WRF_LOGICAL) THEN + XType = NF_INT + ELSE + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + END IF + + stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + +#ifdef USE_NETCDF4_FEATURES + if(need_chunking) then + chunks(1:NDim) = Length(1:NDim) + chunks(NDim+1) = 1 + chunks(1) = (Length(1) + 1)/2 + chunks(2) = (Length(2) + 1)/2 + + block_size = 1 + do i = 1, NDim + block_size = block_size * chunks(i) + end do + + do while (block_size > cache_size) + chunks(1) = (chunks(1) + 1)/2 + chunks(2) = (chunks(2) + 1)/2 + + block_size = 1 + do i = 1, NDim + block_size = block_size * chunks(i) + end do + end do + +! write(unit=0, fmt='(2x, 3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ +! write(unit=0, fmt='(2x, 3a)') TRIM(VarName),':' +! write(unit=0, fmt='(10x, 2(a,i6))') 'length 1 = ', Length(1), ', chunk 1 = ', chunks(1) +! write(unit=0, fmt='(10x, 2(a,i6))') 'length 2 = ', Length(2), ', chunk 2 = ', chunks(2) +! write(unit=0, fmt='(10x, 2(a,i6))') 'length NDim+1 = ', Length(NDim+1), ', chunk NDim+1 = ', chunks(NDim+1) +! write(unit=0, fmt='(10x, a,i6)') 'compression_level = ', compression_level + + stat = NF_DEF_VAR_CHUNKING(NCID, VarID, NF_CHUNKED, chunks(1:NDim+1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF def chunking error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = NF_DEF_VAR_DEFLATE(NCID, VarID, 1, 1, compression_level) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF def compression error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif +#endif + + DH%VarIDs(NVar) = VarID + stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call reorder(MemoryOrder,MemO) + call uppercase(MemO,UCMemO) + stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + VarID = DH%VarIDs(NVar) + do j=1,NDim + if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then + Status = WRF_WARN_WRTLEN_NE_DRRUNLEN + write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & + VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) + call wrf_debug ( WARN , TRIM(msg)) + return +!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then + elseif(PatchStart(j) < MemoryStart(j)) then + Status = WRF_WARN_DIMENSION_ERROR + write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & + '| in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + StoredStart = 1 + call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) + call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) + call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) + di=1 + if(FieldType == WRF_DOUBLE) di=2 + allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then + call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + else + call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + end if + call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & + FieldType,NCID,VarID,XField,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + deallocate(XField, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + endif + DH%first_operation = .FALSE. + return +end subroutine ext_ncd_write_field + +subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & + IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(out) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrdIn + character*(*) ,intent(in) :: Stagger ! Dummy for now + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + character (3) :: MemoryOrder + character (NF_MAX_NAME) :: dimname + type(wrf_data_handle) ,pointer :: DH + integer :: NDim + integer :: NCID + character (VarNameLen) :: VarName + integer :: VarID + integer ,dimension(NVarDims) :: VCount + integer ,dimension(NVarDims) :: VStart + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: VDimIDs + integer ,dimension(NVarDims) :: MemS + integer ,dimension(NVarDims) :: MemE + integer ,dimension(NVarDims) :: StoredStart + integer ,dimension(NVarDims) :: StoredLen + integer ,dimension(:,:,:,:) ,allocatable :: XField + integer :: NVar + integer :: j + integer :: i1,i2,j1,j2,k1,k2 + integer :: x1,x2,y1,y2,z1,z2 + integer :: l1,l2,m1,m2,n1,n2 + character (VarNameLen) :: Name + integer :: XType + integer :: StoredDim + integer :: NAtts + integer :: Len + integer :: stat + integer :: di + integer :: FType + + MemoryOrder = trim(adjustl(MemoryOrdIn)) + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & + TRIM(Var),'| in ext_ncd_read_field ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & + '| in ext_ncd_read_field ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then +! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. +! Status = WRF_WARN_DRYRUN_READ +! write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ +! call wrf_debug ( WARN , TRIM(msg)) + Status = WRF_NO_ERR + RETURN + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then + NCID = DH%NCID + +!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + call ExtOrder(MemoryOrder,Length,Status) + stat = NF_INQ_VARID(NCID,VarName,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif +! allow coercion between double and single prec real +!jm if(FieldType /= Ftype) then + if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then + if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + else if(FieldType /= Ftype) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE + IF (FieldType == WRF_REAL) THEN +! allow coercion between double and single prec real + if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + ELSE IF (FieldType == WRF_DOUBLE) THEN +! allow coercion between double and single prec real + if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + ELSE IF (FieldType == WRF_INTEGER) THEN + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + ELSE IF (FieldType == WRF_LOGICAL) THEN + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + ELSE + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + END IF + + if(Status /= WRF_NO_ERR) then + call wrf_debug ( WARN , TRIM(msg)) + return + endif + ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 + IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN + stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + IF ( dimname(1:10) == 'ext_scalar' ) THEN + NDim = 1 + Length(1) = 1 + ENDIF + ENDIF + if(StoredDim /= NDim+1) then + Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM + write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) + call wrf_debug ( FATAL , msg) + write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 + call wrf_debug ( FATAL , msg) + return + endif + do j=1,NDim + stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(Length(j) > StoredLen(j)) then + Status = WRF_WARN_READ_PAST_EOF + write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Length(j) <= 0) then + Status = WRF_WARN_ZERO_LENGTH_READ + write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DomainStart(j) < MemoryStart(j)) then + Status = WRF_WARN_DIMENSION_ERROR + write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & + ') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) +! return + endif + enddo + + StoredStart = 1 + call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) + call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) +!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) + call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) + + di=1 + if(FieldType == WRF_DOUBLE) di=2 + allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & + FieldType,NCID,VarID,XField,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + deallocate(XField, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + DH%first_operation = .FALSE. + return +end subroutine ext_ncd_read_field + +subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(inout) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + !call upgrade_filename(FileName) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + FileStatus = WRF_FILE_NOT_OPENED + return + endif + if(trim(FileName) /= trim(DH%FileName)) then + FileStatus = WRF_FILE_NOT_OPENED + else + FileStatus = DH%FileStatus + endif + Status = WRF_NO_ERR + return +end subroutine ext_ncd_inquire_opened + +subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + FileStatus = WRF_FILE_NOT_OPENED + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + FileName = trim(DH%FileName) + FileStatus = DH%FileStatus + Status = WRF_NO_ERR + return +end subroutine ext_ncd_inquire_filename + +subroutine ext_ncd_set_time(DataHandle, DateStr, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: i + + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do i=1,MaxTimes + if(DH%Times(i)==DateStr) then + DH%CurrentTime = i + exit + endif + if(i==MaxTimes) then + Status = WRF_WARN_TIME_NF + return + endif + enddo + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_set_time + +subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then + if(DH%CurrentTime >= DH%NumberTimes) then + Status = WRF_WARN_TIME_EOF + return + endif + DH%CurrentTime = DH%CurrentTime +1 + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'DH%FileStatus ',DH%FileStatus + call wrf_debug ( FATAL , msg) + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_next_time + +subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + if(DH%CurrentTime.GT.0) then + DH%CurrentTime = DH%CurrentTime -1 + endif + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_previous_time + +subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: VarName + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + character (80) :: Name + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + + DH%CurrentVariable = DH%CurrentVariable +1 + if(DH%CurrentVariable > DH%NumVars) then + Status = WRF_WARN_VAR_EOF + return + endif + VarName = DH%VarNames(DH%CurrentVariable) + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_next_var + +subroutine ext_ncd_end_of_frame(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + return +end subroutine ext_ncd_end_of_frame + +! NOTE: For scalar variables NDim is set to zero and DomainStart and +! NOTE: DomainEnd are left unmodified. +subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Name + integer ,intent(out) :: NDim + character*(*) ,intent(out) :: MemoryOrder + character*(*) :: Stagger ! Dummy for now + integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd + integer ,intent(out) :: WrfType + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: VarID + integer ,dimension(NVarDims) :: VDimIDs + integer :: j + integer :: stat + integer :: XType + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_INQ_VARID(DH%NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + select case (XType) + case (NF_BYTE) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + case (NF_CHAR) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + case (NF_SHORT) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + case (NF_INT) + if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case (NF_FLOAT) + if(WrfType /= WRF_REAL) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case (NF_DOUBLE) + if(WrfType /= WRF_DOUBLE) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end select + + stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + do j = 1, NDim + DomainStart(j) = 1 + stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_info + +subroutine ext_ncd_warning_str( Code, ReturnString, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + + integer , intent(in) ::Code + character *(*), intent(out) :: ReturnString + integer, intent(out) ::Status + + SELECT CASE (Code) + CASE (0) + ReturnString='No error' + Status=WRF_NO_ERR + return + CASE (-1) + ReturnString= 'File not found (or file is incomplete)' + Status=WRF_NO_ERR + return + CASE (-2) + ReturnString='Metadata not found' + Status=WRF_NO_ERR + return + CASE (-3) + ReturnString= 'Timestamp not found' + Status=WRF_NO_ERR + return + CASE (-4) + ReturnString= 'No more timestamps' + Status=WRF_NO_ERR + return + CASE (-5) + ReturnString= 'Variable not found' + Status=WRF_NO_ERR + return + CASE (-6) + ReturnString= 'No more variables for the current time' + Status=WRF_NO_ERR + return + CASE (-7) + ReturnString= 'Too many open files' + Status=WRF_NO_ERR + return + CASE (-8) + ReturnString= 'Data type mismatch' + Status=WRF_NO_ERR + return + CASE (-9) + ReturnString= 'Attempt to write read-only file' + Status=WRF_NO_ERR + return + CASE (-10) + ReturnString= 'Attempt to read write-only file' + Status=WRF_NO_ERR + return + CASE (-11) + ReturnString= 'Attempt to access unopened file' + Status=WRF_NO_ERR + return + CASE (-12) + ReturnString= 'Attempt to do 2 trainings for 1 variable' + Status=WRF_NO_ERR + return + CASE (-13) + ReturnString= 'Attempt to read past EOF' + Status=WRF_NO_ERR + return + CASE (-14) + ReturnString= 'Bad data handle' + Status=WRF_NO_ERR + return + CASE (-15) + ReturnString= 'Write length not equal to training length' + Status=WRF_NO_ERR + return + CASE (-16) + ReturnString= 'More dimensions requested than training' + Status=WRF_NO_ERR + return + CASE (-17) + ReturnString= 'Attempt to read more data than exists' + Status=WRF_NO_ERR + return + CASE (-18) + ReturnString= 'Input dimensions inconsistent' + Status=WRF_NO_ERR + return + CASE (-19) + ReturnString= 'Input MemoryOrder not recognized' + Status=WRF_NO_ERR + return + CASE (-20) + ReturnString= 'A dimension name with 2 different lengths' + Status=WRF_NO_ERR + return + CASE (-21) + ReturnString= 'String longer than provided storage' + Status=WRF_NO_ERR + return + CASE (-22) + ReturnString= 'Function not supportable' + Status=WRF_NO_ERR + return + CASE (-23) + ReturnString= 'Package implements this routine as NOOP' + Status=WRF_NO_ERR + return + +!netcdf-specific warning messages + CASE (-1007) + ReturnString= 'Bad data type' + Status=WRF_NO_ERR + return + CASE (-1008) + ReturnString= 'File not committed' + Status=WRF_NO_ERR + return + CASE (-1009) + ReturnString= 'File is opened for reading' + Status=WRF_NO_ERR + return + CASE (-1011) + ReturnString= 'Attempt to write metadata after open commit' + Status=WRF_NO_ERR + return + CASE (-1010) + ReturnString= 'I/O not initialized' + Status=WRF_NO_ERR + return + CASE (-1012) + ReturnString= 'Too many variables requested' + Status=WRF_NO_ERR + return + CASE (-1013) + ReturnString= 'Attempt to close file during a dry run' + Status=WRF_NO_ERR + return + CASE (-1014) + ReturnString= 'Date string not 19 characters in length' + Status=WRF_NO_ERR + return + CASE (-1015) + ReturnString= 'Attempt to read zero length words' + Status=WRF_NO_ERR + return + CASE (-1016) + ReturnString= 'Data type not found' + Status=WRF_NO_ERR + return + CASE (-1017) + ReturnString= 'Badly formatted date string' + Status=WRF_NO_ERR + return + CASE (-1018) + ReturnString= 'Attempt at read during a dry run' + Status=WRF_NO_ERR + return + CASE (-1019) + ReturnString= 'Attempt to get zero words' + Status=WRF_NO_ERR + return + CASE (-1020) + ReturnString= 'Attempt to put zero length words' + Status=WRF_NO_ERR + return + CASE (-1021) + ReturnString= 'NetCDF error' + Status=WRF_NO_ERR + return + CASE (-1022) + ReturnString= 'Requested length <= 1' + Status=WRF_NO_ERR + return + CASE (-1023) + ReturnString= 'More data available than requested' + Status=WRF_NO_ERR + return + CASE (-1024) + ReturnString= 'New date less than previous date' + Status=WRF_NO_ERR + return + + CASE DEFAULT + ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & + & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & + & to be calling a package-specific routine to return a message for this warning code.' + Status=WRF_NO_ERR + END SELECT + + return +end subroutine ext_ncd_warning_str + +!returns message string for all WRF and netCDF warning/error status codes +!Other i/o packages must provide their own routines to return their own status messages +subroutine ext_ncd_error_str( Code, ReturnString, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + + integer , intent(in) ::Code + character *(*), intent(out) :: ReturnString + integer, intent(out) ::Status + + SELECT CASE (Code) + CASE (-100) + ReturnString= 'Allocation Error' + Status=WRF_NO_ERR + return + CASE (-101) + ReturnString= 'Deallocation Error' + Status=WRF_NO_ERR + return + CASE (-102) + ReturnString= 'Bad File Status' + Status=WRF_NO_ERR + return + CASE (-1004) + ReturnString= 'Variable on disk is not 3D' + Status=WRF_NO_ERR + return + CASE (-1005) + ReturnString= 'Metadata on disk is not 1D' + Status=WRF_NO_ERR + return + CASE (-1006) + ReturnString= 'Time dimension too small' + Status=WRF_NO_ERR + return + CASE DEFAULT + ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & + & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & + & to be calling a package-specific routine to return a message for this error code.' + Status=WRF_NO_ERR + END SELECT + + return +end subroutine ext_ncd_error_str diff --git a/src/wrflib/wrf_io.f90 b/src/wrflib/wrf_io.f90 new file mode 100644 index 0000000000..278249138e --- /dev/null +++ b/src/wrflib/wrf_io.f90 @@ -0,0 +1,8169 @@ +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + +module wrf_data + + integer , parameter :: FATAL = 1 + integer , parameter :: WARN = 1 + integer , parameter :: WrfDataHandleMax = 99 + integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS + + + + integer , parameter :: MaxVars = 3000 + + integer , parameter :: MaxTimes = 10000 + integer , parameter :: DateStrLen = 19 + integer , parameter :: VarNameLen = 31 + integer , parameter :: NO_DIM = 0 + integer , parameter :: NVarDims = 4 + integer , parameter :: NMDVarDims = 2 + character (8) , parameter :: NO_NAME = 'NULL' + character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' + integer, parameter :: WRF_FILE_NOT_OPENED = 100 + integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 + integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 + integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 + integer, parameter :: WRF_REAL = 104 + integer, parameter :: WRF_DOUBLE = 105 + integer, parameter :: WRF_FLOAT=WRF_REAL + integer, parameter :: WRF_INTEGER = 106 + integer, parameter :: WRF_LOGICAL = 107 + integer, parameter :: WRF_COMPLEX = 108 + integer, parameter :: WRF_DOUBLE_COMPLEX = 109 + integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 +! This bit is for backwards compatibility with old variants of these flags +! that are still being used in io_grib1 and io_phdf5. It should be removed! + integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 + character (256) :: msg + logical :: WrfIOnotInitialized = .true. + type :: wrf_data_handle + character (255) :: FileName + integer :: FileStatus + integer :: Comm + integer :: NCID + logical :: Free + logical :: Write + character (5) :: TimesName + integer :: TimeIndex + integer :: CurrentTime !Only used for read + integer :: NumberTimes !Only used for read + character (DateStrLen), pointer :: Times(:) + integer :: TimesVarID + integer , pointer :: DimLengths(:) + integer , pointer :: DimIDs(:) + character (31) , pointer :: DimNames(:) + integer :: DimUnlimID + character (9) :: DimUnlimName + integer , dimension(NVarDims) :: DimID + integer , dimension(NVarDims) :: Dimension + integer , pointer :: MDVarIDs(:) + integer , pointer :: MDVarDimLens(:) + character (80) , pointer :: MDVarNames(:) + integer , pointer :: VarIDs(:) + integer , pointer :: VarDimLens(:,:) + character (VarNameLen), pointer :: VarNames(:) + integer :: CurrentVariable !Only used for read + integer :: NumVars +! first_operation is set to .TRUE. when a new handle is allocated +! or when open-for-write or open-for-read are committed. It is set +! to .FALSE. when the first field is read or written. + logical :: first_operation + logical :: R4OnOutput + logical :: nofill + logical :: use_netcdf_classic + end type wrf_data_handle + type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) +end module wrf_data +module ext_ncd_support_routines + implicit none +CONTAINS +subroutine allocHandle(DataHandle,DH,Comm,Status) + use wrf_data + include 'wrf_status_codes.h' + integer ,intent(out) :: DataHandle + type(wrf_data_handle),pointer :: DH + integer ,intent(IN) :: Comm + integer ,intent(out) :: Status + integer :: i + integer :: stat + do i=1,WrfDataHandleMax + if(WrfDataHandles(i)%Free) then + DH => WrfDataHandles(i) + DataHandle = i + allocate(DH%Times(MaxTimes), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 124 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%DimLengths(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 131 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%DimIDs(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 138 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%DimNames(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 145 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%MDVarIDs(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 152 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%MDVarDimLens(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 159 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%MDVarNames(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 166 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%VarIDs(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 173 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 180 + call wrf_debug ( FATAL , msg) + return + endif + allocate(DH%VarNames(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 187 + call wrf_debug ( FATAL , msg) + return + endif + exit + endif + if(i==WrfDataHandleMax) then + Status = WRF_WARN_TOO_MANY_FILES + write(msg,*) 'Warning TOO MANY FILES in ',"wrf_io.F90",', line', 195 + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) 'Did you call ext_ncd_ioinit?' + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + DH%Free =.false. + DH%Comm = Comm + DH%Write =.false. + DH%first_operation = .TRUE. + DH%R4OnOutput = .false. + DH%nofill = .false. + Status = WRF_NO_ERR +end subroutine allocHandle +subroutine deallocHandle(DataHandle, Status) + use wrf_data + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN + if(.NOT. WrfDataHandles(DataHandle)%Free) then + DH => WrfDataHandles(DataHandle) + deallocate(DH%Times, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 226 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DimLengths, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 233 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DimIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 240 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DimNames, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 247 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDVarIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 254 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDVarDimLens, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 261 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDVarNames, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 268 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%VarIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 275 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%VarDimLens, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 282 + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%VarNames, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 289 + call wrf_debug ( FATAL , msg) + return + endif + DH%Free =.TRUE. + endif + ENDIF + Status = WRF_NO_ERR +end subroutine deallocHandle +subroutine GetDH(DataHandle,DH,Status) + use wrf_data + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + type(wrf_data_handle) ,pointer :: DH + integer ,intent(out) :: Status + if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then + Status = WRF_WARN_BAD_DATA_HANDLE + return + endif + DH => WrfDataHandles(DataHandle) + if(DH%Free) then + Status = WRF_WARN_BAD_DATA_HANDLE + return + endif + Status = WRF_NO_ERR + return +end subroutine GetDH +subroutine DateCheck(Date,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Date + integer ,intent(out) :: Status + if(len(Date) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + else + Status = WRF_NO_ERR + endif + return +end subroutine DateCheck + +subroutine GetName(Element,Var,Name,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Name + integer ,intent(out) :: Status + character (VarNameLen) :: VarName + character (1) :: c + integer :: i + integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') + + VarName = Var + Name = 'MD___' + do i=1,len(Name) + c=Name(i:i) + if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) + if(c=='-'.or.c==':') Name(i:i)='_' + enddo + Status = WRF_NO_ERR + return +end subroutine GetName + +subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + use wrf_data + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: TimeIndex + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: VStart(2) + integer :: VCount(2) + integer :: stat + integer :: i + + DH => WrfDataHandles(DataHandle) + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_WARN_DATESTR_ERROR + write(msg,*) 'Warning DATE STRING ERROR in ',"wrf_io.F90",', line', 375 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(IO == 'write') then + TimeIndex = DH%TimeIndex + if(TimeIndex <= 0) then + TimeIndex = 1 + elseif(DateStr == DH%Times(TimeIndex)) then + Status = WRF_NO_ERR + return + else + TimeIndex = TimeIndex +1 + if(TimeIndex > MaxTimes) then + Status = WRF_WARN_TIME_EOF + write(msg,*) 'Warning TIME EOF in ',"wrf_io.F90",', line', 390 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + DH%TimeIndex = TimeIndex + DH%Times(TimeIndex) = DateStr + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = DateStrLen + VCount(2) = 1 + stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 404 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + else + do i=1,MaxTimes + if(DH%Times(i)==DateStr) then + Status = WRF_NO_ERR + TimeIndex = i + exit + endif + if(i==MaxTimes) then + Status = WRF_WARN_TIME_NF + write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"wrf_io.F90",', line', 417 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + endif + return +end subroutine GetTimeIndex + +subroutine GetDim(MemoryOrder,NDim,Status) + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(out) :: NDim + integer ,intent(out) :: Status + character*3 :: MemOrd + + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') + NDim = 3 + case ('xy','yx','xs','xe','ys','ye','cc') + NDim = 2 + case ('z','c') + NDim = 1 + case ('0') ! NDim=0 for scalars. TBH: 20060502 + NDim = 0 + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine GetDim +subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) + integer ,intent(in) :: NDim + integer ,dimension(*),intent(in) :: Start,End + integer ,intent(out) :: i1,i2,j1,j2,k1,k2 + i1=1 + i2=1 + j1=1 + j2=1 + k1=1 + k2=1 + if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 + i1 = Start(1) + i2 = End (1) + if(NDim == 1) return + j1 = Start(2) + j2 = End (2) + if(NDim == 2) return + k1 = Start(3) + k2 = End (3) + return +end subroutine GetIndices +logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer,dimension(*) ,intent(in) :: Vector + integer ,intent(out) :: Status + integer :: NDim + integer,dimension(NVarDims) :: temp + character*3 :: MemOrd + logical zero_length + call GetDim(MemoryOrder,NDim,Status) + temp(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + zero_length = .false. + select case (MemOrd) + case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy','yzx') + zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 + case ('xy','yx','xyz','yxz') + zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 + case ('zxy','zyx') + zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 + case default + Status = WRF_WARN_BAD_MEMORYORDER + ZeroLengthHorzDim = .true. + return + end select + Status = WRF_NO_ERR + ZeroLengthHorzDim = zero_length + return +end function ZeroLengthHorzDim +subroutine ExtOrder(MemoryOrder,Vector,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer,dimension(*) ,intent(inout) :: Vector + integer ,intent(out) :: Status + integer :: NDim + integer,dimension(NVarDims) :: temp + character*3 :: MemOrd + call GetDim(MemoryOrder,NDim,Status) + temp(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy') + Vector(2) = temp(3) + Vector(3) = temp(2) + case ('yxz') + Vector(1) = temp(2) + Vector(2) = temp(1) + case ('yzx') + Vector(1) = temp(3) + Vector(2) = temp(1) + Vector(3) = temp(2) + case ('zxy') + Vector(1) = temp(2) + Vector(2) = temp(3) + Vector(3) = temp(1) + case ('zyx') + Vector(1) = temp(3) + Vector(3) = temp(1) + case ('yx') + Vector(1) = temp(2) + Vector(2) = temp(1) + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrder +subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) + use wrf_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*(*),dimension(*) ,intent(in) :: Vector + character(80),dimension(NVarDims),intent(out) :: ROVector + integer ,intent(out) :: Status + integer :: NDim + character*3 :: MemOrd + call GetDim(MemoryOrder,NDim,Status) + ROVector(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy') + ROVector(2) = Vector(3) + ROVector(3) = Vector(2) + case ('yxz') + ROVector(1) = Vector(2) + ROVector(2) = Vector(1) + case ('yzx') + ROVector(1) = Vector(3) + ROVector(2) = Vector(1) + ROVector(3) = Vector(2) + case ('zxy') + ROVector(1) = Vector(2) + ROVector(2) = Vector(3) + ROVector(3) = Vector(1) + case ('zyx') + ROVector(1) = Vector(3) + ROVector(3) = Vector(1) + case ('yx') + ROVector(1) = Vector(2) + ROVector(2) = Vector(1) + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrderStr +subroutine LowerCase(MemoryOrder,MemOrd) + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(out) :: MemOrd + character*1 :: c + integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') + integer :: i,N + MemOrd = ' ' + N = len(MemoryOrder) + MemOrd(1:N) = MemoryOrder(1:N) + do i=1,N + c = MemoryOrder(i:i) + if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) + enddo + return +end subroutine LowerCase +subroutine UpperCase(MemoryOrder,MemOrd) + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(out) :: MemOrd + character*1 :: c + integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') + integer :: i,N + MemOrd = ' ' + N = len(MemoryOrder) + MemOrd(1:N) = MemoryOrder(1:N) + do i=1,N + c = MemoryOrder(i:i) + if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) + enddo + return +end subroutine UpperCase +subroutine netcdf_err(err,Status) + use wrf_data + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: err + integer ,intent(out) :: Status + character(len=80) :: errmsg + integer :: stat + if( err==NF_NOERR )then + Status = WRF_NO_ERR + else + errmsg = NF_STRERROR(err) + write(msg,*) 'NetCDF error: ',errmsg + call wrf_debug ( WARN , TRIM(msg)) + Status = WRF_WARN_NETCDF + endif + return +end subroutine netcdf_err +subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & + ,FieldType,NCID,VarID,XField,Status) + use wrf_data + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer,dimension(NVarDims),intent(in) :: Length + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: FieldType + integer ,intent(in) :: NCID + integer ,intent(in) :: VarID + integer,dimension(*) ,intent(inout) :: XField + integer ,intent(out) :: Status + integer :: TimeIndex + integer :: NDim + integer,dimension(NVarDims) :: VStart + integer,dimension(NVarDims) :: VCount +! include 'wrf_io_flags.h' + call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',"wrf_io.F90",', line', 704 + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' Bad time index for DateStr = ',DateStr + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDim(MemoryOrder,NDim,Status) + VStart(:) = 1 + VCount(:) = 1 + VStart(1:NDim) = 1 + VCount(1:NDim) = Length(1:NDim) + VStart(NDim+1) = TimeIndex + VCount(NDim+1) = 1 + ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE + IF (FieldType == WRF_REAL) THEN + call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + ELSE IF (FieldType == WRF_DOUBLE) THEN + call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + ELSE IF (FieldType == WRF_INTEGER) THEN + call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + ELSE IF (FieldType == WRF_LOGICAL) THEN + call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + if(Status /= WRF_NO_ERR) return + ELSE + write(6,*) 'WARNING---- some missing calls commented out' + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 731 + call wrf_debug ( WARN , TRIM(msg)) + return + END IF + return +end subroutine FieldIO +subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + character*(*) ,intent(in) :: IO + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: l1,l2,m1,m2,n1,n2 + integer ,intent(in) :: di + integer ,intent(in) :: x1,x2,y1,y2,z1,z2 + integer ,intent(in) :: i1,i2,j1,j2,k1,k2 + integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) +!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) + integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) + character*3 :: MemOrd + character*3 :: MemO + integer ,parameter :: MaxUpperCase=IACHAR('Z') + integer :: i,j,k,ix,jx,kx + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) +! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) + case ('xzy') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('yxz') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('zxy') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('yzx') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('zyx') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('yx') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + end select + return +end subroutine Transpose +subroutine reorder (MemoryOrder,MemO) + character*(*) ,intent(in) :: MemoryOrder + character*3 ,intent(out) :: MemO + character*3 :: MemOrd + integer :: N,i,i1,i2,i3 + MemO = MemoryOrder + N = len_trim(MemoryOrder) + if(N == 1) return + call lowercase(MemoryOrder,MemOrd) +! never invert the boundary codes + select case ( MemOrd ) + case ( 'xsz','xez','ysz','yez' ) + return + case default + continue + end select + i1 = 1 + i3 = 1 + do i=2,N + if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i + if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i + enddo + if(N == 2) then + i2=i3 + else + i2 = 6-i1-i3 + endif + MemO(1:1) = MemoryOrder(i1:i1) + MemO(2:2) = MemoryOrder(i2:i2) + if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) + if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then + MemO(1:N-1) = MemO(2:N) + MemO(N:N ) = MemoryOrder(i1:i1) + endif + return +end subroutine reorder +! Returns .TRUE. iff it is OK to write time-independent domain metadata to the +! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is +! returned. +LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) + USE wrf_data + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, first_output, retval + call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & + ', line', 846 + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + first_output = ncd_is_first_operation( DataHandle ) + retval = .NOT. dryrun .AND. first_output + ENDIF + ncd_ok_to_put_dom_ti = retval + RETURN +END FUNCTION ncd_ok_to_put_dom_ti +! Returns .TRUE. iff it is OK to read time-independent domain metadata from the +! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is +! returned. +LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) + USE wrf_data + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, retval + call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & + ', line', 872 + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + retval = .NOT. dryrun + ENDIF + ncd_ok_to_get_dom_ti = retval + RETURN +END FUNCTION ncd_ok_to_get_dom_ti +! Returns .TRUE. iff nothing has been read from or written to the file +! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. +LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) + USE wrf_data + INCLUDE 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + TYPE(wrf_data_handle) ,POINTER :: DH + INTEGER :: Status + LOGICAL :: retval + CALL GetDH( DataHandle, DH, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & + ', line', 895 + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + retval = DH%first_operation + ENDIF + ncd_is_first_operation = retval + RETURN +END FUNCTION ncd_is_first_operation +subroutine upgrade_filename(FileName) + implicit none + character*(*), intent(inout) :: FileName + integer :: i + do i = 1, len(trim(FileName)) + if(FileName(i:i) == '-') then + FileName(i:i) = '_' + else if(FileName(i:i) == ':') then + FileName(i:i) = '_' + endif + enddo +end subroutine upgrade_filename +end module ext_ncd_support_routines +subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + use ext_ncd_support_routines + character*(*) ,intent(in) :: IO + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: l1,l2,m1,m2,n1,n2 + integer ,intent(in) :: di + integer ,intent(in) :: x1,x2,y1,y2,z1,z2 + integer ,intent(in) :: i1,i2,j1,j2,k1,k2 + real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) + real*4 ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) + character*3 :: MemOrd + character*3 :: MemO + integer ,parameter :: MaxUpperCase=IACHAR('Z') + integer :: i,j,k,ix,jx,kx + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) +!#define A-A1+1+(A2-A1+1)*((B-B1)+(C-C1)*(B2-B1+1)) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) +! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) + case ('xzy') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('yxz') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('zxy') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('yzx') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('zyx') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + case ('yx') + ix=0 + jx=0 + kx=0 + call reorder(MemoryOrder,MemO) + if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 + if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 + if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 +! pjj/cray + if(IO == 'write') then +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) + enddo + enddo + enddo +!$OMP END PARALLEL DO +else +!!dir$ concurrent +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=k1,k2 + do j=j1,j2 +!!dir$ prefervector +!!dir$ concurrent +!cdir select(vector) + do i=i1,i2 + Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) + enddo + enddo + enddo +!$OMP END PARALLEL DO +endif + return + end select + return +end subroutine TransposeToR4 +subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character *(*), INTENT(IN) :: DatasetName + integer , INTENT(IN) :: Comm1, Comm2 + character *(*), INTENT(IN) :: SysDepInfo + integer , INTENT(OUT) :: DataHandle + integer , INTENT(OUT) :: Status + DataHandle = 0 ! dummy setting to quiet warning message + CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) + IF ( Status .EQ. WRF_NO_ERR ) THEN + CALL ext_ncd_open_for_read_commit( DataHandle, Status ) + ENDIF + return +end subroutine ext_ncd_open_for_read +!ends training phase; switches internal flag to enable input +!must be paired with call to ext_ncd_open_for_read_begin +subroutine ext_ncd_open_for_read_commit(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer, intent(in) :: DataHandle + integer, intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1013 + call wrf_debug ( FATAL , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1019 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_READ + DH%first_operation = .TRUE. + Status = WRF_NO_ERR + return +end subroutine ext_ncd_open_for_read_commit +subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character*(*) ,intent(INOUT) :: FileName + integer ,intent(IN) :: Comm + integer ,intent(IN) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: VarID + integer :: StoredDim + integer :: NAtts + integer :: DimIDs(2) + integer :: VStart(2) + integer :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + character (NF_MAX_NAME) :: Name + !call upgrade_filename(FileName) + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1064 + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 1070 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1078 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1085 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1092 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(XType/=NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 1098 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1105 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(1) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + write(msg,*) 'Warning DATESTR BAD LENGTH in ',"wrf_io.F90",', line', 1111 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1118 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(2) > MaxTimes) then + Status = WRF_ERR_FATAL_TOO_MANY_TIMES + write(msg,*) 'Fatal TOO MANY TIME VALUES in ',"wrf_io.F90",', line', 1124 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + VStart(1) = 1 + VStart(2) = 1 + stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1133 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1140 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NumVars = 0 + do i=1,TotalNumVars + stat = NF_INQ_VARNAME(DH%NCID,i,Name) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1149 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then + NumVars = NumVars+1 + DH%VarNames(NumVars) = Name + DH%VarIDs(NumVars) = i + endif + enddo + DH%NumVars = NumVars + DH%NumberTimes = VLen(2) + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = trim(FileName) + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimesVarID = VarID + DH%TimeIndex = 0 + return +end subroutine ext_ncd_open_for_read_begin +subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character*(*) ,intent(INOUT) :: FileName + integer ,intent(IN) :: Comm + integer ,intent(IN) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: VarID + integer :: StoredDim + integer :: NAtts + integer :: DimIDs(2) + integer :: VStart(2) + integer :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + character (NF_MAX_NAME) :: Name + !call upgrade_filename(FileName) + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1204 + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 1210 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1217 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1224 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1231 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(XType/=NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 1237 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1244 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(1) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + write(msg,*) 'Warning DATESTR BAD LENGTH in ',"wrf_io.F90",', line', 1250 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1257 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(2) > MaxTimes) then + Status = WRF_ERR_FATAL_TOO_MANY_TIMES + write(msg,*) 'Fatal TOO MANY TIME VALUES in ',"wrf_io.F90",', line', 1263 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + VStart(1) = 1 + VStart(2) = 1 + stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1272 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1279 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NumVars = 0 + do i=1,TotalNumVars + stat = NF_INQ_VARNAME(DH%NCID,i,Name) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1288 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then + NumVars = NumVars+1 + DH%VarNames(NumVars) = Name + DH%VarIDs(NumVars) = i + endif + enddo + DH%NumVars = NumVars + DH%NumberTimes = VLen(2) + DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE + DH%FileName = trim(FileName) + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimesVarID = VarID + DH%TimeIndex = 0 + return +end subroutine ext_ncd_open_for_update +SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character*(*) ,intent(inout) :: FileName + integer ,intent(in) :: Comm + integer ,intent(in) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + character (7) :: Buffer + integer :: VDimIDs(2) + !call upgrade_filename(FileName) + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1338 + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1344 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + DH%TimeIndex = 0 + DH%Times = ZeroDate + stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1374 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = trim(FileName) + stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1383 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%VarNames (1:MaxVars) = NO_NAME + DH%MDVarNames(1:MaxVars) = NO_NAME + do i=1,MaxDims + write(Buffer,FMT="('DIM',i4.4)") i + DH%DimNames (i) = Buffer + DH%DimLengths(i) = NO_DIM + enddo + DH%DimNames(1) = 'DateStrLen' + stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1398 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VDimIDs(1) = DH%DimIDs(1) + VDimIDs(2) = DH%DimUnlimID + stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1407 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(1) = DateStrLen + if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then + DH%R4OnOutput = .true. + end if +!toggle on nofill mode + if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then + DH%nofill = .true. + end if + return +end subroutine ext_ncd_open_for_write_begin +!stub +!opens a file for writing or coupler datastream for sending messages. +!no training phase for this version of the open stmt. +subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & + SysDepInfo, DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character *(*), intent(in) ::DatasetName + integer , intent(in) ::Comm1, Comm2 + character *(*), intent(in) ::SysDepInfo + integer , intent(out) :: DataHandle + integer , intent(out) :: Status + Status=WRF_WARN_NOOP + DataHandle = 0 ! dummy setting to quiet warning message + return +end subroutine ext_ncd_open_for_write +SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + integer :: oldmode ! for nf_set_fill, not used + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1459 + call wrf_debug ( FATAL , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',"wrf_io.F90",', line', 1465 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if ( DH%nofill ) then + Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode ) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',"wrf_io.F90",', line', 1472 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName) + call wrf_debug ( WARN , TRIM(msg)) + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',"wrf_io.F90",', line', 1482 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE + DH%first_operation = .TRUE. + return +end subroutine ext_ncd_open_for_write_commit +subroutine ext_ncd_ioclose(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',"wrf_io.F90",', line', 1504 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',"wrf_io.F90",', line', 1510 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_CLOSE + write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',"wrf_io.F90",', line', 1514 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + continue + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',"wrf_io.F90",', line', 1524 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_CLOSE(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_ioclose ',"wrf_io.F90",', line', 1532 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + CALL deallocHandle( DataHandle, Status ) + DH%Free=.true. + return +end subroutine ext_ncd_ioclose +subroutine ext_ncd_iosync( DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',"wrf_io.F90",', line', 1554 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',"wrf_io.F90",', line', 1560 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',"wrf_io.F90",', line', 1564 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + continue + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',"wrf_io.F90",', line', 1572 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_SYNC(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_ncd_iosync ',"wrf_io.F90",', line', 1579 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + return +end subroutine ext_ncd_iosync +subroutine ext_ncd_redef( DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1601 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 1607 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 1611 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_FILE_OPEN_FOR_READ + write(msg,*) 'Warning FILE OPEN FOR READ in ',"wrf_io.F90",', line', 1619 + call wrf_debug ( WARN , TRIM(msg)) + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 1623 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1630 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + return +end subroutine ext_ncd_redef +subroutine ext_ncd_enddef( DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1651 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 1657 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 1661 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_FILE_OPEN_FOR_READ + write(msg,*) 'Warning FILE OPEN FOR READ in ',"wrf_io.F90",', line', 1667 + call wrf_debug ( WARN , TRIM(msg)) + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 1671 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1678 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE + return +end subroutine ext_ncd_enddef +subroutine ext_ncd_ioinit(SysDepInfo, Status) + use wrf_data + implicit none + include 'wrf_status_codes.h' + CHARACTER*(*), INTENT(IN) :: SysDepInfo + INTEGER ,INTENT(INOUT) :: Status + WrfIOnotInitialized = .false. + WrfDataHandles(1:WrfDataHandleMax)%Free = .true. + WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' + WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' + WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED + if(trim(SysDepInfo) == "use_netcdf_classic" ) then + WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true. + else + WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false. + endif + Status = WRF_NO_ERR + return +end subroutine ext_ncd_ioinit +subroutine ext_ncd_inquiry (Inquiry, Result, Status) + use wrf_data + implicit none + include 'wrf_status_codes.h' + character *(*), INTENT(IN) :: Inquiry + character *(*), INTENT(OUT) :: Result + integer ,INTENT(INOUT) :: Status + SELECT CASE (Inquiry) + CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") + Result='ALLOW' + CASE ("OPEN_READ","OPEN_COMMIT_WRITE") + Result='REQUIRE' + CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") + Result='NO' + CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") + Result='YES' + CASE ("MEDIUM") + Result ='FILE' + CASE DEFAULT + Result = 'No Result for that inquiry!' + END SELECT + Status=WRF_NO_ERR + return +end subroutine ext_ncd_inquiry +subroutine ext_ncd_ioexit(Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer , INTENT(INOUT) ::Status + integer :: error + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1749 + call wrf_debug ( FATAL , msg) + return + endif + do i=1,WrfDataHandleMax + CALL deallocHandle( i , stat ) + enddo + return +end subroutine ext_ncd_ioexit +subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + real,allocatable :: Buffer(:) + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 57 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to read time-independent domain metadata. +IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 66 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 71 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 76 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 83,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 91 + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=NF_FLOAT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 99 + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) & +'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 107 + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 116 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_REAL (DH%NCID,NF_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 138 + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 153 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_get_dom_ti_real +subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + integer,allocatable :: Buffer(:) + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 57 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to read time-independent domain metadata. +IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 66 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 71 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 76 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 83,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 91 + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 99 + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) & +'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 107 + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 116 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_INT (DH%NCID,NF_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 138 + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 153 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_get_dom_ti_integer +subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + real*8,allocatable :: Buffer(:) + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 57 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to read time-independent domain metadata. +IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 66 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 71 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 76 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 83,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 91 + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=NF_DOUBLE) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 99 + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) & +'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 107 + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 116 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 138 + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 153 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_get_dom_ti_double +subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + integer,allocatable :: Buffer(:) + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 57 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to read time-independent domain metadata. +IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 66 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 71 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 76 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 83,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 91 + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 99 + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) & +'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 107 + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 116 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_INT (DH%NCID,NF_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 138 + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 153 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_get_dom_ti_logical +subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*),intent(out) :: Data + + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 57 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to read time-independent domain metadata. +IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 66 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 71 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 76 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 83,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 91 + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 99 + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) & +'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 107 + call wrf_debug ( WARN , msg) + return + endif + Data = '' + stat = NF_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 153 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_get_dom_ti_char +subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real ,intent(in) :: Data(*) + integer,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 56 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to write time-independent domain metadata. +IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 65 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 70 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = NF_PUT_ATT_REAL (DH%NCID,NF_GLOBAL,Element,NF_FLOAT,Count,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 101,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 110,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_PUT_ATT_REAL (DH%NCID,NF_GLOBAL,Element,NF_FLOAT,Count,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 153,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 160 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_put_dom_ti_real +subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer,intent(in) :: Data(*) + integer,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 56 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to write time-independent domain metadata. +IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 65 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 70 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 101,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 110,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 153,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 160 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_put_dom_ti_integer +subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8 ,intent(in) :: Data(*) + integer,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 56 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to write time-independent domain metadata. +IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 65 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 70 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = NF_PUT_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,NF_DOUBLE,Count,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 101,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 110,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_PUT_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,NF_DOUBLE,Count,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 153,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 160 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_put_dom_ti_double +subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical,intent(in) :: Data(*) + integer,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 56 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to write time-independent domain metadata. +IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 65 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 70 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 77 + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Buffer) + deallocate(Buffer, STAT=stat2) + if(stat2/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 92 + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 101,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 110,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 119 + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Buffer) + deallocate(Buffer, STAT=stat2) + if(stat2/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 135 + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 153,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 160 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_put_dom_ti_logical +subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*),intent(in) :: Data + integer,parameter :: Count=1 + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 56 + call wrf_debug ( WARN , msg) + return + endif +! Do nothing unless it is time to write time-independent domain metadata. +IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 65 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 70 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = NF_PUT_ATT_TEXT (DH%NCID,NF_GLOBAL,Element,len_trim(Data),Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 101,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_REDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 110,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_PUT_ATT_TEXT (DH%NCID,NF_GLOBAL,Element,len_trim(Data),Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 153,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 160 + call wrf_debug ( FATAL , msg) + endif +ENDIF + return +end subroutine ext_ncd_put_dom_ti_char +subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 61 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 68 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 73 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) & +'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 78 + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 88 & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_PUT_ATT_REAL(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_FLOAT,Count,Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 124 + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 140 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_ti_real +subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 67 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 74 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 82 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 89 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 94 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%MDVarNames(NVar) == NO_NAME) then + DH%MDVarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 111 + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 124,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) & +'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 133 + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%MDVarDimLens(NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + stat = NF_DEF_VAR(NCID,Name,NF_FLOAT,2,VDims,DH%MDVarIDs(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + exit + elseif(DH%MDVarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) & +'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 156 + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 162 + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%MDVarDimLens(NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) & +'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 170 + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) & +'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 176 + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 183 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + stat = NF_PUT_VARA_REAL (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 222,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 229 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_td_real +subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real*8 ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 61 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 68 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 73 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) & +'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 78 + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 88 & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_PUT_ATT_DOUBLE(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_DOUBLE,Count,Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 124 + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 140 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_ti_double +subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real*8,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 67 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 74 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 82 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 89 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 94 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%MDVarNames(NVar) == NO_NAME) then + DH%MDVarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 111 + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 124,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) & +'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 133 + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%MDVarDimLens(NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + stat = NF_DEF_VAR(NCID,Name,NF_DOUBLE,2,VDims,DH%MDVarIDs(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + exit + elseif(DH%MDVarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) & +'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 156 + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 162 + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%MDVarDimLens(NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) & +'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 170 + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) & +'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 176 + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 183 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + stat = NF_PUT_VARA_DOUBLE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 222,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 229 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_td_double +subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 61 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 68 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 73 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) & +'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 78 + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 88 & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_PUT_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_INT,Count,Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 124 + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 140 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_ti_integer +subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 67 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 74 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 82 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 89 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 94 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%MDVarNames(NVar) == NO_NAME) then + DH%MDVarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 111 + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 124,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) & +'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 133 + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%MDVarDimLens(NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + stat = NF_DEF_VAR(NCID,Name,NF_INT,2,VDims,DH%MDVarIDs(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + exit + elseif(DH%MDVarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) & +'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 156 + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 162 + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%MDVarDimLens(NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) & +'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 170 + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) & +'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 176 + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 183 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + stat = NF_PUT_VARA_INT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 222,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 229 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_td_integer +subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 61 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 68 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 73 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) & +'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 78 + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 88 & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 99 + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_PUT_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_INT,Count,Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 124 + call wrf_debug ( WARN , msg) + endif + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 132 + call wrf_debug ( FATAL , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 140 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_ti_logical +subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + logical ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 67 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 74 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 82 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 89 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 94 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%MDVarNames(NVar) == NO_NAME) then + DH%MDVarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 111 + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 124,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) & +'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 133 + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%MDVarDimLens(NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + stat = NF_DEF_VAR(NCID,Name,NF_INT,2,VDims,DH%MDVarIDs(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + exit + elseif(DH%MDVarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) & +'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 156 + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 162 + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%MDVarDimLens(NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) & +'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 170 + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) & +'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 176 + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 183 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 196 + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = NF_PUT_VARA_INT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) + deallocate(Buffer, STAT=stat2) + if(stat2/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 212 + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 222,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 229 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_td_logical +subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(in) :: Data + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 61 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 68 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 73 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) & +'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 78 + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 88 & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + if(len_trim(Data).le.0) then + stat = NF_PUT_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) + else + stat = NF_PUT_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element), len_trim(Data),trim(Data) ) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 124 + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 140 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_ti_char +subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character*(*) ,intent(in) :: Data + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: stat2 + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 67 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 74 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 82 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 89 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) & +'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 94 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(len(Data) < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%MDVarNames(NVar) == NO_NAME) then + DH%MDVarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 111 + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == len(Data)) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),len(Data),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 124,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = len(Data) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) & +'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 133 + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%MDVarDimLens(NVar) = len(Data) + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + stat = NF_DEF_VAR(NCID,Name,NF_CHAR,2,VDims,DH%MDVarIDs(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 145,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%MDVarNames(NVar) == Name) then + exit + elseif(DH%MDVarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) & +'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 156 + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) & +'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 162 + call wrf_debug ( WARN , msg) + return + endif + enddo + if(len(Data) > DH%MDVarDimLens(NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) & +'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 170 + call wrf_debug ( WARN , msg) + return + elseif(len(Data) < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) & +'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 176 + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 183 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = len(Data) + VCount(2) = 1 + stat = NF_PUT_VARA_TEXT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 222,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 229 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_put_var_td_char +subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real ,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + real ,allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 60 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 68 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 75 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 80 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 85 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 94 + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 103,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 110 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_FLOAT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 118 + call wrf_debug ( WARN , msg) + return + endif + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 128 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_REAL(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 146,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 155 + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 170 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_get_var_ti_real +subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real ,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + real ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 73 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 81 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 88 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 96 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 103 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 108 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 113 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_VARID(NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 120,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 136 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_FLOAT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 144 + call wrf_debug ( WARN , msg) + return + endif + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) & +'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 152 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 160,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 167 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 180 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_VARA_REAL (NCID,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 199 + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 209 + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 224 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_td_real +subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real*8 ,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + real*8 ,allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 60 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 68 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 75 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 80 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 85 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 94 + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 103,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 110 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_DOUBLE) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 118 + call wrf_debug ( WARN , msg) + return + endif + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 128 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_DOUBLE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 146,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 155 + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 170 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_get_var_ti_double +subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real*8 ,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + real*8 ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 73 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 81 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 88 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 96 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 103 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 108 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 113 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_VARID(NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 120,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 136 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_DOUBLE) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 144 + call wrf_debug ( WARN , msg) + return + endif + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) & +'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 152 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 160,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 167 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 180 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_VARA_DOUBLE (NCID,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 199 + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 209 + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 224 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_td_double +subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + integer,allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 60 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 68 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 75 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 80 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 85 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 94 + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 103,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 110 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 118 + call wrf_debug ( WARN , msg) + return + endif + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 128 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 146,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 155 + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 170 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_get_var_ti_integer +subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 73 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 81 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 88 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 96 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 103 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 108 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 113 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_VARID(NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 120,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 136 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 144 + call wrf_debug ( WARN , msg) + return + endif + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) & +'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 152 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 160,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 167 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 180 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_VARA_INT (NCID,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 199 + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 209 + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 224 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_td_integer +subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + integer,allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 60 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 68 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 75 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 80 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 85 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 94 + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 103,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 110 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 118 + call wrf_debug ( WARN , msg) + return + endif + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 128 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 146,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 155 + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 170 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_get_var_ti_logical +subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + logical,intent(out) :: Data(*) + integer,intent(in) :: Count + integer,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 73 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 81 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 88 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 96 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 103 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 108 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 113 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_VARID(NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 120,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 136 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 144 + call wrf_debug ( WARN , msg) + return + endif + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) & +'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 152 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 160,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 167 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) & +'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 180 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_GET_VARA_INT (NCID,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 199 + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) & +'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 209 + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 224 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_td_logical +subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + integer :: Count = 1 + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 60 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 68 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 75 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 80 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 85 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) & +'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 94 + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 103,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 110 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 118 + call wrf_debug ( WARN , msg) + return + endif + endif + if(XLen > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) & +'Warning LEN CHAR STRING > LEN DATA in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 137 + call wrf_debug ( WARN , msg) + return + endif + stat = NF_GET_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 146,' Element ',Element + call wrf_debug ( WARN , msg) + endif + + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 170 + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_ncd_get_var_ti_char +subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) +!*------------------------------------------------------------------------------ +!* Standard Disclaimer +!* +!* Forecast Systems Laboratory +!* NOAA/OAR/ERL/FSL +!* 325 Broadway +!* Boulder, CO 80303 +!* +!* AVIATION DIVISION +!* ADVANCED COMPUTING BRANCH +!* SMS/NNT Version: 2.0.0 +!* +!* This software and its documentation are in the public domain and +!* are furnished "as is". The United States government, its +!* instrumentalities, officers, employees, and agents make no +!* warranty, express or implied, as to the usefulness of the software +!* and documentation for any purpose. They assume no +!* responsibility (1) for the use of the software and documentation; +!* or (2) to provide technical support to users. +!* +!* Permission to use, copy, modify, and distribute this software is +!* hereby granted, provided that this disclaimer notice appears in +!* all copies. All modifications to this software must be clearly +!* documented, and are solely the responsibility of the agent making +!* the modification. If significant modifications or enhancements +!* are made to this software, the SMS Development team +!* (sms-info@fsl.noaa.gov) should be notified. +!* +!*---------------------------------------------------------------------------- +!* +!* WRF NetCDF I/O +! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov +!* Date: October 6, 2000 +!* +!*---------------------------------------------------------------------------- + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + integer :: Count = 1 + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + character (80) ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) & +'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 73 + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 81 + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 88 + call wrf_debug ( WARN , msg) + return + endif + NCID = DH%NCID + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 96 + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) & +'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 103 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) & +'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 108 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) & +'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 113 + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = NF_INQ_VARID(NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 120,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 128,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then + if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 136 + call wrf_debug ( WARN , msg) + return + endif + else + if(XType /= NF_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) & +'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 144 + call wrf_debug ( WARN , msg) + return + endif + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) & +'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 152 + call wrf_debug ( FATAL , msg) + return + endif + stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 160,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'Warning in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 167 + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Len1 + VCount(2) = 1 + if(Len1 > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) & +'Warning LEN CHAR STRING > LEN DATA in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 189 + call wrf_debug ( WARN , msg) + return + endif + Data = '' + stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 199 + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) & +'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 224 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_td_char +subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_real +subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_integer +subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_double +subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_ncd_put_dom_td_logical +subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_ncd_put_dom_td_char +subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_real +subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_integer +subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_double +subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_ncd_get_dom_td_logical +subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(out) :: Data + integer ,intent(out) :: Status + call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_ncd_get_dom_td_char +subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, & + Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(inout) :: Field(*) + integer ,intent(in) :: FieldTypeIn + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrdIn + character*(*) ,intent(in) :: Stagger ! Dummy for now + character*(*) ,dimension(*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + integer :: FieldType + character (3) :: MemoryOrder + type(wrf_data_handle) ,pointer :: DH + integer :: NCID + integer :: NDim + character (VarNameLen) :: VarName + character (3) :: MemO + character (3) :: UCMemO + integer :: VarID + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: VDimIDs + character(80),dimension(NVarDims) :: RODimNames + integer ,dimension(NVarDims) :: StoredStart + integer ,dimension(:,:,:,:),allocatable :: XField + integer :: stat + integer :: NVar + integer :: i,j + integer :: i1,i2,j1,j2,k1,k2 + integer :: x1,x2,y1,y2,z1,z2 + integer :: l1,l2,m1,m2,n1,n2 + integer :: XType + integer :: di + character (80) :: NullName + logical :: NotFound + MemoryOrder = trim(adjustl(MemoryOrdIn)) + NullName=char(0) + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',"wrf_io.F90",', line', 2482 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',"wrf_io.F90",', line', 2489 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 2496 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NCID = DH%NCID + if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then + FieldType = WRF_REAL + else + FieldType = FieldTypeIn + end if + write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) +!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN + write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring' + call wrf_debug ( WARN , TRIM(msg)) + return + ENDIF + call ExtOrder(MemoryOrder,Length,Status) + call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 2533 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',"wrf_io.F90",', line', 2537 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == VarName ) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',"wrf_io.F90",', line', 2543 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = VarName + DH%NumVars = NVar + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',"wrf_io.F90",', line', 2552 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + do j = 1,NDim + if(RODimNames(j) == NullName .or. RODimNames(j) == '') then + do i=1,MaxDims + if(DH%DimLengths(i) == Length(j)) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2566 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(i) = Length(j) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',"wrf_io.F90",', line', 2574 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + else !look for input name and check if already defined + NotFound = .true. + do i=1,MaxDims + if (DH%DimNames(i) == RODimNames(j)) then + if (DH%DimLengths(i) == Length(j)) then + NotFound = .false. + exit + else + Status = WRF_WARN_DIMNAME_REDEFINED + write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & + TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', "wrf_io.F90" ,' line', 2589 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + enddo + if (NotFound) then + do i=1,MaxDims + if (DH%DimLengths(i) == NO_DIM) then + DH%DimNames(i) = RODimNames(j) + stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2602 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(i) = Length(j) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',"wrf_io.F90",', line', 2610 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + endif + endif + VDimIDs(j) = DH%DimIDs(i) + DH%VarDimLens(j,NVar) = Length(j) + enddo + VDimIDs(NDim+1) = DH%DimUnlimID + ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE + IF (FieldType == WRF_REAL) THEN + XType = NF_FLOAT + ELSE IF (FieldType == WRF_DOUBLE) THEN + Xtype = NF_DOUBLE + ELSE IF (FieldType == WRF_INTEGER) THEN + XType = NF_INT + ELSE IF (FieldType == WRF_LOGICAL) THEN + XType = NF_INT + ELSE + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 2633 + call wrf_debug ( WARN , TRIM(msg)) + return + END IF + stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',"wrf_io.F90",', line', 2641 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%VarIDs(NVar) = VarID + stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF error in ',"wrf_io.F90",', line', 2697 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call reorder(MemoryOrder,MemO) + call uppercase(MemO,UCMemO) + stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_ncd_write_field: NetCDF error in ',"wrf_io.F90",', line', 2706 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',"wrf_io.F90",', line', 2716 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + VarID = DH%VarIDs(NVar) + do j=1,NDim + if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then + Status = WRF_WARN_WRTLEN_NE_DRRUNLEN + write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & + VarName,'| dim ',j,' in ',"wrf_io.F90",', line', 2726 + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) + call wrf_debug ( WARN , TRIM(msg)) + return +!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then + elseif(PatchStart(j) < MemoryStart(j)) then + Status = WRF_WARN_DIMENSION_ERROR + write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & + '| in ',"wrf_io.F90",', line', 2735 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + StoredStart = 1 + call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) + call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) + call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) + di=1 + if(FieldType == WRF_DOUBLE) di=2 + allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 2749 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then + call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + else + call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + end if + call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & + FieldType,NCID,VarID,XField,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 2765 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + deallocate(XField, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 2772 + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 2778 + call wrf_debug ( FATAL , TRIM(msg)) + endif + DH%first_operation = .FALSE. + return +end subroutine ext_ncd_write_field +subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & + IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(out) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrdIn + character*(*) ,intent(in) :: Stagger ! Dummy for now + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + character (3) :: MemoryOrder + character (NF_MAX_NAME) :: dimname + type(wrf_data_handle) ,pointer :: DH + integer :: NDim + integer :: NCID + character (VarNameLen) :: VarName + integer :: VarID + integer ,dimension(NVarDims) :: VCount + integer ,dimension(NVarDims) :: VStart + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: VDimIDs + integer ,dimension(NVarDims) :: MemS + integer ,dimension(NVarDims) :: MemE + integer ,dimension(NVarDims) :: StoredStart + integer ,dimension(NVarDims) :: StoredLen + integer ,dimension(:,:,:,:) ,allocatable :: XField + integer :: NVar + integer :: j + integer :: i1,i2,j1,j2,k1,k2 + integer :: x1,x2,y1,y2,z1,z2 + integer :: l1,l2,m1,m2,n1,n2 + character (VarNameLen) :: Name + integer :: XType + integer :: StoredDim + integer :: NAtts + integer :: Len + integer :: stat + integer :: di + integer :: FType + MemoryOrder = trim(adjustl(MemoryOrdIn)) + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & + TRIM(Var),'| in ext_ncd_read_field ',"wrf_io.F90",', line', 2842 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & + '| in ext_ncd_read_field ',"wrf_io.F90",', line', 2849 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',"wrf_io.F90",', line', 2856 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 2862 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then +! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. +! Status = WRF_WARN_DRYRUN_READ +! write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 2867 +! call wrf_debug ( WARN , TRIM(msg)) + Status = WRF_NO_ERR + RETURN + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 2873 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then + NCID = DH%NCID +!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + call ExtOrder(MemoryOrder,Length,Status) + stat = NF_INQ_VARID(NCID,VarName,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2884,' Varname ',Varname + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2891 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2898 + call wrf_debug ( WARN , TRIM(msg)) + return + endif +! allow coercion between double and single prec real +!jm if(FieldType /= Ftype) then + if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then + if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 2907 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + else if(FieldType /= Ftype) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 2913 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE + IF (FieldType == WRF_REAL) THEN +! allow coercion between double and single prec real + if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning REAL TYPE MISMATCH in ',"wrf_io.F90",', line', 2923 + endif + ELSE IF (FieldType == WRF_DOUBLE) THEN +! allow coercion between double and single prec real + if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',"wrf_io.F90",', line', 2929 + endif + ELSE IF (FieldType == WRF_INTEGER) THEN + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',"wrf_io.F90",', line', 2934 + endif + ELSE IF (FieldType == WRF_LOGICAL) THEN + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',"wrf_io.F90",', line', 2939 + endif + ELSE + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 2943 + END IF + if(Status /= WRF_NO_ERR) then + call wrf_debug ( WARN , TRIM(msg)) + return + endif + ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 + IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN + stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2955 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + IF ( dimname(1:10) == 'ext_scalar' ) THEN + NDim = 1 + Length(1) = 1 + ENDIF + ENDIF + if(StoredDim /= NDim+1) then + Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM + write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) + call wrf_debug ( FATAL , msg) + write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 + call wrf_debug ( FATAL , msg) + return + endif + do j=1,NDim + stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2976 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(Length(j) > StoredLen(j)) then + Status = WRF_WARN_READ_PAST_EOF + write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Length(j) <= 0) then + Status = WRF_WARN_ZERO_LENGTH_READ + write(msg,*) 'Warning ZERO LENGTH READ in ',"wrf_io.F90",', line', 2987 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DomainStart(j) < MemoryStart(j)) then + Status = WRF_WARN_DIMENSION_ERROR + write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & + ') < MemoryStart (',MemoryStart(j),') in ',"wrf_io.F90",', line', 2993 + call wrf_debug ( WARN , TRIM(msg)) +! return + endif + enddo + StoredStart = 1 + call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) + call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) +!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) + call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) + di=1 + if(FieldType == WRF_DOUBLE) di=2 + allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 3010 + call wrf_debug ( FATAL , msg) + return + endif + call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & + FieldType,NCID,VarID,XField,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3017 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & + ,XField,x1,x2,y1,y2,z1,z2 & + ,i1,i2,j1,j2,k1,k2 ) + deallocate(XField, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 3027 + call wrf_debug ( FATAL , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3033 + call wrf_debug ( FATAL , msg) + endif + DH%first_operation = .FALSE. + return +end subroutine ext_ncd_read_field +subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(inout) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + !call upgrade_filename(FileName) + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + FileStatus = WRF_FILE_NOT_OPENED + return + endif + if(trim(FileName) /= trim(DH%FileName)) then + FileStatus = WRF_FILE_NOT_OPENED + else + FileStatus = DH%FileStatus + endif + Status = WRF_NO_ERR + return +end subroutine ext_ncd_inquire_opened +subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + FileStatus = WRF_FILE_NOT_OPENED + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3080 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + FileName = trim(DH%FileName) + FileStatus = DH%FileStatus + Status = WRF_NO_ERR + return +end subroutine ext_ncd_inquire_filename +subroutine ext_ncd_set_time(DataHandle, DateStr, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: i + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',"wrf_io.F90",', line', 3103 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3109 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3115 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 3119 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3123 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do i=1,MaxTimes + if(DH%Times(i)==DateStr) then + DH%CurrentTime = i + exit + endif + if(i==MaxTimes) then + Status = WRF_WARN_TIME_NF + return + endif + enddo + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3140 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_set_time +subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3158 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3164 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3168 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3172 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then + if(DH%CurrentTime >= DH%NumberTimes) then + Status = WRF_WARN_TIME_EOF + return + endif + DH%CurrentTime = DH%CurrentTime +1 + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'DH%FileStatus ',DH%FileStatus + call wrf_debug ( FATAL , msg) + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3187 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_next_time +subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3205 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3211 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3215 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3219 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + if(DH%CurrentTime.GT.0) then + DH%CurrentTime = DH%CurrentTime -1 + endif + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3230 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_previous_time +subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: VarName + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + character (80) :: Name + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3251 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3257 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3261 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3265 + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + DH%CurrentVariable = DH%CurrentVariable +1 + if(DH%CurrentVariable > DH%NumVars) then + Status = WRF_WARN_VAR_EOF + return + endif + VarName = DH%VarNames(DH%CurrentVariable) + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3278 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_next_var +subroutine ext_ncd_end_of_frame(DataHandle, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + call GetDH(DataHandle,DH,Status) + return +end subroutine ext_ncd_end_of_frame +! NOTE: For scalar variables NDim is set to zero and DomainStart and +! NOTE: DomainEnd are left unmodified. +subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Name + integer ,intent(out) :: NDim + character*(*) ,intent(out) :: MemoryOrder + character*(*) :: Stagger ! Dummy for now + integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd + integer ,intent(out) :: WrfType + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: VarID + integer ,dimension(NVarDims) :: VDimIDs + integer :: j + integer :: stat + integer :: XType + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3323 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3329 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3334 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3339 + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = NF_INQ_VARID(DH%NCID,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3346 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3353 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3360 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + select case (XType) + case (NF_BYTE) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3367 + call wrf_debug ( WARN , TRIM(msg)) + return + case (NF_CHAR) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3372 + call wrf_debug ( WARN , TRIM(msg)) + return + case (NF_SHORT) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3377 + call wrf_debug ( WARN , TRIM(msg)) + return + case (NF_INT) + if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3383 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case (NF_FLOAT) + if(WrfType /= WRF_REAL) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3390 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case (NF_DOUBLE) + if(WrfType /= WRF_DOUBLE) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3397 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 3403 + call wrf_debug ( WARN , TRIM(msg)) + return + end select + stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3411 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',"wrf_io.F90",', line', 3417 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3424 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + do j = 1, NDim + DomainStart(j) = 1 + stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3433 + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3440 + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_ncd_get_var_info +subroutine ext_ncd_warning_str( Code, ReturnString, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer , intent(in) ::Code + character *(*), intent(out) :: ReturnString + integer, intent(out) ::Status + SELECT CASE (Code) + CASE (0) + ReturnString='No error' + Status=WRF_NO_ERR + return + CASE (-1) + ReturnString= 'File not found (or file is incomplete)' + Status=WRF_NO_ERR + return + CASE (-2) + ReturnString='Metadata not found' + Status=WRF_NO_ERR + return + CASE (-3) + ReturnString= 'Timestamp not found' + Status=WRF_NO_ERR + return + CASE (-4) + ReturnString= 'No more timestamps' + Status=WRF_NO_ERR + return + CASE (-5) + ReturnString= 'Variable not found' + Status=WRF_NO_ERR + return + CASE (-6) + ReturnString= 'No more variables for the current time' + Status=WRF_NO_ERR + return + CASE (-7) + ReturnString= 'Too many open files' + Status=WRF_NO_ERR + return + CASE (-8) + ReturnString= 'Data type mismatch' + Status=WRF_NO_ERR + return + CASE (-9) + ReturnString= 'Attempt to write read-only file' + Status=WRF_NO_ERR + return + CASE (-10) + ReturnString= 'Attempt to read write-only file' + Status=WRF_NO_ERR + return + CASE (-11) + ReturnString= 'Attempt to access unopened file' + Status=WRF_NO_ERR + return + CASE (-12) + ReturnString= 'Attempt to do 2 trainings for 1 variable' + Status=WRF_NO_ERR + return + CASE (-13) + ReturnString= 'Attempt to read past EOF' + Status=WRF_NO_ERR + return + CASE (-14) + ReturnString= 'Bad data handle' + Status=WRF_NO_ERR + return + CASE (-15) + ReturnString= 'Write length not equal to training length' + Status=WRF_NO_ERR + return + CASE (-16) + ReturnString= 'More dimensions requested than training' + Status=WRF_NO_ERR + return + CASE (-17) + ReturnString= 'Attempt to read more data than exists' + Status=WRF_NO_ERR + return + CASE (-18) + ReturnString= 'Input dimensions inconsistent' + Status=WRF_NO_ERR + return + CASE (-19) + ReturnString= 'Input MemoryOrder not recognized' + Status=WRF_NO_ERR + return + CASE (-20) + ReturnString= 'A dimension name with 2 different lengths' + Status=WRF_NO_ERR + return + CASE (-21) + ReturnString= 'String longer than provided storage' + Status=WRF_NO_ERR + return + CASE (-22) + ReturnString= 'Function not supportable' + Status=WRF_NO_ERR + return + CASE (-23) + ReturnString= 'Package implements this routine as NOOP' + Status=WRF_NO_ERR + return +!netcdf-specific warning messages + CASE (-1007) + ReturnString= 'Bad data type' + Status=WRF_NO_ERR + return + CASE (-1008) + ReturnString= 'File not committed' + Status=WRF_NO_ERR + return + CASE (-1009) + ReturnString= 'File is opened for reading' + Status=WRF_NO_ERR + return + CASE (-1011) + ReturnString= 'Attempt to write metadata after open commit' + Status=WRF_NO_ERR + return + CASE (-1010) + ReturnString= 'I/O not initialized' + Status=WRF_NO_ERR + return + CASE (-1012) + ReturnString= 'Too many variables requested' + Status=WRF_NO_ERR + return + CASE (-1013) + ReturnString= 'Attempt to close file during a dry run' + Status=WRF_NO_ERR + return + CASE (-1014) + ReturnString= 'Date string not 19 characters in length' + Status=WRF_NO_ERR + return + CASE (-1015) + ReturnString= 'Attempt to read zero length words' + Status=WRF_NO_ERR + return + CASE (-1016) + ReturnString= 'Data type not found' + Status=WRF_NO_ERR + return + CASE (-1017) + ReturnString= 'Badly formatted date string' + Status=WRF_NO_ERR + return + CASE (-1018) + ReturnString= 'Attempt at read during a dry run' + Status=WRF_NO_ERR + return + CASE (-1019) + ReturnString= 'Attempt to get zero words' + Status=WRF_NO_ERR + return + CASE (-1020) + ReturnString= 'Attempt to put zero length words' + Status=WRF_NO_ERR + return + CASE (-1021) + ReturnString= 'NetCDF error' + Status=WRF_NO_ERR + return + CASE (-1022) + ReturnString= 'Requested length <= 1' + Status=WRF_NO_ERR + return + CASE (-1023) + ReturnString= 'More data available than requested' + Status=WRF_NO_ERR + return + CASE (-1024) + ReturnString= 'New date less than previous date' + Status=WRF_NO_ERR + return + CASE DEFAULT + ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & + & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & + & to be calling a package-specific routine to return a message for this warning code.' + Status=WRF_NO_ERR + END SELECT + return +end subroutine ext_ncd_warning_str +!returns message string for all WRF and netCDF warning/error status codes +!Other i/o packages must provide their own routines to return their own status messages +subroutine ext_ncd_error_str( Code, ReturnString, Status) + use wrf_data + use ext_ncd_support_routines + implicit none + include 'netcdf.inc' + include 'wrf_status_codes.h' + integer , intent(in) ::Code + character *(*), intent(out) :: ReturnString + integer, intent(out) ::Status + SELECT CASE (Code) + CASE (-100) + ReturnString= 'Allocation Error' + Status=WRF_NO_ERR + return + CASE (-101) + ReturnString= 'Deallocation Error' + Status=WRF_NO_ERR + return + CASE (-102) + ReturnString= 'Bad File Status' + Status=WRF_NO_ERR + return + CASE (-1004) + ReturnString= 'Variable on disk is not 3D' + Status=WRF_NO_ERR + return + CASE (-1005) + ReturnString= 'Metadata on disk is not 1D' + Status=WRF_NO_ERR + return + CASE (-1006) + ReturnString= 'Time dimension too small' + Status=WRF_NO_ERR + return + CASE DEFAULT + ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & + & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & + & to be calling a package-specific routine to return a message for this error code.' + Status=WRF_NO_ERR + END SELECT + return +end subroutine ext_ncd_error_str diff --git a/src/wrflib/wrf_io_flags.h b/src/wrflib/wrf_io_flags.h new file mode 100644 index 0000000000..2048aff665 --- /dev/null +++ b/src/wrflib/wrf_io_flags.h @@ -0,0 +1,15 @@ + integer, parameter :: WRF_FILE_NOT_OPENED = 100 + integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 + integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 + integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 + integer, parameter :: WRF_REAL = 104 + integer, parameter :: WRF_DOUBLE = 105 + integer, parameter :: WRF_FLOAT=WRF_REAL + integer, parameter :: WRF_INTEGER = 106 + integer, parameter :: WRF_LOGICAL = 107 + integer, parameter :: WRF_COMPLEX = 108 + integer, parameter :: WRF_DOUBLE_COMPLEX = 109 + integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 +! This bit is for backwards compatibility with old variants of these flags +! that are still being used in io_grib1 and io_phdf5. It should be removed! + integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 diff --git a/src/wrflib/wrf_status_codes.h b/src/wrflib/wrf_status_codes.h new file mode 100644 index 0000000000..059d9ea719 --- /dev/null +++ b/src/wrflib/wrf_status_codes.h @@ -0,0 +1,133 @@ + +!WRF Error and Warning messages (1-999) +!All i/o package-specific status codes you may want to add must be handled by your package (see below) +! WRF handles these and netCDF messages only + integer, parameter :: WRF_NO_ERR = 0 !no error + integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete + integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found + integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found + integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps + integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found + integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time + integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files + integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch + integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file + integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file + integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file + integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable + integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF + integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle + integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length + integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training + integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists + integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent + integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized + integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths + integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage + integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable + integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP + +!Fatal errors + integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error + integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error + integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status + + +!Package specific errors (1000+) +!Netcdf status codes +!WRF will accept status codes of 1000+, but it is up to the package to handle +! and return the status to the user. + + integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 + integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 + integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 + integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? + integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? + integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 + integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 + integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 + integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 + integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 + integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 + integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 + integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 + integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 + integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 + integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 + integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 + integer, parameter :: WRF_WARN_NETCDF = -1021 + integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 + integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 + integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 + +! For HDF5 only + integer, parameter :: WRF_HDF5_ERR_FILE = -200 + integer, parameter :: WRF_HDF5_ERR_MD = -201 + integer, parameter :: WRF_HDF5_ERR_TIME = -202 + integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 + integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 + integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 + integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 + integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 + integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 + integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 + integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 + integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 + integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 + integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 + integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 + integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 + integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 + integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 + integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 + integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 + integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 + integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 + integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 + integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 + integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 + integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 + integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 + integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 + integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 + integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 + integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 + integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 + integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 + integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 + + integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 + integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 + integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 + integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 + integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 + integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 + integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 + + integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 + integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 + integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 + + integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 + integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 + integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 + integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 + integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 + integer, parameter :: WRF_HDF5_ERR_GROUP = -308 + + integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 + integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 + integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 + integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 + integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 + + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 + + integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 + integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 + diff --git a/ush/build.comgsi b/ush/build.comgsi index 3b014dc078..0f9b9ce54e 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -24,6 +24,7 @@ elif [[ -d /jetmon ]] ; then ### jet elif [[ -d /glade ]] ; then ### cheyenne source /etc/profile.d/modules.sh modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" + NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" elif [[ -d /work/noaa ]] ; then ### orion modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" @@ -43,6 +44,27 @@ if [[ "$NETCDF4" == "1" ]] || [[ "$NETCDF4" == "0" ]]; then unset NETCDF4 fi +export BACIO_LIB4=${NCEPLIBS}/lib/libbacio_4.a +#export BUFR_LIBd=${NCEPLIBS}/lib/libbufr_d.a #NCEPLIBS has problems in generateing libbufr +export CRTM_LIB=${NCEPLIBS}/lib/libcrtm.a +export CRTM_INC=${NCEPLIBS}/include +export NEMSIO_LIB=${NCEPLIBS}/lib/libnemsio.a +export NEMSIO_INC=${NCEPLIBS}/include +export SFCIO_LIB4=${NCEPLIBS}/lib/libsfcio_4.a +export SFCIO_INC4=${NCEPLIBS}/include_4 +export SIGIO_LIB4=${NCEPLIBS}/lib/libsigio_4.a +export SIGIO_INC4=${NCEPLIBS}/include_4 +export SP_LIBd=${NCEPLIBS}/lib/libsp_d.a +export SP_LIB4=${NCEPLIBS}/lib/libsp_4.a +export W3EMC_LIBd=${NCEPLIBS}/lib/libw3emc_d.a +export W3EMC_LIB4=${NCEPLIBS}/lib/libw3emc_4.a +export W3EMC_INCd=${NCEPLIBS}/include_d +export W3EMC_INC4=${NCEPLIBS}/include_4 +export W3NCO_LIBd=${NCEPLIBS}/lib/libw3nco_d.a +export W3NCO_LIB4=${NCEPLIBS}/lib/libw3nco_4.a +export IP_LIBd=${NCEPLIBS}/lib/libip_d.a +export IP_LIB4=${NCEPLIBS}/lib/libip_4.a + set -x rm -rf $dir_root/build mkdir -p $dir_root/build @@ -60,17 +82,18 @@ git log -1 | head -n1 >> output.log echo -e "\ngit status:" >> output.log git status >> output.log echo -e "\nCompiling commands:" >> output.log -echo " cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON .." >> output.log +echo " cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON -Wno-dev .." >> output.log echo " make -j8" >> output.log cat output.log -cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON .. 2>&1 | tee output.cmake +cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_ENKF_PREPROCESS_ARW=ON -DBUILD_UTIL_COM=ON -Wno-dev .. 2>&1 | tee output.cmake make -j 8 2>&1 | tee output.compile ###aftermath commitID=`git log -1 | head -n1 |cut -c8-15` repoName=`git config --get remote.origin.url | cut -d: -f2` +repoName=${repoName//\//:} datestamp=`date +%Y%m%d` cd bin ln -sf gsi.x gsi.x_${repoName}_${datestamp}_${commitID} diff --git a/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt b/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt index 663f6323f5..a994eb945e 100644 --- a/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt +++ b/util/EnKF/arw/src/enspreproc_regional.fd/CMakeLists.txt @@ -2,12 +2,12 @@ cmake_minimum_required(VERSION 2.6) set(GSI_Fortran_FLAGS_LOCAL "${GSI_Fortran_FLAGS} -DWRF") file(GLOB LOCAL_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.f90 ${CMAKE_CURRENT_SOURCE_DIR}/*.F90) set_source_files_properties( ${LOCAL_SRC} PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS_LOCAL} ) - include_directories( ${PROJECT_BINARY_DIR}/include ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ) + include_directories( ${PROJECT_BINARY_DIR}/include ${CORE_INCS} ${NETCDF_INCLUDES} ${MPI_Fortran_INCLUDE_PATH} ${FV3GFS_NCIO_INCS} ) add_executable(enspreproc.x ${LOCAL_SRC} ) set_target_properties( enspreproc.x PROPERTIES COMPILE_FLAGS ${GSI_Fortran_FLAGS_LOCAL} ) target_link_libraries(enspreproc.x ${GSISHAREDLIB} ${GSILIB} ${GSISHAREDLIB} ${WRF_LIBRARIES} ${NETCDF_LIBRARIES_F90} ${NETCDF_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES} ${MPI_Fortran_LIBRARIES} ${LAPACK_LIBRARIES} -L./ ${EXTRA_LINKER_FLAGS} ${HDF5_LIBRARIES} ${CURL_LIBRARIES} ${CORE_LIBRARIES} ${CORE_BUILT} - ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${ZLIB_LIBRARIES} ${wrflib} ) + ${GSI_LDFLAGS} ${NCDIAG_LIBRARIES} ${ZLIB_LIBRARIES} ${wrflib} ${FV3GFS_NCIO_LIBRARIES} ) add_dependencies(enspreproc.x ${GSILIB}) From 8bb92f46309fc77c11717325661e7c87bad88823 Mon Sep 17 00:00:00 2001 From: "guoqing.ge" Date: Thu, 4 Jun 2020 13:36:24 -0600 Subject: [PATCH 03/11] update build.comgsi for Hera --- ush/build.comgsi | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/ush/build.comgsi b/ush/build.comgsi index 0f9b9ce54e..dd26202a46 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -12,12 +12,10 @@ dir_root=$(pwd) -if [[ "`grep -i "theia" /etc/hosts | head -n1`" != "" ]] ; then ###theia - source /etc/profile.d/modules.sh - modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.theia.GSI_UPP_WRF" -elif [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then ###hera +if [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then ###hera source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.hera.GSI_UPP_WRF" + NCEPLIBS="/scratch1/BMC/comgsi/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.0.4/install" elif [[ -d /jetmon ]] ; then ### jet source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.jet.GSI_UPP_WRF" From 14f60cde045d2cdde7a5bd6ff895fd63f508bb76 Mon Sep 17 00:00:00 2001 From: "guoqing.ge" Date: Thu, 4 Jun 2020 17:20:27 -0600 Subject: [PATCH 04/11] update build.comgsi for Jet --- ush/build.comgsi | 1 + 1 file changed, 1 insertion(+) diff --git a/ush/build.comgsi b/ush/build.comgsi index dd26202a46..6957e8b3ca 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -19,6 +19,7 @@ if [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then ###hera elif [[ -d /jetmon ]] ; then ### jet source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.jet.GSI_UPP_WRF" + NCEPLIBS="/lfs4/BMC/wrfruc/gge/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.4.274/install" elif [[ -d /glade ]] ; then ### cheyenne source /etc/profile.d/modules.sh modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" From 60f51c6a181852cbfba91ad9db95e3ae6a61afcd Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Thu, 4 Jun 2020 18:47:09 -0600 Subject: [PATCH 05/11] bug fixes for GNU compilers --- cmake/Modules/setGNUFlags.cmake | 2 + src/gsi/phil2.f90 | 16 +++---- src/gsi/pvqc.f90 | 82 ++++++++++++++++----------------- 3 files changed, 51 insertions(+), 49 deletions(-) diff --git a/cmake/Modules/setGNUFlags.cmake b/cmake/Modules/setGNUFlags.cmake index 1e1e075fa1..e4ef2d9ade 100644 --- a/cmake/Modules/setGNUFlags.cmake +++ b/cmake/Modules/setGNUFlags.cmake @@ -27,6 +27,7 @@ function (setGNU) set(W3NCO_C_FLAGS " -DLINUX -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") set(WRFLIB_Fortran_FLAGS " -O3 -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" CACHE INTERNAL "") set( NCDIAG_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) + set( FV3GFS_NCIO_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) set( NDATE_Fortran_FLAGS "-fconvert=big-endian -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -O3 -Wl,-noinhibit-exec" CACHE INTERNAL "") set( COV_CALC_FLAGS "-c -O3 -fconvert=little-endian -ffast-math -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fopenmp" CACHE INTERNAL "") set(GSDCLOUD_Fortran_FLAGS "-O3 -fconvert=big-endian" CACHE INTERNAL "") @@ -56,6 +57,7 @@ function (setGNU) set(W3NCO_C_FLAGS " -DLINUX -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp" CACHE INTERNAL "") set(WRFLIB_Fortran_FLAGS " -g -fbacktrace -fconvert=big-endian -ffast-math -fno-second-underscore -frecord-marker=4 -funroll-loops -g -ggdb -static -Wall -fno-range-check -D_REAL8_ -fopenmp -ffree-line-length-0" CACHE INTERNAL "") set( NCDIAG_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) + set( FV3GFS_NCIO_Fortran_FLAGS "-ffree-line-length-none" CACHE INTERNAL "" ) set( NDATE_Fortran_FLAGS "-fconvert=big-endian -DCOMMCODE -DLINUX -DUPPLITTLEENDIAN -g -fbacktrace -Wl,-noinhibit-exec" CACHE INTERNAL "") set( COV_CALC_FLAGS "-c -O3 -fconvert=little-endian -ffast-math -ffree-form -fno-second-underscore -frecord-marker=4 -funroll-loops -ggdb -static -Wall -fopenmp" CACHE INTERNAL "") set(GSDCLOUD_Fortran_FLAGS "-O3 -fconvert=big-endian" CACHE INTERNAL "") diff --git a/src/gsi/phil2.f90 b/src/gsi/phil2.f90 index 9dce41f215..c2d01cb349 100644 --- a/src/gsi/phil2.f90 +++ b/src/gsi/phil2.f90 @@ -349,11 +349,11 @@ subroutine denest(nob,nrand,nor, &! [denest] xob(:,L)=(/clat*clon,clat*slon,slon/) rob(L)=(altob(L)-vmin)/uv-vrand! <- altitudes in hilbert vertical units enddo -if(nrand<1 .or. nrand>273)stop'nrand is invalid' +if(nrand<1 .or. nrand>273)stop 'nrand is invalid' if(nrand>5)then; call getqset7( qset7); if(nrand>7)call getqset13(qset13) else; call getqset5(nrand,qset5) endif -if(nrand>91) call getqset5(3,qset3) +if(nrand>91) call getqset5(3,qset5) ! Project the data onto nrand differently-oriented Hilbert curves and sum @@ -407,7 +407,7 @@ subroutine denest(nob,nrand,nor, &! [denest] case(1) call bsmoo1(nob,span,sob,rank,wtob) case default - stop'In denest; this value of B-spline order, nor, is not supported' + stop 'In denest; this value of B-spline order, nor, is not supported' end select enddo! irand ! Convert the sum of Hilbert-parameter-relative densities to an average, @@ -499,7 +499,7 @@ subroutine denestx(nob,nrand,nor, &! [denest] xob(:,L)=(/clat*clon,clat*slon,slon/) rob(L)=(altob(L)-vmin)/uv-vrand! <- altitudes in hilbert vertical units enddo -if(nrand<1 .or. nrand>104)stop'nrand is invalid' +if(nrand<1 .or. nrand>104)stop 'nrand is invalid' if(nrand>5)then; call getqset8( qset8); if(nrand>8)call getqset13(qset13) else; call getqset5(nrand,qset5) endif @@ -549,7 +549,7 @@ subroutine denestx(nob,nrand,nor, &! [denest] case(1) call bsmoo1(nob,span,sob,rank,denob) case default - stop'In denest; this value of B-spline order, nor, is not supported' + stop 'In denest; this value of B-spline order, nor, is not supported' end select enddo! irand ! Convert the sum of Hilbert-parameter-relative densities to an average, @@ -650,7 +650,7 @@ subroutine denest2d(nob,nrand,nor,dentrip,scale,& ! [denest2d] case(1) call bsmoo1(nob,span,sob,rank,wtob) case default - stop'In denest; this value of B-spline order, nor, is not supported' + stop 'In denest; this value of B-spline order, nor, is not supported' end select ! Rotate the Hilbert tile by a pi/(2*nrand) about its axis at (1/3,1/3): if(Lnunit)& - stop'In writevqcascfile; No available unit number for writing' + stop 'In writevqcascfile; No available unit number for writing' open(unit=iunit,file=vqcascfile,access='sequential',form='formatted') write(iunit,600)npx,npa,npb,npk,nx,na write(iunit,601)sgt @@ -198,15 +198,15 @@ subroutine readvqcascfile(vqcascfile,&! [readvqcascfile] if(.not.op)exit enddo if(.not.ex .or. iunit>nunit)& - stop'In readvqcascfile; No available unit number for reading' + stop 'In readvqcascfile; No available unit number for reading' open(unit=iunit,file=vqcascfile,access='sequential',form='formatted') read(iunit,600)npx,npa,npb,npk,nx,na -if(npx_a/=npx)stop'In readvqcascfile; mismatched specified npx' -if(npa_a/=npa)stop'In readvqcascfile; mismatched specified npa' -if(npb_a/=npb)stop'In readvqcascfile; mismatched specified npb' -if(npk_a/=npk)stop'In readvqcascfile; mismatched specified npk' -if(nx_a /=nx )stop'In readvqcascfile; mismatched specified nx' -if(na_a /=na )stop'In readvqcascfile; mismatched specified na' +if(npx_a/=npx)stop 'In readvqcascfile; mismatched specified npx' +if(npa_a/=npa)stop 'In readvqcascfile; mismatched specified npa' +if(npb_a/=npb)stop 'In readvqcascfile; mismatched specified npb' +if(npk_a/=npk)stop 'In readvqcascfile; mismatched specified npk' +if(nx_a /=nx )stop 'In readvqcascfile; mismatched specified nx' +if(na_a /=na )stop 'In readvqcascfile; mismatched specified na' nkm=npk-1 npb2=npb*2 allocate(sgt(-nx:nx,0:na,-nkm:nkm),swt(-nx:nx,0:na,-nkm:nkm),& @@ -250,13 +250,13 @@ subroutine writevqcdatfile(vqcdatfile,&! [writevqcdatfile] logical :: ex,op !============================================================================== if(.not.linitvqc)& - stop'In writevqcdatfile; VQC parameters and tables are not yet initialized' -if(npx_a/=npx)stop'In writevqcdatfile; mismatched specified npx' -if(npa_a/=npa)stop'In writevqcdatfile; mismatched specified npa' -if(npb_a/=npb)stop'In writevqcdatfile; mismatched specified npb' -if(npk_a/=npk)stop'In writevqcdatfile; mismatched specified npk' -if(nx_a /=nx )stop'In writevqcdatfile; mismatched specified nx' -if(na_a /=na )stop'In writevqcdatfile; mismatched specified na' + stop 'In writevqcdatfile; VQC parameters and tables are not yet initialized' +if(npx_a/=npx)stop 'In writevqcdatfile; mismatched specified npx' +if(npa_a/=npa)stop 'In writevqcdatfile; mismatched specified npa' +if(npb_a/=npb)stop 'In writevqcdatfile; mismatched specified npb' +if(npk_a/=npk)stop 'In writevqcdatfile; mismatched specified npk' +if(nx_a /=nx )stop 'In writevqcdatfile; mismatched specified nx' +if(na_a /=na )stop 'In writevqcdatfile; mismatched specified na' do iunit=lunit,nunit inquire(unit=iunit, exist=ex, opened=op) @@ -264,7 +264,7 @@ subroutine writevqcdatfile(vqcdatfile,&! [writevqcdatfile] if(.not.op)exit enddo if(.not.ex .or. iunit>nunit)& - stop'In writevqcdatfile; No available unit number for writing' + stop 'In writevqcdatfile; No available unit number for writing' open(unit=iunit,file=vqcdatfile,access='sequential',form='unformatted') write(unit=iunit)npx,npa,npb,npk,nx,na write(iunit)sgt @@ -306,15 +306,15 @@ subroutine readvqcdatfile(vqcdatfile,&! [readvqcdatfile] if(.not.op)exit enddo if(.not.ex .or. iunit>nunit)& - stop'In readvqcdatfile; No available unit number for reading' + stop 'In readvqcdatfile; No available unit number for reading' open(unit=iunit,file=vqcdatfile,access='sequential',form='unformatted') read(iunit)npx,npa,npb,npk,nx,na -if(npx_a/=npx)stop'In readvqcdatfile; mismatched specified npx' -if(npa_a/=npa)stop'In readvqcdatfile; mismatched specified npa' -if(npb_a/=npb)stop'In readvqcdatfile; mismatched specified npb' -if(npk_a/=npk)stop'In readvqcdatfile; mismatched specified npk' -if(nx_a /=nx )stop'In readvqcdatfile; mismatched specified nx' -if(na_a /=na )stop'In readvqcdatfile; mismatched specified na' +if(npx_a/=npx)stop 'In readvqcdatfile; mismatched specified npx' +if(npa_a/=npa)stop 'In readvqcdatfile; mismatched specified npa' +if(npb_a/=npb)stop 'In readvqcdatfile; mismatched specified npb' +if(npk_a/=npk)stop 'In readvqcdatfile; mismatched specified npk' +if(nx_a /=nx )stop 'In readvqcdatfile; mismatched specified nx' +if(na_a /=na )stop 'In readvqcdatfile; mismatched specified na' nkm=npk-1 npb2=npb*2 allocate(sgt(-nx:nx,0:na,-nkm:nkm),swt(-nx:nx,0:na,-nkm:nkm),& @@ -358,13 +358,13 @@ subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch] x1,x2,xa,ya,xx integer(i_kind) :: ja !============================================================================== -if(.not.linitvqc)stop'In vqch; VQC tables are not initialized' +if(.not.linitvqc)stop 'In vqch; VQC tables are not initialized' if(ia<0)then; sx=-x; ja=-ia else; sx= x; ja= ia endif -if(ja>na )stop'In vqch; ia out of bounds' -if(ib<=0.or.ib>=npb2 )stop'In vqch; ib out of bounds' -if(ik<=-npk.or.ik>=npk)stop'In vqch; ik out of bounds' +if(ja>na )stop 'In vqch; ia out of bounds' +if(ib<=0.or.ib>=npb2 )stop 'In vqch; ib out of bounds' +if(ik<=-npk.or.ik>=npk)stop 'In vqch; ik out of bounds' x1=x1t(ja,ik) x2=x2t(ja,ik) xa=xat(ja,ik) @@ -428,8 +428,8 @@ subroutine vqch_r(beta,x,g,w)! [vqch] real(dp),parameter:: pio4=pi/4_dp real(dp) :: bc,p,q,qx,x1,x2,ya,xx !============================================================================== -if(.not.linitvqc)stop'In vqch; VQC tables are not initialized' -if(beta<=u0.or.beta>=u2)stop'In vqch; beta out of bounds' +if(.not.linitvqc)stop 'In vqch; VQC tables are not initialized' +if(beta<=u0.or.beta>=u2)stop 'In vqch; beta out of bounds' x1=x1t(0,0) x2=x2t(0,0) ya=yat(0,0) @@ -478,13 +478,13 @@ subroutine vqcs_iii(ia,ib,ik,x,g,w)! [vqcs] ww,dfa,fl,dfl,f1,f2,df1,df2,g1,g2 integer(i_kind) :: ix1,ix2,ja !============================================================================== -if(.not.linitvqc)stop'In vqcs; VQC tables are not initialized' +if(.not.linitvqc)stop 'In vqcs; VQC tables are not initialized' if(ia<0)then; sx=-x; ja=-ia else; sx= x; ja= ia endif -if(ja>na )stop'In vqcs; ia out of bounds' -if(ib<=0.or.ib>=npb2 )stop'In vqcs; ib out of bounds' -if(ik<=-npk.or.ik>=npk)stop'In vqcs; ik out of bounds' +if(ja>na )stop 'In vqcs; ia out of bounds' +if(ib<=0.or.ib>=npb2 )stop 'In vqcs; ib out of bounds' +if(ik<=-npk.or.ik>=npk)stop 'In vqcs; ik out of bounds' beta =ib*db kappa=ik*dk bc=tan(pio4*(u2-beta)) @@ -574,7 +574,7 @@ subroutine vqcs_r(beta,x,g,w)! [vqcs] ww,dfa,fl,dfl,f1,f2,df1,df2,g1,g2 integer(i_kind) :: ix1,ix2 !============================================================================== -if(.not.linitvqc)stop'In vqcs; VQC tables are not initialized' +if(.not.linitvqc)stop 'In vqcs; VQC tables are not initialized' bc=tan(pio4*(u2-beta)) p=bc**2 q=u1/bc From 3b0f98e6c709e07f49a98bc48d5cbf3fe1a68b62 Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Fri, 5 Jun 2020 10:32:09 -0600 Subject: [PATCH 06/11] libraries bufr and wrflib are from the GSILIBS repo; other bug fixes --- CMakeLists.txt | 10 +- cmake/Modules/FindBUFR.cmake | 6 +- cmake/Modules/findHelpers.cmake | 8 +- cmake/Modules/platforms/Generic.cmake | 3 +- src/bufr/.gitrepo | 11 - src/bufr/CMakeLists.txt | 22 - src/bufr/README.libbufr | 1617 ----- src/bufr/adn30.f | 85 - src/bufr/atrcpt.f | 104 - src/bufr/bfrini.f | 299 - src/bufr/blocks.f | 117 - src/bufr/bort.f | 88 - src/bufr/bort2.f | 52 - src/bufr/bort_exit.c | 35 - src/bufr/bufrlib.h | 143 - src/bufr/bufrlib0.PRM | 202 - src/bufr/bvers.f | 50 - src/bufr/cadn30.f | 45 - src/bufr/capit.f | 64 - src/bufr/ccbfl.c | 36 - src/bufr/chekstab.f | 111 - src/bufr/chrtrn.f | 48 - src/bufr/chrtrna.f | 64 - src/bufr/cktaba.f | 292 - src/bufr/closbf.f | 68 - src/bufr/closmg.f | 136 - src/bufr/cmpia.c | 42 - src/bufr/cmpmsg.f | 56 - src/bufr/cmsgini.f | 211 - src/bufr/cnved4.f | 137 - src/bufr/cobfl.c | 106 - src/bufr/conwin.f | 108 - src/bufr/copybf.f | 106 - src/bufr/copymg.f | 136 - src/bufr/copysb.f | 187 - src/bufr/cpbfdx.f | 108 - src/bufr/cpdxmm.f | 162 - src/bufr/cpymem.f | 156 - src/bufr/cpyupd.f | 113 - src/bufr/crbmg.c | 150 - src/bufr/cread.c | 94 - src/bufr/cwbmg.c | 54 - src/bufr/datebf.f | 142 - src/bufr/datelen.f | 73 - src/bufr/digit.f | 52 - src/bufr/drfini.f | 105 - src/bufr/drstpl.f | 99 - src/bufr/dumpbf.f | 174 - src/bufr/dxdump.f | 334 - src/bufr/dxinit.f | 141 - src/bufr/dxmini.f | 178 - src/bufr/elemdx.f | 149 - src/bufr/errwrt.f | 57 - src/bufr/getabdb.f | 90 - src/bufr/getbmiss.f | 49 - src/bufr/getlens.f | 83 - src/bufr/getntbe.f | 77 - src/bufr/gets1loc.f | 220 - src/bufr/gettagpr.f | 101 - src/bufr/gettbh.f | 95 - src/bufr/getvalnb.f | 140 - src/bufr/getwin.f | 128 - src/bufr/i4dy.f | 66 - src/bufr/ibfms.f | 57 - src/bufr/icbfms.f | 71 - src/bufr/ichkstr.f | 65 - src/bufr/icmpdx.f | 91 - src/bufr/icopysb.f | 48 - src/bufr/icvidx.c | 40 - src/bufr/idn30.f | 81 - src/bufr/idxmsg.f | 58 - src/bufr/ifbget.f | 85 - src/bufr/ifxy.f | 66 - src/bufr/igetdate.f | 60 - src/bufr/igetfxy.f | 79 - src/bufr/igetntbi.f | 66 - src/bufr/igetntbl.f | 59 - src/bufr/igetsc.f | 55 - src/bufr/igettdi.f | 69 - src/bufr/inctab.f | 81 - src/bufr/invcon.f | 107 - src/bufr/invmrg.f | 156 - src/bufr/invtag.f | 99 - src/bufr/invwin.f | 90 - src/bufr/iok2cpy.f | 97 - src/bufr/ipkm.f | 77 - src/bufr/ipks.f | 96 - src/bufr/ireadmg.f | 54 - src/bufr/ireadmm.f | 56 - src/bufr/ireadns.f | 51 - src/bufr/ireadsb.f | 44 - src/bufr/irev.F | 80 - src/bufr/ishrdx.f | 80 - src/bufr/isize.f | 51 - src/bufr/istdesc.f | 56 - src/bufr/iupb.f | 55 - src/bufr/iupbs01.f | 179 - src/bufr/iupbs3.f | 85 - src/bufr/iupm.f | 74 - src/bufr/iupvs01.f | 82 - src/bufr/jstchr.f | 68 - src/bufr/jstnum.f | 108 - src/bufr/lcmgdf.f | 79 - src/bufr/lmsg.f | 56 - src/bufr/lstjpb.f | 110 - src/bufr/makebufrlib.sh | 289 - src/bufr/makestab.f | 400 -- src/bufr/maxout.f | 88 - src/bufr/mesgbc.f | 192 - src/bufr/mesgbf.f | 98 - src/bufr/minimg.f | 79 - src/bufr/mrginv.f | 66 - src/bufr/msgfull.f | 79 - src/bufr/msgini.f | 214 - src/bufr/msgupd.f | 143 - src/bufr/msgwrt.f | 307 - src/bufr/mtinfo.f | 62 - src/bufr/mvb.f | 79 - src/bufr/nemock.f | 89 - src/bufr/nemtab.f | 149 - src/bufr/nemtba.f | 81 - src/bufr/nemtbax.f | 92 - src/bufr/nemtbb.f | 129 - src/bufr/nemtbd.f | 224 - src/bufr/nenubd.f | 103 - src/bufr/nevn.f | 110 - src/bufr/newwin.f | 93 - src/bufr/nmsub.f | 77 - src/bufr/nmwrd.f | 52 - src/bufr/numbck.f | 91 - src/bufr/nummtb.c | 68 - src/bufr/numtab.f | 183 - src/bufr/numtbd.f | 118 - src/bufr/nvnwin.f | 109 - src/bufr/nwords.f | 63 - src/bufr/nxtwin.f | 96 - src/bufr/openbf.f | 318 - src/bufr/openbt.f | 73 - src/bufr/openmb.f | 111 - src/bufr/openmg.f | 100 - src/bufr/pad.f | 92 - src/bufr/padmsg.f | 63 - src/bufr/parstr.f | 98 - src/bufr/parusr.f | 197 - src/bufr/parutg.f | 277 - src/bufr/pkb.f | 87 - src/bufr/pkbs1.f | 116 - src/bufr/pkc.f | 118 - src/bufr/pkftbv.f | 50 - src/bufr/pktdd.f | 146 - src/bufr/pkvs01.f | 151 - src/bufr/posapx.f | 96 - src/bufr/rbytes.c | 62 - src/bufr/rcstpl.f | 187 - src/bufr/rdbfdx.f | 157 - src/bufr/rdcmps.f | 197 - src/bufr/rdmemm.f | 227 - src/bufr/rdmems.f | 165 - src/bufr/rdmgsb.f | 112 - src/bufr/rdmsgb.f | 103 - src/bufr/rdmsgw.f | 68 - src/bufr/rdmtbb.f | 130 - src/bufr/rdmtbd.f | 138 - src/bufr/rdtree.f | 137 - src/bufr/rdusdx.f | 273 - src/bufr/readdx.f | 147 - src/bufr/readerme.f | 230 - src/bufr/readlc.f | 193 - src/bufr/readmg.f | 184 - src/bufr/readmm.f | 83 - src/bufr/readmt.f | 256 - src/bufr/readns.f | 102 - src/bufr/reads3.f | 243 - src/bufr/readsb.f | 130 - src/bufr/restd.c | 139 - src/bufr/rewnbf.f | 180 - src/bufr/rjust.f | 54 - src/bufr/rsvfvm.f | 67 - src/bufr/rtrcpt.f | 95 - src/bufr/seqsdx.f | 253 - src/bufr/setblock.f | 47 - src/bufr/setbmiss.f | 48 - src/bufr/sntbbe.f | 161 - src/bufr/sntbde.f | 180 - src/bufr/status.f | 155 - src/bufr/stbfdx.f | 180 - src/bufr/stdmsg.f | 60 - src/bufr/stndrd.f | 293 - src/bufr/stntbi.f | 69 - src/bufr/stntbia.f | 95 - src/bufr/strcln.f | 47 - src/bufr/strcpt.f | 76 - src/bufr/string.f | 152 - src/bufr/strnum.f | 88 - src/bufr/strsuc.f | 95 - src/bufr/stseq.c | 407 -- src/bufr/tabent.f | 184 - src/bufr/tabsub.f | 460 -- src/bufr/trybump.f | 120 - src/bufr/ufbcnt.f | 86 - src/bufr/ufbcpy.f | 129 - src/bufr/ufbcup.f | 137 - src/bufr/ufbdmp.f | 290 - src/bufr/ufbevn.f | 290 - src/bufr/ufbget.f | 187 - src/bufr/ufbin3.f | 263 - src/bufr/ufbint.f | 454 -- src/bufr/ufbinx.f | 168 - src/bufr/ufbmem.f | 249 - src/bufr/ufbmex.f | 202 - src/bufr/ufbmms.f | 109 - src/bufr/ufbmns.f | 107 - src/bufr/ufbovr.f | 191 - src/bufr/ufbpos.f | 143 - src/bufr/ufbqcd.f | 95 - src/bufr/ufbqcp.f | 79 - src/bufr/ufbrep.f | 296 - src/bufr/ufbrms.f | 154 - src/bufr/ufbrp.f | 145 - src/bufr/ufbrw.f | 218 - src/bufr/ufbseq.f | 386 -- src/bufr/ufbsp.f | 141 - src/bufr/ufbstp.f | 244 - src/bufr/ufbtab.f | 564 -- src/bufr/ufbtam.f | 283 - src/bufr/ufdump.f | 409 -- src/bufr/upb.f | 69 - src/bufr/upbb.f | 82 - src/bufr/upc.f | 81 - src/bufr/upds3.f | 81 - src/bufr/upftbv.f | 100 - src/bufr/ups.f | 97 - src/bufr/uptdd.f | 115 - src/bufr/usrtpl.f | 250 - src/bufr/valx.f | 87 - src/bufr/wrcmps.f | 472 -- src/bufr/wrdesc.c | 59 - src/bufr/wrdlen.F | 482 -- src/bufr/wrdxtb.f | 182 - src/bufr/writcp.f | 51 - src/bufr/writdx.f | 88 - src/bufr/writlc.f | 222 - src/bufr/writsa.f | 180 - src/bufr/writsb.f | 85 - src/bufr/wrtree.f | 155 - src/bufr/wtstat.f | 121 - src/gsi/.CMakeLists.txt.swp | Bin 16384 -> 0 bytes src/gsi/phil2.f90 | 2 +- src/gsi/pietc.f90 | 2 +- src/gsi/pvqc_tables.f90 | 2 +- src/wrflib/CMakeLists.txt | 11 - src/wrflib/ext_ncd_get_dom_ti.code | 157 - src/wrflib/ext_ncd_get_var_td.code | 227 - src/wrflib/ext_ncd_get_var_ti.code | 174 - src/wrflib/ext_ncd_put_dom_ti.code | 164 - src/wrflib/ext_ncd_put_var_td.code | 233 - src/wrflib/ext_ncd_put_var_ti.code | 144 - src/wrflib/field_routines.F90 | 175 - src/wrflib/io_int_stubs.f90 | 157 - src/wrflib/model_data_order.inc | 8 - src/wrflib/module_driver_constants.F90 | 180 - src/wrflib/module_machine.F90 | 175 - src/wrflib/pack_utils.c | 390 -- src/wrflib/streams.h | 16 - src/wrflib/transpose.code | 40 - src/wrflib/wrf_io.F90.orig | 3685 ----------- src/wrflib/wrf_io.f90 | 8169 ------------------------ src/wrflib/wrf_io_flags.h | 15 - src/wrflib/wrf_status_codes.h | 133 - ush/build.comgsi | 22 +- 270 files changed, 35 insertions(+), 48085 deletions(-) delete mode 100644 src/bufr/.gitrepo delete mode 100644 src/bufr/CMakeLists.txt delete mode 100755 src/bufr/README.libbufr delete mode 100644 src/bufr/adn30.f delete mode 100644 src/bufr/atrcpt.f delete mode 100644 src/bufr/bfrini.f delete mode 100644 src/bufr/blocks.f delete mode 100644 src/bufr/bort.f delete mode 100644 src/bufr/bort2.f delete mode 100644 src/bufr/bort_exit.c delete mode 100644 src/bufr/bufrlib.h delete mode 100755 src/bufr/bufrlib0.PRM delete mode 100644 src/bufr/bvers.f delete mode 100644 src/bufr/cadn30.f delete mode 100644 src/bufr/capit.f delete mode 100644 src/bufr/ccbfl.c delete mode 100644 src/bufr/chekstab.f delete mode 100644 src/bufr/chrtrn.f delete mode 100644 src/bufr/chrtrna.f delete mode 100644 src/bufr/cktaba.f delete mode 100644 src/bufr/closbf.f delete mode 100644 src/bufr/closmg.f delete mode 100644 src/bufr/cmpia.c delete mode 100644 src/bufr/cmpmsg.f delete mode 100644 src/bufr/cmsgini.f delete mode 100644 src/bufr/cnved4.f delete mode 100644 src/bufr/cobfl.c delete mode 100644 src/bufr/conwin.f delete mode 100644 src/bufr/copybf.f delete mode 100644 src/bufr/copymg.f delete mode 100644 src/bufr/copysb.f delete mode 100644 src/bufr/cpbfdx.f delete mode 100644 src/bufr/cpdxmm.f delete mode 100644 src/bufr/cpymem.f delete mode 100644 src/bufr/cpyupd.f delete mode 100644 src/bufr/crbmg.c delete mode 100644 src/bufr/cread.c delete mode 100644 src/bufr/cwbmg.c delete mode 100644 src/bufr/datebf.f delete mode 100644 src/bufr/datelen.f delete mode 100644 src/bufr/digit.f delete mode 100644 src/bufr/drfini.f delete mode 100644 src/bufr/drstpl.f delete mode 100644 src/bufr/dumpbf.f delete mode 100644 src/bufr/dxdump.f delete mode 100644 src/bufr/dxinit.f delete mode 100644 src/bufr/dxmini.f delete mode 100644 src/bufr/elemdx.f delete mode 100644 src/bufr/errwrt.f delete mode 100644 src/bufr/getabdb.f delete mode 100644 src/bufr/getbmiss.f delete mode 100644 src/bufr/getlens.f delete mode 100644 src/bufr/getntbe.f delete mode 100644 src/bufr/gets1loc.f delete mode 100644 src/bufr/gettagpr.f delete mode 100644 src/bufr/gettbh.f delete mode 100644 src/bufr/getvalnb.f delete mode 100644 src/bufr/getwin.f delete mode 100644 src/bufr/i4dy.f delete mode 100644 src/bufr/ibfms.f delete mode 100644 src/bufr/icbfms.f delete mode 100644 src/bufr/ichkstr.f delete mode 100644 src/bufr/icmpdx.f delete mode 100644 src/bufr/icopysb.f delete mode 100644 src/bufr/icvidx.c delete mode 100644 src/bufr/idn30.f delete mode 100644 src/bufr/idxmsg.f delete mode 100644 src/bufr/ifbget.f delete mode 100644 src/bufr/ifxy.f delete mode 100644 src/bufr/igetdate.f delete mode 100644 src/bufr/igetfxy.f delete mode 100644 src/bufr/igetntbi.f delete mode 100644 src/bufr/igetntbl.f delete mode 100644 src/bufr/igetsc.f delete mode 100644 src/bufr/igettdi.f delete mode 100644 src/bufr/inctab.f delete mode 100644 src/bufr/invcon.f delete mode 100644 src/bufr/invmrg.f delete mode 100644 src/bufr/invtag.f delete mode 100644 src/bufr/invwin.f delete mode 100644 src/bufr/iok2cpy.f delete mode 100644 src/bufr/ipkm.f delete mode 100644 src/bufr/ipks.f delete mode 100644 src/bufr/ireadmg.f delete mode 100644 src/bufr/ireadmm.f delete mode 100644 src/bufr/ireadns.f delete mode 100644 src/bufr/ireadsb.f delete mode 100755 src/bufr/irev.F delete mode 100644 src/bufr/ishrdx.f delete mode 100644 src/bufr/isize.f delete mode 100644 src/bufr/istdesc.f delete mode 100644 src/bufr/iupb.f delete mode 100644 src/bufr/iupbs01.f delete mode 100644 src/bufr/iupbs3.f delete mode 100644 src/bufr/iupm.f delete mode 100644 src/bufr/iupvs01.f delete mode 100644 src/bufr/jstchr.f delete mode 100644 src/bufr/jstnum.f delete mode 100644 src/bufr/lcmgdf.f delete mode 100644 src/bufr/lmsg.f delete mode 100644 src/bufr/lstjpb.f delete mode 100755 src/bufr/makebufrlib.sh delete mode 100644 src/bufr/makestab.f delete mode 100644 src/bufr/maxout.f delete mode 100644 src/bufr/mesgbc.f delete mode 100644 src/bufr/mesgbf.f delete mode 100644 src/bufr/minimg.f delete mode 100644 src/bufr/mrginv.f delete mode 100644 src/bufr/msgfull.f delete mode 100644 src/bufr/msgini.f delete mode 100644 src/bufr/msgupd.f delete mode 100644 src/bufr/msgwrt.f delete mode 100644 src/bufr/mtinfo.f delete mode 100644 src/bufr/mvb.f delete mode 100644 src/bufr/nemock.f delete mode 100644 src/bufr/nemtab.f delete mode 100644 src/bufr/nemtba.f delete mode 100644 src/bufr/nemtbax.f delete mode 100644 src/bufr/nemtbb.f delete mode 100644 src/bufr/nemtbd.f delete mode 100644 src/bufr/nenubd.f delete mode 100644 src/bufr/nevn.f delete mode 100644 src/bufr/newwin.f delete mode 100644 src/bufr/nmsub.f delete mode 100644 src/bufr/nmwrd.f delete mode 100644 src/bufr/numbck.f delete mode 100644 src/bufr/nummtb.c delete mode 100644 src/bufr/numtab.f delete mode 100644 src/bufr/numtbd.f delete mode 100644 src/bufr/nvnwin.f delete mode 100644 src/bufr/nwords.f delete mode 100644 src/bufr/nxtwin.f delete mode 100644 src/bufr/openbf.f delete mode 100644 src/bufr/openbt.f delete mode 100644 src/bufr/openmb.f delete mode 100644 src/bufr/openmg.f delete mode 100644 src/bufr/pad.f delete mode 100644 src/bufr/padmsg.f delete mode 100644 src/bufr/parstr.f delete mode 100644 src/bufr/parusr.f delete mode 100644 src/bufr/parutg.f delete mode 100644 src/bufr/pkb.f delete mode 100644 src/bufr/pkbs1.f delete mode 100644 src/bufr/pkc.f delete mode 100644 src/bufr/pkftbv.f delete mode 100644 src/bufr/pktdd.f delete mode 100644 src/bufr/pkvs01.f delete mode 100644 src/bufr/posapx.f delete mode 100644 src/bufr/rbytes.c delete mode 100644 src/bufr/rcstpl.f delete mode 100644 src/bufr/rdbfdx.f delete mode 100644 src/bufr/rdcmps.f delete mode 100644 src/bufr/rdmemm.f delete mode 100644 src/bufr/rdmems.f delete mode 100644 src/bufr/rdmgsb.f delete mode 100644 src/bufr/rdmsgb.f delete mode 100644 src/bufr/rdmsgw.f delete mode 100644 src/bufr/rdmtbb.f delete mode 100644 src/bufr/rdmtbd.f delete mode 100644 src/bufr/rdtree.f delete mode 100644 src/bufr/rdusdx.f delete mode 100644 src/bufr/readdx.f delete mode 100644 src/bufr/readerme.f delete mode 100644 src/bufr/readlc.f delete mode 100644 src/bufr/readmg.f delete mode 100644 src/bufr/readmm.f delete mode 100644 src/bufr/readmt.f delete mode 100644 src/bufr/readns.f delete mode 100644 src/bufr/reads3.f delete mode 100644 src/bufr/readsb.f delete mode 100644 src/bufr/restd.c delete mode 100644 src/bufr/rewnbf.f delete mode 100644 src/bufr/rjust.f delete mode 100644 src/bufr/rsvfvm.f delete mode 100644 src/bufr/rtrcpt.f delete mode 100644 src/bufr/seqsdx.f delete mode 100644 src/bufr/setblock.f delete mode 100644 src/bufr/setbmiss.f delete mode 100644 src/bufr/sntbbe.f delete mode 100644 src/bufr/sntbde.f delete mode 100644 src/bufr/status.f delete mode 100644 src/bufr/stbfdx.f delete mode 100644 src/bufr/stdmsg.f delete mode 100644 src/bufr/stndrd.f delete mode 100644 src/bufr/stntbi.f delete mode 100644 src/bufr/stntbia.f delete mode 100644 src/bufr/strcln.f delete mode 100644 src/bufr/strcpt.f delete mode 100644 src/bufr/string.f delete mode 100644 src/bufr/strnum.f delete mode 100644 src/bufr/strsuc.f delete mode 100644 src/bufr/stseq.c delete mode 100644 src/bufr/tabent.f delete mode 100644 src/bufr/tabsub.f delete mode 100644 src/bufr/trybump.f delete mode 100644 src/bufr/ufbcnt.f delete mode 100644 src/bufr/ufbcpy.f delete mode 100644 src/bufr/ufbcup.f delete mode 100644 src/bufr/ufbdmp.f delete mode 100644 src/bufr/ufbevn.f delete mode 100644 src/bufr/ufbget.f delete mode 100644 src/bufr/ufbin3.f delete mode 100644 src/bufr/ufbint.f delete mode 100644 src/bufr/ufbinx.f delete mode 100644 src/bufr/ufbmem.f delete mode 100644 src/bufr/ufbmex.f delete mode 100644 src/bufr/ufbmms.f delete mode 100644 src/bufr/ufbmns.f delete mode 100644 src/bufr/ufbovr.f delete mode 100644 src/bufr/ufbpos.f delete mode 100644 src/bufr/ufbqcd.f delete mode 100644 src/bufr/ufbqcp.f delete mode 100644 src/bufr/ufbrep.f delete mode 100644 src/bufr/ufbrms.f delete mode 100644 src/bufr/ufbrp.f delete mode 100644 src/bufr/ufbrw.f delete mode 100644 src/bufr/ufbseq.f delete mode 100644 src/bufr/ufbsp.f delete mode 100644 src/bufr/ufbstp.f delete mode 100644 src/bufr/ufbtab.f delete mode 100644 src/bufr/ufbtam.f delete mode 100644 src/bufr/ufdump.f delete mode 100644 src/bufr/upb.f delete mode 100644 src/bufr/upbb.f delete mode 100644 src/bufr/upc.f delete mode 100644 src/bufr/upds3.f delete mode 100644 src/bufr/upftbv.f delete mode 100644 src/bufr/ups.f delete mode 100644 src/bufr/uptdd.f delete mode 100644 src/bufr/usrtpl.f delete mode 100644 src/bufr/valx.f delete mode 100644 src/bufr/wrcmps.f delete mode 100644 src/bufr/wrdesc.c delete mode 100755 src/bufr/wrdlen.F delete mode 100644 src/bufr/wrdxtb.f delete mode 100644 src/bufr/writcp.f delete mode 100644 src/bufr/writdx.f delete mode 100644 src/bufr/writlc.f delete mode 100644 src/bufr/writsa.f delete mode 100644 src/bufr/writsb.f delete mode 100644 src/bufr/wrtree.f delete mode 100644 src/bufr/wtstat.f delete mode 100644 src/gsi/.CMakeLists.txt.swp delete mode 100644 src/wrflib/CMakeLists.txt delete mode 100644 src/wrflib/ext_ncd_get_dom_ti.code delete mode 100644 src/wrflib/ext_ncd_get_var_td.code delete mode 100644 src/wrflib/ext_ncd_get_var_ti.code delete mode 100644 src/wrflib/ext_ncd_put_dom_ti.code delete mode 100644 src/wrflib/ext_ncd_put_var_td.code delete mode 100644 src/wrflib/ext_ncd_put_var_ti.code delete mode 100644 src/wrflib/field_routines.F90 delete mode 100755 src/wrflib/io_int_stubs.f90 delete mode 100644 src/wrflib/model_data_order.inc delete mode 100644 src/wrflib/module_driver_constants.F90 delete mode 100644 src/wrflib/module_machine.F90 delete mode 100644 src/wrflib/pack_utils.c delete mode 100644 src/wrflib/streams.h delete mode 100644 src/wrflib/transpose.code delete mode 100644 src/wrflib/wrf_io.F90.orig delete mode 100644 src/wrflib/wrf_io.f90 delete mode 100644 src/wrflib/wrf_io_flags.h delete mode 100644 src/wrflib/wrf_status_codes.h diff --git a/CMakeLists.txt b/CMakeLists.txt index 8c9bf8a28b..093f822128 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -185,11 +185,13 @@ project(GSI) find_package( LAPACK ) endif() # build the WRF I/O libraries - if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/src/wrflib) - add_subdirectory(src/wrflib) + if(DEFINED ENV{GSIWRF_LIB}) + set(wrflib "$ENV{GSIWRF_LIB}" CACHE INTERNAL "WRFIO library" ) + elseif(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/libsrc/wrflib) + add_subdirectory(libsrc/wrflib) else() - message("src/wrflib not pulled from git, looking for WRF dependencies locally") - message("src/wrflib not pulled from git, looking for WRF dependencies locally") + message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") + message("libsrc/wrflib not pulled from git, looking for WRF dependencies locally") find_package( WRF ) endif() diff --git a/cmake/Modules/FindBUFR.cmake b/cmake/Modules/FindBUFR.cmake index 1f85768b16..58527743bc 100644 --- a/cmake/Modules/FindBUFR.cmake +++ b/cmake/Modules/FindBUFR.cmake @@ -31,17 +31,17 @@ if(NOT BUILD_BUFR ) endif() endif() if( NOT BUFR_LIBRARY ) # didn't find the library, so build it from source - message("Could not find BUFR library, so building from src") + message("Could not find BUFR library, so building from libsrc") if( NOT DEFINED ENV{BUFR_SRC} ) findSrc( "bufr" BUFR_VER BUFR_DIR ) else() - set( BUFR_DIR "$ENV{BUFR_SRC}/src" CACHE STRING "BUFR Source Location") + set( BUFR_DIR "$ENV{BUFR_SRC}/libsrc" CACHE STRING "BUFR Source Location") endif() set( libsuffix "_v${BUFR_VER}${debug_suffix}" ) set( BUFR_LIBRARY "${LIBRARY_OUTPUT_PATH}/libbufr${libsuffix}.a" CACHE STRING "BUFR Library" ) set( bufr "bufr${libsuffix}") set( BUILD_BUFR "ON" CACHE INTERNAL "Build the BUFR library") - add_subdirectory(${CMAKE_SOURCE_DIR}/src/bufr) + add_subdirectory(${CMAKE_SOURCE_DIR}/libsrc/bufr) set( BUFR_LIBRARY ${bufr} ) if( CORE_BUILT ) diff --git a/cmake/Modules/findHelpers.cmake b/cmake/Modules/findHelpers.cmake index e251175da9..028957a0a6 100644 --- a/cmake/Modules/findHelpers.cmake +++ b/cmake/Modules/findHelpers.cmake @@ -1,8 +1,8 @@ function (findSrc varName version varDir ) - if(EXISTS ${CMAKE_SOURCE_DIR}/src/${varName}) - message("setting source for ${varName} to be in src") - set( ${varDir} "${CMAKE_SOURCE_DIR}/src/${varName}" PARENT_SCOPE) - set( ${varCacheName} "${CMAKE_SOURCE_DIR}/src/${varName}" CACHE STRING "" FORCE ) + if(EXISTS ${CMAKE_SOURCE_DIR}/libsrc/${varName}) + message("setting source for ${varName} to be in libsrc") + set( ${varDir} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" PARENT_SCOPE) + set( ${varCacheName} "${CMAKE_SOURCE_DIR}/libsrc/${varName}" CACHE STRING "" FORCE ) else() set(searchName ${varName}_v${${version}}) message("searching for source for ${searchName} in ${CRTM_BASE}") diff --git a/cmake/Modules/platforms/Generic.cmake b/cmake/Modules/platforms/Generic.cmake index 1cf3613ce2..b584cf66cf 100644 --- a/cmake/Modules/platforms/Generic.cmake +++ b/cmake/Modules/platforms/Generic.cmake @@ -12,8 +12,7 @@ macro (setGeneric) set(ENKF_Platform_FLAGS "-O3 ${HOST_FLAG} -warn all -implicitnone -traceback -fp-model strict -convert big_endian -DGFS -D_REAL8_ ${OpenMP_Fortran_FLAGS}" CACHE INTERNAL "ENKF Fortran Flags") message("setting values for corelibs") - set(BUILD_BUFR "ON" CACHE INTERNAL "Build the BUFR library" ) - + set(BUILD_BUFR "OFF" CACHE INTERNAL "Build the BUFR library" ) set(BUILD_BACIO "OFF" CACHE INTERNAL "Build the BACIO library" ) set(BUILD_SFCIO "OFF" CACHE INTERNAL "Build the SFCIO library" ) set(BUILD_SIGIO "OFF" CACHE INTERNAL "Build the SIGIO library" ) diff --git a/src/bufr/.gitrepo b/src/bufr/.gitrepo deleted file mode 100644 index 5613b78622..0000000000 --- a/src/bufr/.gitrepo +++ /dev/null @@ -1,11 +0,0 @@ -; DO NOT EDIT (unless you know what you are doing) -; -; This subdirectory is a git "subrepo", and this file is maintained by the -; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme -; -[subrepo] - remote = none - branch = master - commit = 3048cc07ded08e77a5d60d1ae0ba8eaa39c873d1 - parent = c8258179932d604e01f94d641f526f314d2ad27d - cmdver = 0.3.1 diff --git a/src/bufr/CMakeLists.txt b/src/bufr/CMakeLists.txt deleted file mode 100644 index db24ca0793..0000000000 --- a/src/bufr/CMakeLists.txt +++ /dev/null @@ -1,22 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -#message("in bufr") -if(BUILD_BUFR) - file(GLOB BUFR_F77_SRC ${BUFR_DIR}/*.f ${BUFR_DIR}/*.F) - file(GLOB BUFR_C_SRC ${BUFR_DIR}/*.c) - file(GLOB BUFR_PRM ${BUFR_DIR}/*.PRM) - - ADD_CUSTOM_COMMAND( OUTPUT "${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm" - PRE_BUILD - COMMAND cpp -P -D_REAL8_ -DWRF -DLINUX -DPGI -traditional-cpp ${BUFR_DIR}/bufrlib0.PRM -o ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm - DEPENDS ${BUFR_DIR}/bufrlib0.PRM - ) - add_custom_target(bufrlib_prm DEPENDS ${CMAKE_INCLUDE_OUTPUT_DIRECTORY}/bufrlib.prm ) - if( BUFR_F77_SRC ) - set_source_files_properties( ${BUFR_F77_SRC} COMPILE_FLAGS ${BUFR_Fortran_FLAGS}) - endif() - set_source_files_properties( ${BUFR_C_SRC} COMPILE_FLAGS ${BUFR_C_FLAGS} ) - - add_library( ${bufr} STATIC ${BUFR_C_SRC} ${BUFR_F77_SRC} ) - add_dependencies(${bufr} bufrlib_prm) - set_target_properties( ${bufr} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) -endif() diff --git a/src/bufr/README.libbufr b/src/bufr/README.libbufr deleted file mode 100755 index a5b7926f55..0000000000 --- a/src/bufr/README.libbufr +++ /dev/null @@ -1,1617 +0,0 @@ - - Original Implementation of BUFR Archive Library - 12Z 6 January 1994 - -Implemented on Cray-YMP as a single monolithic source bufr.f. Only the AVN -and FNL PREPBUFR processing and q.c. codes used the BUFR Archive Library -initially. These were: PREPDATA, SYNDATA, CQCBUFR, OIQCBUFR, and SSIANL. -These had actually been implemented with a non-production version of the -library in Jack Woollen's directory on 12Z 21 September 1993. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 10 January 1995 - -The BUFR Archive Library was modified slightly to allow for changes in the AVN -and FNL PREPBUFR and Q.C. Processing codes (PREPDATA, CQCBUFR, OIQCBUFR, -SSIANL). - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 28 June 1995 - -The BUFR Archive Library was modified to increase the size of internal arrays -in order to handle bigger files. Coding was also added in order to process -ERS scatterometer data which is input from compressed BUFR messages (new -subroutine READERME). - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 09 September 1996 - -The BUFR Archive Library was separated into 121 BUFR interface routines, -which include upgrades and devices for operating the BUFR database. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 21Z 09 October 1996 - -The BUFR Archive Library was modified to include 9 additional routines to -process ERS scatterometer data (IREADERS, RDTRER, READERS, UNCMPS), perform -fault tolerant reading (IREADFT, READFT), and support report part merging -(INVMRG, MRGINV, NWORDS). - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 25 November 1996 - -Several routines in the BUFR Archive Library are being modified to provide -more machine independence. The data merging routine is being modified -for radiosonde call signs, a return code is being added to UFBINT when -mnemonics are not found, and READMG is being modified to exit gracefully when -the file is positioned after an end of file - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 11 December 1996 - -The following subroutines were modified in the BUFR Archive Library: - - STATUS - Fixed a long standing bug which occurs in unusual situations. Very - low impact. - - UFBINT - Removed a hard abort for users who try to write non-existing - mnemonics. - - UFBRW - Removed a hard abort for users who try to write non-existing - mnemonics. - - ADDATE - New date arithmetic subroutine added to the library. - - DUMPBF - New dump date reader added to the library. - - MSGINI - Modified to allow inclusion of minutes in writing the message date - into a BUFR message. - - READTJ - Specific database ingest message reader added to the library which - can attach different BUFR tables if the message type is not - recognized in the current ones. Works with a user subroutine - called OPENBT which specifies the location(s) of different tables. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 21Z 17 December 1996 - -The BUFR Archive Library was modified to make the following changes: - - DUMPBF - Corrected error in dump date reader. - - RDUSDX - Fixed for some MVS compiler's treatment of internal reads. - - RDBFDX - Fixed for some MVS compiler's treatment of internal reads. - - UFBINT - Modified to always initialize "USR" array to missing (10E10) when - BUFR file is being read. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 29 July 1997 - -Three BUFR Archive Library subroutines were modified to update the current -BUFR version information written into Section 0 of each message: DXMINI, -MSGINI and MSGWRT. Version 3 replaces version 2. - -Three additional subroutines were modified to enable them to process GOES -soundings from NESDIS: IRDERM, RDTRER and READERME. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 03 September 1997 - -Changes are being made to the BUFR Archive Library to recompile all routines -without the -ez compiler option. The removal of this debugging option should -speed up the execution of all modules which are linked with BUFR Archive -Library routines. - -In addition, a new subroutine, STANDARD, is being added to the library. This -subroutine "standardizes" NCEP BUFR messages for transmission. It was -requested to process hurricane location data. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 02 April 1998 - -BUFR Archive Library subroutine STRCLN, which initializes the mnemonic string -cache in the BUFR interface, is being modified to enlarge the cache from 50 -elements to 1000, maximum. - -BUFR Archive Library subroutine STRING manages the mnemonic string cache in -the BUFR interface. The mnemonic string cache is a performance enhancing -device which saves time when the same mnemonic strings are encountered in a -user program, over and over again (the typical scenario). It is being -modified to operate a bigger cache, and some optimization of the cache search -algorithm is being made in support of a bigger cache. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 20Z 08 July 1998 - -The new version of the BUFR Archive Library is Y2K compliant, with additional -changes to support expanded machine independence of the code, and to refine, -correct, or improve some of the routines within. Although nearly every one of -library routines has some change made (mainly because of the introduction of a -more general error exit subroutine), the changes largely fall into the first -two categories. Three new routines were also added to the BUFR Archive Library -for micellaneous puposes. - -1) Y2K Compliance - -Y2K compliance in the BUFR Archive Library is downwardly compatible. That is, -the new library will read non-Y2K BUFR files as the old one does. However, all -two digit years read are represented internally as four digit years, and any -files written with the new library will be in Y2K format. A functional -conversion of two digit year inputs assumes the years 21-99 are in the -twentieth century, while years numbered 00-20 are in the twenty-first. A Y2K -BUFR file is identified by a non-zero value in the 18th byte of the message -section one, the century byte. At this point users of the library have access -to the full four digit year values read by including a signal in their programs -via a new entry point called DATELEN. The plan is to have the default set to -return two digits of the year during a transition period. This allows -implementation of the new BUFR Archive Library into a non-Y2K compliant -environment. The susbsequent list of subroutines have been changed for Y2K -compliance: BFRINI, DATEBF, DUMPBF, MSGINI, OPENMB, OPENMG, RDMEMM, READERME, -READFT, READMG, READTJ. - -2) Machine Independence - -Since the last implementation of the BUFR Archive Library, several areas in the -code have been identified which are problematic in some way with regards to -compiling the library on some computers. Upgrades have been made to the -following list of subroutines to address these: CONWIN, INVCON, PARUSR, -RDTRER, READERM, READERME, TRYBUMP, UFBEVN, UFBGET, UFBINT, UFBRP, UFBRW, -UFBTAB and UNCMPS. - -3) Refinements, Corrections, and Improvements - -This is a list of BUFR Archive Library routines which were either in error, -or in need of some improvement: IRDERM, NEMTBB, NENUCK, RDBFDX, RDUSDX, STRCLN, -STRING, TABENT, UNCMPS and WRTREE. -4) New Error Exit Subroutine - -Many of the BUFR Archive Library routines perform internal testing during -operation in order to prevent certain situation from generating mysterious -aborts, or, even worse, giving the wrong answers. The original library utilized -the Cray library routine ABORT to terminate a program when such a situation was -found. The new library uses a new inernal subroutine, BORT, to accomplish -this. The list of routines changed for this purpose is as follows: ADN30, -CHEKSTAB, CLOSMG, COPYBF, COPYMG, COPYSB, CPYMEM, CPYUPD, DATEBF, DRSTPL, -DUMPBF, DXMINI, ELEMDX, GETWIN, IDN30, IFBGET, INCTAB, INVMRG, IPKM, IUPM, -JSTIFY, LSTJPB, LSTRPC, LSTRPS, MAKESTAB, MSGINI, MSGUPD, MSGWRT, MVB, NEMTBA, -NEMTBB, NEMTBD, NENUCK, NEWWIN, NMSUB, NVNWIN, NXTWIN, OPENMB, OPENMG, OPENBF, -PAD, PARSEQ, PARUSR, PARUTG, PKC, POSAPN, POSAPX, RCSTPL, RDBFDX, RDMEMM, -RDMEMS, RDUSDX, READDX, READERM, READERME, READERS, READFT, READMG, READNS, -READSB, READTJ, SEQSDX, STANDARD, STATUS, STRING, TABENT, TABSUB, UFBCNT, -UFBCPY, UFBCUP, UFBDMP, UFBEVN, UFBGET, UFBINT, UFBMEM, UFBMMS, UFBMNS, -UFBOVR, UFBQCD, UFBQCP, UFBREP, UFBRMS, UFBTAM, UPTDD, USRTPL, VAL$, WRDLEN, -WRITDX, WRITSA, WRITSB, WTSTAT - -5) New Code Added - -I4DY the two/four digit year conversion function -LJUST a character left justify function -OPENBT A dummy entry point which is relevant to users of the READTJ - subroutine - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 31 August 1998 - -BUFR Archive Library subroutine DATEBF, which returns the center date-time for -a BUFR data dump file, is being modified to correct an error which lead to the -year being returned in the second argument as 2-digit year when a 4-digit year -was requested via a prior call to subroutine DATELEN. The center date -returned in the sixth argument, in the form YYYYMMDDHH, was correct in the -previous version of this subroutine. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 27 October 1998 - -The BUFR Archive Library is being modified to correct problems caused by -in-lining code with fpp directives. The following subroutines are being -changed: DATEBF, MVB, RCSTPL, RDMEMS, RDTREE, RDTRER, UFBGET, UFBRW, UFBTAB, -UFBTAM and UPBB. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 24 November 1998 - -Fuction I4DY and subroutine MSGWRT were changed as a result of final Y2K -testing of the decoder/ingest system. - -I4DY was changed to conform to the NCEP 2-digit year time-window of 1921-2020. - -MSGWRT was changed to zero out the padding bytes written at the end of -Section 4. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 14 December 1998 - -Subroutine MSGUPD was updated to bybass the processing of reports that are -longer than the length of a BUFR message. Prior to this change, the BUFR -Archive Library would issue an abort in the event of this rare, but possible -occurrence which occurred at 12Z on 4 December in the RGL suite. - -In addition, function I4DY was modified to use 20 as the 2-digit year for -windowing to a 4-digit year (00-20 ==> add 2000; 21-99 ==> add 1900). This -windowing technique was inadvertently changed to 10 in the previous -implementation of the BUFR Archive Library. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 18 November 1999 - -The BUFR Archive Library on the IBM-SP was implemented into productuction when -this machine became operational (replacing the Cray-YMP/J-90's). - -The following changes were actually implemented on the IBM-SP on 18Z 13 July -1999 prior to it's operational status): - - -1) A number of routines in the BUFR Archive Library have been modified to -increase the number of BUFR files which can be opened at one time from 10 to -32. This is necessary in order to process multiple BUFR files under the MPI. -The following routines were modified: BFRINI, CHEKSTAB, CLOSMG, CONWIN, COPYMG, -COPYSB, CPBFDX, CPYMEM, CPYUPD, DXINIT, ELEMDX, GETWIN, IFBGET, INVCON, INVMRG, -INVTAG, INVWIN, LSTJPD, LSTRPC, LSTRPS, MAKESTAB, MSGINI, MSGUPD, NEMTAB, -NEMTBA, NEMTBD, NENUCK, NEWWIN, NMSUB, NUMTAB, NVNWIN, NWORDS, NXTWIN, OPENBF, -OPENMB, OPENMG, PARUTG, PKTDD, RCSTPL, RDBFDX, RDMEMM, RDMEMS, RDTREE, RDTRER, -RDUSDX, READERM, READERME, READERS, READFT, READMG, READNS, READSB, READTJ, -STATUS, STRING, TRYBUMP, UFBCNT, UFBCPY, UFBCUP, UFBDMP, UFBEVN, UFBGET, -UFBINT, UFBOVR, UFBREP, UFBRP, UFBRW, UFBTAB, UFBTAM, UNCMPS, UPTDD, USRTPL, -WRITDX, WRTREE, WTSTAT. - -2) Subroutines READFT, READMG, and READTJ have been modified with semantic -adjustments to ameliorate compiler complaints from LINUX boxes. - -3) Added the new subroutine READIBM in order to process "foreign" (non-NCEP) -BUFR files which may not be padded. Unlike the subroutine READERM, which -performs a similar fuction, READIBM works properly on all platforms and should -replace calls to READERM in application programs. (READERM does not work -properly on the NCEP IBM-SP machine.) - -4) Added the new subroutine NEMTBAX. It is like subroutine NEMTBA except if -the requested mnemonic is not found, it returns rather than calls BORT. This -is necessary to support the logic in the new BUFR Archive Library subroutine -READIBM (see 3). - -5) Added the new subroutine READMM. It is like subroutine RDMEMM except it -advances the value of the message (record) number by one prior to returning -to the calling program. This adds another option for application programs -which read BUFR files in random access mode (e.g., PREPOBS_OIQCBUFR). - -6) Function IREADMG has been modified to contain two new function entries -called IREADMM and IREADIBM. The IREADIBM function calls the new library -subroutine READIBM (see 3) and the IREADMM function calls the new library -subroutine READMM (see 5). - -7) RDTRER, READERM, READERME and UNCMPS have been modified to expand the -maximum number of possible descriptors in a subset from 1000 to 3000. - -8) The maximum number of bytes required to store all messages internally was -increased from 4 Mbytes to 8 Mbytes in the following subroutines: RDMEMM, -UFBMEM, UFBMMS, UFBMNS and UFBRMS. - -9) The function formerly called VAL$ has been renamed to VALX to remove the -possibility of the "$" symbol causing problems on other platforms. In turn -subroutine NEMTBB has been modified to call function VALX rather than VAL$. - -10) New subroutines UFBSTP and UFBSP added (UFBSP is called by UFBSTP). - N O T S U R E W H A T T H E S E D O ! ! ! - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 19 September 2000 - -A number of routines in the BUFR Archive Library have been modified. These -changes include: - -1) Consolidated logic that had been replicated in message decoding subroutines -READMG, READFT, READTJ, READERM, READERME, RDMEMM and READIBM into a single -new subroutine CKTABA (called by these subroutines). On top of this CKTABA -now recognizes a variety of Section 3 formats, including compression -indicators and "standard" BUFR. Thus, compressed and standard BUFR messages -can now be read in via these message decoding subroutines. - -2) The subset decoding subroutine READSB now calls a new subroutine RDCMPS -which allows it to read subsets from compressed BUFR messages. - -3) Subroutine RDTRER has been removed. It had been called by READERS to decode -ERS scatterometer data from compressed BUFR messages. The change in READSB -(see 2) allows READERS to be changed from a subroutine to an entry point at the -top of READSB since it is now essentially an alias to READSB. - -4) Subroutine UNCMPS has been removed. It had been called by READERM, READERME -and READIBM to uncompress BUFR messages in foreign (i.e., standard ) BUFR files -(e.g., ERS scatterometer data). This is a result of change 1 above. - -5) Added capability to encode and decode data using the operator descriptors -(BUFR Table C) for changing width and changing scale. Subroutines modified -were: NEMTAB, NEMTBD, NUMTAB and TABSUB - -6) Enlarged arrays to allow processing messages up to 20000 bytes. Routines -modified were: BFRINI, CLOSMG, COPYBF, COPYMG, COPYSB, CPYMEM, CPYUPD, IRDERM, -MESGBF, MINIMG, MSGINI, MSGUPD, MSGWRT, POSAPN, POSAPX, RCSTPL, RDBFDX, RDMEMM, -RDMEMS, RDTREE, READERM, READERME, READFT, READIBM, READMG, READMM, READSB, -READTJ, UFBGET, UFBMEM, UFBTAB, UFBTAM, WRITDX, WRITSA and WRTREE. - -7) Added subroutine UFBSEQ, like UFBINT except processes specific sequences -instead of specific elements. - -8) Added function NMBYT, returns the number of bytes in a message opened for -input. - - -The BUFR Archive Library is now compiled using both optimization level 3 (-O3) -and optimization level 4 (-O4). The previous BUFR Archive Library had used -only -O4. The -O3 compilation here generates the same archive library names as -before. Thus, any code that is recompiled from an unchanged makefile will now -link in the appropriate -O3 library, rather than the -O4 library as before. -The new -O4 libraries all have the string "_O4" appended to the end of the -filename. - -Any program that must link to the -O4 BUFR Archive Library when compiled will -have to modify its makefile. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 19Z 15 August 2001 - - -Parameter MAXMEM (the maximum number of bytes required to store all messages -internally) was increased from 8 MBYTES TO 16 MBYTES in the following -subroutines: CPYMEM, RDMEMM, RDMEMS, READMM, UFBMEM, UFBMMS, UFBMNS, UFBRMS and -UFBTAM. - -Subroutine UFBTAM modified to not abort when there are too many subsets coming -in (i.e., .gt. array limit passed in), but rather to just process the limiting -number of reports and print a diagnostic. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 14 May 2002 - -A number of routines in the BUFR Archive Library have been modified. These -changes include: - -1) Entries IREADMM, IREADNS, IREADSB, IREADERS, IREADIBM, IREADFT and -ICOPYSB changed to functions. Entries MRGINV, MINIMG, DATELEN, NENUBD, -NENUAA, JSTNUM, JSTCHR and READERS changed to subroutines (note that READERS -now simply calls READSB since it was an entry point at the top of READSB and -was thus already an alias to it). Converted all entry points to subroutines or -functions in order to increase portability to other platforms (e.g., the NESDIS -CEMSCS machine). - -2) Entries DXMINA, DXMINB, DXMIND and SUBUPD removed because they are -obsolete. - -3) Added XMSGINI for capacity to expand section three. XMSGINI has the -capacity to write a fully expanded section three descriptor set into BUFR -messages. Created specifically for NESDIS so they can send files out without -local sequence descriptors. This "capacity" is not fully functional, it is -currently activated by changing WRCMPS.to call it rather than CMSGINI, which -writes sections 0,1,2,3 for compressed messages in the usual way. XMSGINI -is included because it is useful for particular situations as is (aka -NESDIS), and at some point could be integrated as a more direct form of -STANDARDizing messages for export or whatever. - -4) Included in-line compression function (subr. CMSGINI, WRITCP, WRCMPS -added). - -5) Improved RDCMPS and UFBSEQ for generality. Previously RDCMPS and UFBSEQ -would not recognise compressed delayed replication as a legitimate data -structure. - -6) Removed old CRAY compiler directives in: COPYSB, CPYUPD, DRSTPL, GETWIN, -INVMRG, MVB, NEWWIN, NXTWIN, RCSTPL, READSB, UFBDMP, UFBGET, UFBINT, UFBOVR, -UFBRW, UFBTAB, UFBTAM and USRTPL. - -7) Added new subroutine UFDUMP which is like UFBDMP, but prints subset element -contents in more detail, omitting the pointers, counters, and other more -esoteric information describing the internal subset structures. Each -subroutine, UFBDMP and UFDUMP, is useful for different diagnostic purposes, -but in general UFDUMP is more useful for just looking at the data elements. - -8) Corrected error in READSB relating to certain foreign filetypes. - -9) Added new subroutine DRFINI which initializes delayed replication factors, -and allocates the space in the full word buffer for their contents -explicitly. This is done implictly by UFBINT in a more limited way. DRFINI -enables, for instance, the subsequent use of UFBSEQ to write data directly -into delayed replicated sequences. - -10) Added new subroutine MAXOUT which allows users to control the record -length of output BUFR messages created. - -11) Added new subroutine NUMTBD which is used by XMSGINI, in expanding the -section 3 descriptor list. - -12) Added new subroutine CAPIT which capitalizes a string of characters. This -enables the use of mixed case in the unit section of the ASCII BUFR tables. -An example; a program which generates an ASCII BUFR table from the "Master -Table B", might end up copying some units fields in mixed or lower case. If -the units are 'Code table' or 'Flag table' or certain other unit -designations, the table will be parsed incorrectly, and the data read or -written incorrectly as a result. This makes sure all unit designations are -seen by the parser in upper case to avoid these types of problems. - -13) Removed subroutine JSTIFY because it was a dummy subroutine with two -entry points for left justifying two different types of character strings. -Part of conversion of entry points to separate subroutines or functions. See -number 1 above. - -14) Removed subroutine NENUCK because it was a dummy subroutine with two -entry points for checking the BUFR mnemonic table. Part of conversion of -entry points to separate subroutines or functions. See number 1 above. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 27 May 2003 - (Actually implemented into productuction 12Z 19 May 2003 when the IBM - Frost and Snow machines became operational at NCEP) - -The following changes have been made in the BUFR Archive Library: - -1) Subroutine CLOSMG - to correct a problem introduced in the previous -(May 2002) implementation which prevented the dump center time and initiation -time messages from being written out (affected program BUFR_DUMPMD, if it were -recompiled, in the data dumping process) - -2) Subroutine UFBREP - to work properly for descriptors tied to a pivot -descriptor in delayed replicated sequences (involved disabling the parsing -switch which controlled checking for presence in the same replication group - -UFBREP does not need this check, and it interferes with what UFBREP can do -otherwise) - -3) Subroutine UFBSEQ - to fix cases where delayed replication is at end of -subset, or when a requested sequence is missing; also corrected the logic -array of exit conditions for the subroutine, previously, in some cases, proper -exits were missed, generating bogus error messages, because of several -miscellaneous bugs which are now removed - -4) Subroutine UPB - to make certain zero is returned for zero bits input - -5) The following subroutines are modified to replace calls to Fortran -Insrinsic Function ICHAR with calls to NCEP W3LIB c-function MOVA2I: DATEBF -and DUMPBF. This change increases portability of the BUFR Archive Library -because MOVA2I copies a bit string from a Character*1 variable to an integer -variable. It is intended to replace the Fortran Intrinsic Function ICHAR, -which only supports 0 <= ICHAR(A) <= 127 on the IBM SP. If "A" is greater -than 127 in the collating sequence, ICHAR(A) does not return the expected bit -value. This function can be used for all values of ICHAR(A) between 0 and -255. This change increases portability of the BUFR Archive Library and is, in -fact, necessary on the NCEP IBM Frost and Snow machines. - - -The BUFR Archive Library on Frost and Snow is compiled using optimization -level 4 (-O4) for Fortran routines and optimization level 3 (-O3) for c -routines. The previous BUFR Archive Library on the IBM-SP's had used -O3 for -the default filenames and -O4 for a second set of filenames with the string -"_O4" appended to the end. - -The following libraries are generated on the NCEP IBM Frost and Snow machines: - -libbufr_4.a -- 4-byte reals, 4-byte integers, 64-bit executable compilation -libbufr_8.a -- 8-byte reals, 8-byte integers, 64-bit executable compilation -libbufr_d.a -- 8-byte reals, 4-byte integers, 64-bit executable compilation - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 12Z 04 November 2003 - -This is the first "unified" BUFR Archive Library including components from the -regular NCEP production machine version (whose implementation history is -documented to this point), the decoder version (previously on a workstation but -now on the IBM Frost and Snow machines), and a checkout NCEP/EMC grid-to-obs -verification version. This version is portable to all platforms (as necessary -for WRF), contains docblocks for each routine with a complete program history -log, and outputs more complete diagnostic information when routines terminate -abnormally, unusual things happen or for informational purposes. - -The following libraries are now generated on the NCEP IBM Frost and Snow -machines: - -libbufr_4_64.a -- 4-byte reals, 4-byte integers, 64-bit executable compilation -libbufr_8_64.a -- 8-byte reals, 8-byte integers, 64-bit executable compilation -libbufr_d_64.a -- 8-byte reals, 4-byte integers, 64-bit executable compilation -libbufr_4_32.a -- 4-byte reals, 4-byte integers, 32-bit executable compilation - -The first three are compiled exactly the same as the three libraries noted in -the previous 05-27-2003 implementation (they are just renamed). The fourth -library is compiled identically to the previous decoder-specific version on -Frost and Snow (libdecod_bufr_32.a). It is compiled with optimization level 3 -(-O3) for both Fortran and c routines and will be linked into the production -decoder programs in place of libdecod_bufr_32.a. - - -The following routines have been added to the BUFR archive library: - -1) Subroutine BORT2 which prints (to STDOUT) two given error strings and -then calls BORT_EXIT (see 7 below) to abort the application program calling -the BUFR Archive Library software. It is similar to existing subroutine BORT, -except BORT prints only one error string. - -2) Function IUPBS1 which, given a BUFR message contained within array MBAY, -unpacks and returns the binary integer contained within byte NBYT of -Section 1 of the BUFR message. This was present in the original decoder- -specific version of the library. - -3) Subroutine OVRBS1 which, given a BUFR message contained within array MBAY, -packs and stores the value of a binary integer into byte NBYT of Section 1 -of the BUFR message, overwriting the value previously stored there. - -4) Subroutine UPDS3 which, given a BUFR message contained within array MBAY, -unpacks and returns the descriptors contained within Section 3 of the BUFR -message. This was present in the original decoder-specific version of the -library. - -5) Function MOVA2I (see "Changes to BUFR Archive Library, 12Z 27 May 2003" -number 5 for more info). This Fortran version replaces the W3LIB c-version -previously called by DATEBF and DUMPBF. It is now called by new subroutines -MESGBC (see 6) and REWNBF (see 11) as well. This change removes any -dependency upon the W3LIB, since no other BUFR Archive Library routines call -any W3LIB routines. It was converted to Fortran 77 because the c-version does -not work properly when compiled with 32-bit executable compilation and linked -into a Fortran source copiled with 8-byte real and integer word length. - -6) Subroutine MESGBC reads past any BUFR table (dictionary) or dummy -(center or dump time in dump files) messages in a BUFR file (if there are -any) and returns the message type for the first report data message found. -It also determines whether or not this first report data message is -compressed BUFR. This subroutine is identical to MESGBF except MESGBF -only reads past dictionary messages and MESGBF does not return any -information about compression. - -7) C subroutine BORT_EXIT terminates the application program calling the -BUFR software and returns an implementation-defined non-zero status code to -the executing shell script. (See 1 and 26.) - -8) Subroutine RDMGSB opens a BUFR file in logical unit LUNIT for input -operations, then reads a particular subset into internal subset arrays from a -particular BUFR message in a message buffer. This is based on the subset -number in the message and the message number in the BUFR file. This was -present in the original verification-specific version of the library. - -9) Subroutine SUBUPD packs up the current subset within memory and then tries -to add it to the BUFR message that is currently open within memory for -LUNIT. If the subset will not fit into the currently open message, then that -message is flushed to LUNIT and a new one is created in order to hold the -current subset. If the subset is larger than an empty message, the subset is -discarded and a diagnostic is printed. This subroutine is identical to -existing BUFR Archive Library subroutine MSGUPD except SUBUPD does NOT pad the -packed subset. This was present in the original verification-specific version -of the library. - -10) Subroutine UFBINX either opens a BUFR file for input operations (if it is -not already opened as such), or saves its position and rewinds it to the first -data message (if BUFR file already opened), then (via a call to BUFR Archive -Library subroutine UFBINT) reads specified values from internal subset arrays -associated with a particular subset from a particular BUFR message in a message -buffer. The particular subset and BUFR message are based based on the subset -number in the message and the message number in the BUFR file. Finally, this -subroutine either closes the BUFR file (if is was opened here) or restores it -to its previous read/write status and position (if is was not opened here). -This was present in the original verification-specific version of the library. - -11) Subroutine REWNBF which will either: 1) store the current parameters -associated with a BUFR file (read/write pointers, etc.), set the file status -to read, then rewind the BUFR file and position it such that the next BUFR -message read will be the first message in the file containing actual subsets -with data; or 2) restore the BUFR file to the parameters it had prior to 1) -using the information saved in 1). This allows information to be extracted -from a particular subset in a BUFR file which is in the midst of being read -from or written to by an application program. This was present in the original -verification-specific version of the library. - -12) Subroutine UFBIN3 reads specified values from the current BUFR data subset -where the data values correspond to mnemonics which are part of a multiple- -replication "level" sequence within another multiple-replication "event stack" -sequence. This subroutine is designed to read event information from -"PREPFITS" type BUFR files (currently the only application which reads -PREPFITS files is the verification program GRIDTOBS, where UFBIN3 was -previously an in-line subroutine). The existing analogous subroutine UFBEVN -should be used to read information from "PREPBUFR" type BUFR files. This was -present in the original verification-specific version of the library. - -13) Function NEVN accumulates all data events for a particular data value and -level and returns them to the calling program. The value of the function -itself is the total number of events found. {This function should only be -called by UFBIN3 (see 12), which, itself, is called only by verification -application program GRIDTOBS, where it was previously an in-line subroutine. -In general, NEVN does not work properly in other application programs at this -time.} This was present in the original verification-specific version of the -library. - -14) Subroutine READLC returns a character data element associated with a -particular subset mnemonic from the internal message buffer. It is designed -to be used to return character elements greater than the usual length of 8 -bytes. It currently will not work for compressed BUFR mesaages. - -15) Subroutine WRITLC packs a character data element associated with a -particular subset mnemonic from the internal message buffer. It is designed -to be used to store character elements greater than the usual length of 8 -bytes. - -16) Subroutine WRITST generates a standardized version of the current BUFR -message in internal memory and writes it to the output file (not sure if -it works properly). - -17) Subroutine COPYST generates a standardized version of the current BUFR -message read using READMG and writes it intact as a record to the output -file. - -18) Subroutine COMPRES compresses subsets in BUFR messages previously read -using BUFR Archive Library subroutine READMG or equivalent. It then -generates a new bufr message consisting of the compressed subsets. Note -that subsets in the output compressed message may have been read from -different (adjacent) input messages. Currently the only application program -which calls this subroutine is BUFR_COMPRESS, where COMPRES was previously -an in-line subroutine). - -19) Subroutine READ2C reads a subset into compression maxtrix arrays in -preparation for generating compressed BUFR messages. This had been an in- -line subroutine in the application program BUFR_COMPRESS and is currently -called only by BUFR Archive Library subroutine COMPRES (see 18). - - - -The following routines in the BUFR archive library have been modified: - -20) Subroutine UPBB modified to make certain zero is returned for zero bits -input and to make logic consistent with logic in UPB. (See also 30 for UPBB.) - -21) Subroutine UFBTAB modified to not abort when there are too many subsets -coming in (i.e., .gt. array limit passed in), but rather to just process the -limiting number of reports and print a diagnostic. It is also modified to -call subroutine REWNBF when the BUFR file is already opened (this is taken -from the verification version of UFBTAB and allows specific subset information -to be read from a file in the midst of being read from or written to), before -OPENBF was always called and this would have led to an abort of the -application program. (See also 29 for UFBTAB.) - -22) Subroutine CKTABA modified to not abort when the Section 1 message subtype -does not agree with the Section 1 message subtype in the dictionary IF the -message type mnemonic is not of the form "NCtttsss", where ttt is the BUFR type -and sss is the BUFR subtype. This allows program PREPOBS_PREPDATA to specify -different message subtypes for the same message type. (See also 27 and 43.) - -23) Subroutine OPENBF modified to accept 'NUL' as the second (I/O) argument. -IO='NUL' prevents the BUFR Archive Library software from actually trying to -access or write to the BUFR file (designed only for use with library -subroutine WRITSA). This was present in the original decoder-specific version -of the library. - -24) Subroutine CLOSBF modified to not close the BUFR file if it was opened as -'NUL' by OPENBF (see 23). This was present in the original decoder-specific -version of the library. - -25) Subroutine MSGWRT modified to not write to the BUFR file if it was opened -as 'NUL' by OPENBF (see 23). This was present in the original decoder- -specific version of the library. - -26) Subroutine BORT modified to call new BUFR Archive Library subroutine -BORT_EXIT (see 7 above) rather than c function EXIT with argument 49 {"CALL -EXIT(49)"}. Since EXIT is an intrinsic c function, it expects arguments to be -passed by value rather than by reference as in done in Fortran. This has -caused an unpredictable status code to be passed back to the executing shell -script, in some cases even ZERO!! This change will ensure an non-zero status -is always returned. - -27) Suboutines CKTABA, DATEBF, DUMPBF and function I4DY modified such that -date calculations no longer use floating point arithmetic. This can lead to -round off error and an improper resulting date on some machines (e.g., NCEP -IBM Frost/Snow). This change increases portability of the BUFR Archive -Library. (See also 22 and 43 for CKTABA.) - -28) Parameter MAXMSG (the maximum number of BUFR messages which can be stored -internally) increased from 50000 to 200000 in the following subroutines: -CPYMEM, RDMEMM, RDMEMS, READMM, UFBMEM, UFBMMS, UFBMNS, UFBRMS and UFBTAM. -This may be necessary in the future for BUFR files with many, many messages. - -29) Parameter MAXJL (the maximum number of Jump/Link table entries) increased -from 15000 to 16000 in the following routines: BFRINI, CONWIN, COPYMG, CPYMEM, -DRFINI, DRSTPL, GETWIN, INCTAB, INVCON, INVMRG, INVTAG, INVWIN, LSTJPB, -LSTRPC, LSTRPS, MAKESTAB, MSGINI, NEWWIN, NVNWIN, NWORDS, NXTWIN, PARUTG, -RCSTPL, RDCMPS, RDTREE, READNS, TABENT, TABSUB, TRYBUMP, UFBCPY, UFBCUP, -UFBDMP, UFBEVN, UFBGET, UFBINT, UFBOVR, UFBREP, UFBRP, UFBRW, UFBSEQ, UFBSP, -UFBSTP, UFBTAB, UFBTAM, UFDUMP, USRTPL, WRCMPS and WRTREE. This was present -in the original verification-specific version of the library. - -30) The following routines are modified to make the BUFR Archive Library -big-endian/little-endian independent: IPKM, IUPM, PKB, PKC, UPB and UPBB. This -was present in the original decoder-specific version of the library and -increases the portability of the BUFR Archive Library. - -31) Subroutine BFRINI modified to initialize variable JSR as ZERO in new -COMMON block /BUFRSR/. This was present in the original verification-specific -version of the library. (See also 29 for BFRINI.) - -32) Subroutine RCSTPL modified to increase the maximum number of levels of -recursion (parameter MAXRCR) from 50 to 100. This was present in the original -verification-specific version of the library. (See also 29 and 43 for RCSTPL.) - -33) Subroutine WRCMPS modified to save logical variables WRIT1 and FLUSH in -global memory. This fixed a bug in this subroutine which could lead to -messages being written out before being full. (See also 29 for WRCMPS.) - -34) Subroutine RDTREE modified to fix a bug which could only occur when the -last element in a subset is a character. (See also 29 for RDTREE.) - -35) Subroutine UFDUMP modified to handle print of character values greater -than 8 bytes. (See also 29 for UFDUMP.) - -36) Subroutine UFBEVN modified to save the maximum number of events found for -all data values specified amongst all levels returned as variable MAXEVN in -new COMMON block /UFBN3C/ and to add call to BORT if BUFR file is open for -output. (See also 29 for UFBEVN.) - -37) Subroutine NEMOCK modified to expand non-zero return into -1 for length -not 1-8 characters and -2 for invalid characters (return only -1 before for -all problematic cases) - -38) Subroutine NUMBCK modified to expand non-zero return into -1 for invalid -character in position 1, -2 for invalid characters in positions 2 through 6, --3 for invalid characters in positions 2 and 3 due to being out of range, and --4 for invalid characters in positions 4 through 6 due to being out of range -(return only -1 before for all probelmatic cases) - -39) Subroutine WTSTAT modified to correct a "typo" in test for valid value for -"IM". - -40) Subroutines ELEMDX, PARSEQ, PARUSR, PARUTG, PKC, RDUSDX, SEQSDX, STRING, -UFBINT, UFBOVR, UFBREP, UFBSTP and VALX modified to call new BUFR Archive -Library subroutine BORT2 (see 1). - -41) Subroutine MAKESTAB modified to allow for the possibility that a connected -file may not contain any dictionary table info (e.g., an empty file). -Subsequent connected files which are not empty will no longer get tripped up -by this. (This change avoids the need for an application program to -disconnect any empty files via a call to CLOSBF.) (See also 29 for MAKESTAB.) - -42) Subroutine READTJ modified to simply call BUFR Archive Library subroutine -READMG rather than being a clone of it. At one time it performed different -functions than READMG, but that has not been the case since the 2000-09-19 -BUFR Archive Library implementation. - -43) Subroutines CKTABA, CMSGINI, NUMTAB, PARUSR, PARUTG, RCSTPL, USRTPL, -WRDLEN, WRTREE and XMSGINI modified to correct some minor bugs (uninitialized -variables, etc.) (see subroutine DOCBLOCKS for more information). (See also -29 for PARUTG, RCSTPL, USRTPL, WRTREE and 32 for RCSTPL.) - -44) Subroutine UFBDMP modified to add "fuzziness" about 10E10 in test for a -missing value (rather than true equality as before) because some missing values -(e.g., character strings < 8 characters) were not getting stamped out as -"MISSING". Also added option to print values using format edit descriptor -"F15.6" if input argument LUNIN is < zero. If LUNIN is > zero edit descriptor -expanded from "G10.3" to "G15.6". (See also 29 for UFBDMP.) - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 18Z 21 December 2004 - (Blue/White only) - -1) New subroutines ISTDESC, RESTD, WRDESC, CADN30, STDMSG and STNDRD have been -added to provide the capability to expand Section 3 of output BUFR messages -until they are completely "standard" according to the WMO FM-94 regulations. -The logic is activated via an initial call to STDMSG. - -2) Subroutine XMSGINI has been removed. It had been included in a previous -BUFRLIB version as an indirect way of "standardizing" compressed messages, but -the same logic is now fully integrated into CMSGINI and is activated via a -separate initial call to new subroutine STDMSG (see 1). - -3) Subroutine STANDARD has been marked as obsolete (for future removal from -BUFRLIB) in favor of a new subroutine STNDRD which more completely -"standardizes" Section 3. The old subroutine (i.e. STANDARD) would always just -break down the top-level Table A descriptor by one level, so that, unless this -"one level deep" expansion happened to consist of all standard descriptors, the -resulting BUFR message was still non-standard. Contrarily, the new logic will -recursively break down successive sequence descriptors for as long as needed -until all appearing in Section 3 are themselves standard or else, at a -minimum, preceded with the 206YYY "bypass" operator (note: this recursive logic -is written using C for portability reasons, since not all FORTRAN 77 compilers -support recursion!). In addition, STNDRD has other advantages over STANDARD -as well; namely, it contains safety checks which prevent overflow of the -message array that is passed to it, and it also is more directly integrated -into BUFRLIB and can be automatically activated in-line via a separate initial -call to new subroutine STDMSG (see 1). - -4) Subroutine WRITSA was modified to fix a bug which, in certain situations, -prevented one or more BUFR messages from being returned to the calling program -within the memory arrays. In addition, a new subroutine WRITCA was added which -functions exactly like WRITSA except that it works on compressed messages. - -5) Subroutines WRCMPS and RDCMPS were modified to fix a bug in the compression -algorithm which occurred when all subsets in a single message contained -identical character strings. Separate corrections were also made to each of -these subroutines to fix a few unrelated minor bugs. - -6) Subroutine UFDUMP was modified to add a fuzziness test for the "missing" -value and to add an interactive, scrolling print capability similar to UFBDMP. - -7) Subroutine UFBDMP was modified to automatically use READLC when reading -"long" character strings, similar to an existing capability within UFDUMP. - -8) Documentation was improved and/or clarified in many existing subroutines -throughout BUFRLIB. - -9) Subroutines COMPRES and READ2C have been removed. The same functionality -can be obtained by using subroutine WRITCP. - -10) Subroutines IREADERS, READERS and READTJ have been removed, as they were -nothing more than wrappers for READMG and had been marked as obsolete within -a previous BUFRLIB version. - -11) Subroutines READERM, IREADERM and IRDERM have been removed. They had -been superseded functionally by (the more-portable!) subroutine READIBM and -had been marked as obsolete within a previous BUFRLIB version. - -12) Parameter MXMSGL (the maximum number of bytes in a BUFR message) was -increased from 20K TO 50K bytes in the following subroutines: BFRINI, CKTABA, -CLOSMG, CMSGINI, COPYBF, COPYMG, COPYSB, CPYMEM, CPYUPD, DXMINI, MAXOUT, -MESGBC, MESGBF, MINIMG, MSGINI, MSGUPD, MSGWRT, NMBYT, POSAPN, POSAPX, -RCSTPL, RDBFDX, RDCMPS, RDMEMM, RDMEMS, RDMGSB, RDTREE, READERME, READFT, -READIBM, READLC, READMG, READMM, READSB, REWNBF, SUBUPD, UFBGET, UFBINX, -UFBMEM, UFBTAB, UFBTAM, WRCMPS, WRITDX, WRITLC, WRITSA and WRTREE. (Note: -this is not included in the Docblock history in these routines.) - -13) Subroutines READERME, READIBM, DATEBF and DUMPBF were modified to make -the test for the string 'BUFR' portable to EBCDIC machines. - -14) Subroutine WRTREE was modified to use double-precision arithmetic within -an internal statement function, in order to correct for a truncation problem -that could occur in the case of very large computed values. - -15) Subroutine COPYST has been marked as obsolete (for future removal from -BUFRLIB). The same functionality can be obtained by calling new subroutine -STDMSG, followed by a call to COPYMG. - -16) Subroutine WRITST has been marked as obsolete (for future removal from -BUFRLIB). The same functionality can be obtained by calling new subroutine -STDMSG, followed by a call to CLOSMG. - -17) A new option IO="NODX" has been added to subroutine OPENBF. In this -case, the subroutine behaves exactly as if it had been called with IO="OUT", -except that DX dictionary messages are not written out to logical unit LUNIT. - -18) Subroutine WRDLEN was modified to keep track of whether it has already -been called by one of the other BUFRLIB subroutines and, if so, to then -immediately return (without proceeding any further) every time it is -subsequently called. - -19) Subroutines OPENBF, UFBINT, UFBOVR, UFBREP, UFBSEQ, UFBSTP and WRDLEN -were all modified to fix similar portability bugs whereby the values of some -internal variable(s) which keep track of whether the subroutine has already -been called were not being explicitly preserved with a SAVE statement. - -20) New subroutine PKVS1 was added which calls OVRBS1 in an in-line fashion -and therefore allows easier overwriting of default values in Section 1 of -output BUFR messages. The new methodology can also overwrite the value of -byte 8 in Section 0 (i.e. BUFR edition number) if desired. - -21) New function IUPVS1 was added which calls IUPBS1 in an in-line fashion -and therefore allows easy unpacking of Section 1 values from BUFR messages -that have already been read into the internal memory arrays by subroutine -READMG or equivalent. The new methodology can also unpack the value of -byte 8 in Section 0 (i.e. BUFR edition number) if desired. - -22) Subroutine ADDATE was modified to fix a bug in calculating the number of -days in February for years which are multiples of 100 but not of 400. - -23) Subroutine MESGBC was modified to allow the option of operating on a -BUFR message that has already been read into the internal memory arrays by -subroutine READMG or equivalent. - -24) New subroutine DXDUMP was added which outputs an ASCII-formatted copy of -the information embedded within the DX dictionary messages of a BUFR file. -It is especially useful for learning the contents of archived BUFR files, -and the output is in a format suitable for subsequent input to OPENBF as a -user-defined dictionary tables file. - -25) Subroutines DATELEN, DATEBF and DUMPBF were all modified to call -subroutine WRDLEN to initialize local machine information (in case it has -not already been called). These routines do not require this information -but they may now or someday call other routines that do require it. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 31 January 2006 - -1) Documentation was improved and/or clarified within many existing routines -throughout BUFRLIB. - -2) Global parameter MAXMEM (the maximum number of bytes that can be used to -store BUFR messages internally) was increased from 16Mb to 50Mb, and global -parameter MAXTBA (the maximum number of entries in the internal BUFR Table A) -was increased from 50 to 60. In addition, all global parameters were moved -into a new global INCLUDE file "bufrlib.PRM", rather than continuing to -hardcode the same parameter values in every individual source file where -they were needed. This will allow future changes to any of these parameter -values to be made much more easily. - -3) An additional CCS compilation of BUFRLIB (libbufr_s_64.a) is now being -maintained via the makefile. This new version is identical to the existing -libbufr_4_64.a compilation, except that several parameter values within -"bufrlib.PRM" are set much larger in order to allow extremely large BUFR -messages (i.e. up to 2.5Mb) to be processed. - -4) The capability to compress output BUFR messages has now been directly -incorporated into subroutines WRITSB and WRITSA, whereas previously it had -been necessary to instead call the separate subroutines WRITCP and WRITCA, -respectively. The use of compression can now be easily toggled on or off -(with "off" as the default if left unspecified) via new subroutine CMPMSG. -As such, subroutine WRITCA has now been marked as obsolete (for future removal -from BUFRLIB), since the same functionality can now be obtained by calling the -new subroutine CMPMSG, followed by a call to WRITSA. In a similar manner, -WRITCP has now been modified to directly call subroutines CMPMSG and WRITSB, -although it is being retained as a distinct subroutine within BUFRLIB (rather -than also being marked as obsolete) out of consideration for the large number -of existing application programs which use it. - -5) A new function IUPBS01 was added which works like existing function -IUPBS1, except that it uses a descriptive mnemonic rather than a hardcoded -byte number in order to specify the value to be unpacked from Section 0 or -Section 1 of a BUFR message. This allows the same function call to work on -messages encoded using either BUFR edition 3 or BUFR edition 4 (rather than -having to pass in different byte numbers depending on the edition!), and it -also allows values encoded across multiple bytes (e.g. section lengths, -4-digit years, etc.) to be easily unpacked as well. As such, the existing -function IUPBS1 has been marked as obsolete (for future removal from BUFRLIB), -and many other subroutines throughout BUFRLIB (e.g. UPDS3, DATEBF, DUMPBF, -STNDRD, CKTABA, NMBYT, MSGWRT, RDBFDX, etc.) have been modified to now use -the new function IUPBS01. In addition, a new function IUPVS01 was added which -calls IUPBS01 in an in-line fashion, and existing function IUPVS1 (which had -similarly called IUPBS1 in an in-line fashion) has now been marked as obsolete. - -6) A new subroutine PKVS01 was added which works like existing subroutine -PKVS1, except that it uses a descriptive mnemonic rather than a hardcoded -byte number in order to specify the value to be stored into Section 0 or -Section 1 of all future output BUFR messages. This allows the same -subroutine call to work on messages encoded using either BUFR edition 3 -or BUFR edition 4 (rather than having to pass in different byte numbers -depending on the edition!), and it also allows values encoded across multiple -bytes (e.g. 4-digit years, originating centers and subcenters, etc.) to be -easily overwritten as well. As such, the existing subroutine PKVS1 has been -marked as obsolete (for future removal from BUFRLIB). In a similar manner, -a new subroutine PKBS1 was also added to replace existing subroutine OVRBS1, -which has now itself also been marked as obsolete. - -7) A new subroutine CNVED4 was added which, given a BUFR message encoded using -BUFR edition 3, creates and outputs an equivalent message encoded using BUFR -edition 4. This subroutine can be called by an application program, or it can -alternatively be activated in an in-line fashion via a call to new subroutine -PKVS01 using the descriptive mnemonic "BEN" (i.e. BUFR edition number) with a -corresponding value of "4". - -8) Subroutines NEMTAB, NUMTAB, TABENT and TABSUB were modified to support -the Table C operators 2-07-YYY and 2-08-YYY, which are new to BUFR with the -advent of edition 4. - -9) Subroutines COPYST, WRITST and STANDARD, which had been marked as obsolete -within a previous version of BUFRLIB, have now been deleted. - -10) The default BUFR master table version number was changed from "4" to "12" -within subroutines CMSGINI, DXMINI and MSGINI. - -11) A bug was corrected in subroutine STNDRD in order to ensure that byte 4 of -Section 4 is always properly zeroed out. - -12) A bug was corrected in subroutine PARUTG which was preventing 1-bit delayed -replication factors from being directly read via a call to subroutine UFBINT. - -13) A bug was corrected in subroutine WRCMPS which was causing a character -compression array to be improperly initialized. In addition, a local parameter -was increased to allow up to 4000 subsets to be written into a single compressed -BUFR message. - -14) Subroutine UFBMEM was modified to not abort when there are either too many -messages read in or too many bytes read in (i.e., .gt. array limits passed in), -but rather to just process the limiting number of messages and/or bytes and -print a diagnostic. - -15) Subroutine CLOSMG was modified to override logic that had always written -out messages 1 and 2 even when they contained zero subsets (it assumed these -contained the dump center and processing time in Section 1). Now, if the unit -number argument is passed in as a negative number the first time this routine -is called by an application program, ALL empty messages are skipped (i.e., -assumes that messages 1 and 2 do not contain dump center and processing time). -This remains set for all subsequent calls to CLOSMG for a particular file, -regardless of the sign of the unit number (CLOSMG is called by other BUFRLIB -routines which always pass in a positive unit number). - -16) A new function IGETDATE was added which unpacks and returns the Section 1 -date-time from an input BUFR message, in format of either YYYYMMDDHH or YYMMDDHH -depending on the value requested via the most recent call to subroutine DATELEN. -The same logic had been repeated within numerous existing subroutines throughout -BUFRLIB and has now been consolidated into this single subroutine that can -itself be called from wherever it is needed. - -17) A new subroutine GETLENS was added which unpacks and returns the individual -section lengths from an input BUFR message. The same logic had been repeated -within numerous existing subroutines throughout BUFRLIB and has now been -consolidated into this single subroutine that can itself be called from -wherever it is needed. - -18) A new subroutine RDMSGW was added which reads the next padded BUFR message -from a given BUFR file. The same logic had been repeated within numerous -existing subroutines throughout BUFRLIB and has now been consolidated into -this single subroutine that can itself be called from wherever it is needed. - -19) A new function PKFTBV was added which computes and returns the value -equivalent to the setting of a specified bit within a flag table of a -specified width. In addition, a new subroutine UPFTBV was also added which -functions as the logical inverse, i.e. given a mnemonic and corresponding flag -table value, it computes and returns the equivalent bit settings. - -20) A new subroutine UFBPOS, which allows a user to directly point at and read -a specified subset from within a specified message in an input BUFR file, was -added to BUFRLIB. Previously, this logic existed as an in-line subroutine -within a separate application program. - -21) A new subroutine GETABDB, which returns internal BUFR table information -in a pre-defined ASCII format, was added to BUFRLIB. Previously, this logic -existed as an in-line subroutine within a separate application program. - -22) Subroutine READMG was modified to be able to handle BUFR messages which are -not padded out to an 8-byte boundary and for which it had therefore previously -been necessary to instead call the separate subroutine READIBM. Logic was also -added to allow the option of having READMG behave like the separate subroutine -READFT, so that it will not abort when a read error is encountered but rather -will treat it the same as an end-of-file condition. This option is activated -by passing in the negative of the usual logical unit number. In summary, READMG -can now itself properly read from any FORTRAN-blocked file of BUFR messages, and -therefore the existing subroutines READIBM, IREADIBM, READFT and IREADFT have -now all been marked as obsolete (for future removal from BUFRLIB). - -23) A set of generic C-language functions for reading/writing BUFR messages -from/to generic BUFR files (which may or may not contain FORTRAN-blocking and/or -message padding) was added to BUFRLIB. These functions (CCBFL, COBFL, CRBMG, -CWBMG and RBYTES) are primarily intended for use by separate application -programs (such as cwordsh), but are themselves being directly incorporated into -BUFRLIB in order to prevent such application programs from having to directly -link to certain COMMON blocks and parameter sizes internal to BUFRLIB. - -24) Function MOVA2I is marked as obsolete (for future removal from BUFRLIB). It -is present in the W3 Libraries (in C language) and is no longer called by any -BUFR Archive Library routines. A warning message is now printed instructing -users to migrate to MOVA2I in the W3 Libraries. - -25) Subroutine UFBTAB was modified to work for compressed BUFR messages. An -option to return only the subset count (when the input unit number is less than -zero) was also added. - -26) Subroutine COPYSB was modified to now write out a compressed subset/message -if the input subset/message is compressed (before this subroutine could only -write out an uncompressed subset/message regardless of the compression status -of the input subset/message). - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 06 February 2007 - -1) Several global parameters were increased in "bufrlib.PRM". Specifically, -MAXTBA, MAXTBB and MAXTBD (the maximum numbers of internal Table A, B and D -entries, respectively) were increased from 60, 250 and 250 to 120, 500 and 500, -respectively, and MAXJL (the maximum number of internal jump/link table -entries) was increased from 16000 to 20000. - -2) Subroutine CKTABA was modified to allow "FRtttsss" and "FNtttsss" (where ttt -is the message type and sss is the message subtype) as valid Table A mnemonics -for foreign BUFR messages. Previously, only "NCtttsss" had been allowed. - -3) Subroutines GETS1LOC and IUPBS01 were modified to provide two additional -options for unpacking values from Section 1 of a BUFR message. Specifically, -"CENT" now unpacks the century and "YCEN" now unpacks the year of the century. - -4) Subroutine PKBS1 was modified to provide several additional options for -directly packing values into Section 1 of a BUFR message. Specifically, -"YEAR", "MNTH", "DAYS", "HOUR", "CENT" and "YCEN" now pack the message year, -month, day, hour, century and year of century, respectively, and "MTYP" and -"MSBT" now pack the message type and subtype, respectively. - -5) Subroutine MAXOUT was modified to allow it to be called with a special flag -value of "0", indicating that output BUFR messages should be set to the maximum -allowable record length. In addition, a sanity check was added to prevent this -record length from being set to a value greater than the maximum allowable. - -6) For the printing of flag table values, subroutines UFBDMP and UFDUMP were -modified to include an equivalent listing of the bits that were actually set. - -7) Subroutine UFBPOS was modified to remove an unnecessary (and incorrect!) -initialization statement. This had been silently ignored by the IBM CCS -compiler but was a portability issue for other compilers. - -8) Subroutine UFBTAB was modified to add a required declaration for a local -character variable. This had been silently ignored by the IBM CCS compiler -but was a portability issue for other compilers. - -9) Subroutine RDUSDX was modified to abort if it encounters a user-defined -BUFR message whose message type is set to 11. This value is reserved for -internal dictionary messages. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, 28 May 2008 - -1) Subroutine BORT_EXIT was modified to fix a faulty ANSI-C declaration. -This had been silently ignored by the IBM CCS compiler but was a portability -issue for other compilers. - -2) Subroutines RDTREE and WRTREE were modified to fix a bug which, on rare -occasions, caused a segmentation fault due to overflow of internal arrays. -This bug only occurred when working with long character strings (i.e. longer -than 8 bytes) while using a non-optimized compilation of BUFRLIB. - -3) Subroutine WRITCA, which had been marked as obsolete within a previous -version of BUFRLIB, has now been deleted. - -4) A new subroutine PARSTR was added which works like existing subroutine -PARSEQ, except that it allows substrings within a string to be separated by -one or more occurrences of any given single character (and not just by one -or more blank characters). As such, the existing subroutine PARSEQ has -been marked as obsolete (for future removal from BUFRLIB), and many other -subroutines throughout BUFRLIB have been modified to now use the new -subroutine PARSTR. - -5) Subroutine JSTCHR was modified to add a return argument indicating -whether the input string was empty. This allows the subroutine to be used -in any context where existing subroutine LJUST was being used, and LJUST -has now been marked as obsolete (for future removal from BUFRLIB). - -6) Several new subroutines have been added to enable the capability to read -BUFR table information from external ASCII master tables instead of from -pre-defined DX dictionary files. This is in preparation for the planned -future capability to be able to directly decode a BUFR message according to -its internal data description section. - -7) The value BMISS (i.e. the BUFR "missing" value), which was defined as a -local data value within many separate subroutines, has now been defined as a -global parameter within the "bufrlib.PRM" include file. In addition, a new -function IBFMS has been added which safely tests a given value to determine -whether or not it is "missing", and several existing subroutines throughout -BUFRLIB have been modified to now use this new function. - -8) The determination as to whether the local host machine uses the -"big-endian" or "little-endian" byte-ordering scheme is now determined at -compile time and integrated into BUFRLIB via the use of conditional -compilation statements. This allows BUFRLIB to run much more efficiently -since it no longer has to constantly re-check the local byte-ordering -scheme at run time. - -9) Subroutine DXDUMP was modified to correct a bug which caused the -truncation of output reference values longer than 8 digits. - -10) Several global parameters were increased in "bufrlib.PRM". -Specifically, MXCDV (the maximum number of data values per subset in a -compressed BUFR message) was increased from 2000 to 3000, and MAXMEM (the -maximum number of bytes that can be used to store BUFR messages within -internal memory) was increased from 50Mb to 75Mb within the "supersized" -BUFRLIB. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.0.0 - -1) Subroutines PKVS1, OVRBS1, NMBYT, READIBM, IREADIBM, READFT, IREADFT and -MOVA2I, which had been marked as obsolete within a previous version of -BUFRLIB, have now been deleted. - -2) A new global parameter MAXSS was defined for use as the maximum number of -data values that can be read from or written into a single data subset by the -BUFRLIB software. Previously, the separate global parameter MAXJL was used -to define this limit. MAXJL will now be used solely to define the maximum -number of internal jump/link table entries. - -3) The size of a string declaration was increased within subroutine RDUSDX. - -4) Subroutine READLC was modified to enable the extraction of "long" (i.e. -greater than 8 bytes) character strings from compressed messages. In -addition, it is now possible to access all occurrences of such a string -from within a given data subset, via the use of the new mnemonic condition -character '#'. Previously, READLC could only ever access the first -occurrence of any "long" character string from within a data subset. - -5) Subroutine WRITLC was modified to allow the writing of "long" (i.e. -greater than 8 bytes) character strings within compressed messages. In -addition, it is now possible to write all occurrences of such a string into -a given data subset, via the use of the new mnemonic condition character '#'. -Previously, WRITLC could only ever locate and write the first occurrence of -any "long" character string within a data subset. - -6) Subroutine UFDUMP was modified to label each output level for sequences -where the replication count is greater than 1. In addition, it will now -output all occurrences of "long" (i.e. greater than 8 bytes) character -strings from within a given data subset. - -7) Subroutine RDCMPS was modified to fix a bug which could cause the overflow -of internal arrays when working with long character strings (i.e. longer -than 8 bytes). - -8) Subroutine NVNWIN was modified to fix a bug which could cause the overflow -of an internal array during initialization on certain operating systems. - -9) A new subroutine BVERS was added as a resource for managing and reporting -library version numbers. - -10) The fuzziness threshold in function IBFMS was increased for improved -accuracy when testing for the BUFRLIB "missing" value. - -11) A new subroutine IUPBS3 was added which unpacks specified values from -Section 3, including subset counts and compression indicators. The same -logic had been repeated within numerous existing subroutines throughout -BUFRLIB and has now been consolidated into this single subroutine that can -itself be called from wherever it is needed. - -12) Subroutines READERME, RDMSGW and RDMSGB were modified to prevent the -overflow of an internal array for extremely large BUFR messages. - -13) Subroutine UPDS3 was modified to pass in a new input argument containing -the dimensioned size of the output array, in order to prevent the subroutine -from possibly overflowing the array. - -14) Subroutine WRITSA was modified to pass in a new input argument containing -the dimensioned size of the output array, in order to prevent the subroutine -from possibly overflowing the array. - -15) A new capability was added to BUFRLIB to enable the decoding of a BUFR -message according to its data description section (Section 3). This is -activated by setting IO="SEC3" when opening the file via subroutine OPENBF. -Master tables containing all possible BUFR descriptors are also required, and -these may be specified via a call to new subroutine MTINFO or by using default -values specified within subroutine BFRINI. If the default values are used, -then FORTRAN logical unit numbers 98 and 99 will be allocated by the BUFRLIB -for opening and reading the master tables. This new capability allows BUFR -messages to be decoded without pre-defined DX dictionary files. - -16) Subroutine READMM was re-written to directly call subroutine RDMEMM -instead of duplicating all of the code logic in RDMEMM. - -17) Subroutine UPB was re-written to directly call subroutine UPBB instead of -duplicating all of the code logic in UPBB. - -18) Subroutine POSAPN has been marked as obsolete (for future removal from -BUFRLIB). The same functionality can now be obtained via the use of -subroutine POSAPX. - -19) Subroutine WRCMPS was modified to fix a bug involving the writing of -compressed subsets which contain delayed replication. In certain situations, -the values of two internal variables were not being properly saved between -successive calls to the subroutine. - -20) Changes were made so that the BUFRLIB will automatically read and adjust -to any DX table (dictionary) messages internal to a file. Previously, the -software would only ever process such messages at the beginning of a file, -so that all subsequent data messages in that file were required to conform -to these initial dictionary messages, and any subsequent dictionary messages -in the file were simply ignored. Now, any subsequent dictionary messages -will cause the BUFRLIB to adjust its internal processing tables and treat all -subsequent data messages as conforming to these new dictionary messages, up -through the end of the file or until yet another set of dictionary messages -is encountered. These changes affect all BUFRLIB subroutines which read BUFR -messages from a file, including READMG, IREADMG, READMM, IREADMM, RDMEMM, -READNS and IREADNS. - -21) Subroutine ADDATE has been marked as obsolete (for future removal from -BUFRLIB) since it is no longer called by any BUFRLIB routines. The same -functionality can now be obtained via the use of subroutine W3MOVDAT in the -NCEP W3 library. - -22) Subroutine SUBUPD has been marked as obsolete (for future removal from -BUFRLIB) since it is no longer called by any BUFRLIB routines and is almost -an exact replica of subroutine MSGUPD. The same functionality can now be -obtained via the use of subroutine MSGUPD. - -23) A new logical function MSGFULL was added which determines whether there is -enough room to store the current data subset within the current BUFR message -for output. The same logic had been repeated within numerous existing -subroutines throughout BUFRLIB and has now been consolidated into this single -subroutine that can itself be called from wherever it is needed. - -24) A new capability was added to BUFRLIB to allow it to append a tank receipt -time to Section 1 within all future BUFR messages written to output by -subroutines WRITSB, COPYMG or equivalent. The tank receipt time is a local -extension to Section 1; however, its inclusion in a message is still fully -compliant with the WMO BUFR regulations. This new capability is activated via -an initial call to new subroutine STRCPT, specifying the time to be appended -to Section 1 within all future BUFR messages written to output. This same -information can then be read back from an input BUFR message via a call to new -subroutine RTRCPT. - -25) Subroutine NUMTAB was re-written to directly call subroutine NUMTBD -instead of duplicating all of the code logic in NUMTBD. - -26) Subroutine NEMTBA was re-written to directly call subroutine NEMTBAX -instead of duplicating all of the code logic in NEMTBAX. - -27) Documentation was improved within numerous subroutines throughout BUFRLIB, -including the addition of docblocks where none previously existed. - -28) The default BUFR master table version number was changed from "12" to "13" -within subroutines CMSGINI, DXMINI and MSGINI. - -29) A new capability was added to allow BUFRLIB print diagnostics and other -runtime messages to be redirected somewhere other than the default FORTRAN -logical unit #6 (i.e. standard output). This is enabled within an application -program by supplying an in-line version of subroutine ERRWRT to override the -new default version of this subroutine provided within the BUFRLIB. The -default version will continue to write to standard output when included within -a compilation. - -30) Subroutines CMSGINI, STNDRD and MSGWRT were modified to remove a logical -error which assumed that any message whose data section (Section 4) was -compressed was also fully standard. In reality, the use of compression only -implies that the data section is fully standard and does not necessarily imply -that the data description section (Section 3) is also fully standard. BUFRLIB -will now address the standardization of Section 3 solely within subroutine -STNDRD, independent of whether or not the data in Section 4 are compressed. - -31) Functions LSTRPC and LSTRPS have been marked as obsolete (for future removal -from BUFRLIB). The same functionality can now be obtained via the use of -function LSTJPB. - -32) Subroutine UFBTAB was modified to fix a bug involving the unpacking of -character strings which are identical within each subset of a single -compressed BUFR message. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.0.1 - -1) Subroutine REWNBF was modified to fix a bug which skipped the first data -message after a file rewind. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.1.0 - -1) Subroutine UFDUMP was modified to fix a bug when checking for the "missing" -value in long character strings (i.e. longer than 8 bytes). - -2) A new subroutine UFBMEX was added for use with certain application -programs. UFBMEX functions similarly to UFBMEM, but has an additional return -argument containing an array of message types corresponding to the array of -messages that were read into internal memory. - -3) Subroutines ADDATE, IUPBS1, IUPVS1, LJUST, LSTRPC, LSTRPS, SUBUPD, POSAPN -and PARSEQ, which had been marked as obsolete within a previous version of -BUFRLIB, have now been deleted. - -4) Several global parameters were increased in "bufrlib.PRM". -Specifically, MAXTBA (the maximum number of Table A entries for a BUFR file) -was increased from 120 to 150, and MXDXTS (the maximum number of dictionary -tables that can be stored for use with BUFR messages in internal memory) was -increased from 10 to 200. - -5) Subroutine CONWIN was modified to fix a bug and remove an obsolete call -argument. - -6) Subroutine WRCMPS was modified to fix a bug involving embedded tables -within a file of compressed BUFR messages. - -7) Documentation was improved in many subroutines throughout the library. - -8) Support has been added for the 2-03-YYY "change reference values" operator. - -9) Subroutine USRTPL was modified to fix a bug that was incorrectly using -parameter MAXJL instead of parameter MAXSS when checking for overflow of an -internal template array. - -10) Subroutine WRDXTB was modified to prevent it from trying to store more -than 255 Table A, Table B or Table D descriptors in a single DX dictionary -message. The maximum value was set to 255 since regular 8-bit delayed -replication is used to store descriptor information in these messages. - -11) Subroutine TABSUB was modified to correctly generate the jump/link table -for subsets where a Table C operator immediately follows a Table D sequence. - - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.2.0 - -1) The makebufrlib.sh script was modified to streamline the endianness check -and make it more portable. - -2) Subroutine WRTREE was modified to ensure that "missing" character strings -are properly encoded with all bits set to 1. - -3) A new function ICBFMS was added which tests whether decoded character -strings are "missing" by checking if all of the equivalent bits are set to 1. -This was done because, on certain platforms, the BUFRLIB REAL*8 "missing" value -BMISS is not always equivalent to all bits set to 1 when viewed as a character -string, and thus the existing BUFRLIB function IBFMS did not always work -properly in such cases. However, users can continue to use the existing IBFMS -function in application programs, because the new ICBFMS function has now been -incorporated internally within the logic of many BUFRLIB subroutines, in -addition to also being available for direct calling by application programs. - -4) Subroutines READMG and READERME were modified to prevent the BUFRLIB from -internally adjusting to DX (dictionary) table messages when Section 3 decoding -is being used. Otherwise, contention can occur between the table information -in the DX messages and the table information specified within the Section 3 -descriptors. From now on, whenever Section 3 decoding is used (as specified -by setting IO="SEC3" when opening a file via OPENBF), the BUFRLIB will now -treat any DX (dictionary) table message the same as any other message and -decode the actual data (i.e. table) values according to Section 3. - -5) Subroutine OPENBF was modified to allow a new option for input call -argument IO. If this argument is set to 'INUL', then the BUFRLIB will behave -the same as when IO='IN', except that it will never try to actually read -anything from the file attached to input call argument LUNIT. This can be -useful for some special cases, such as when the user plans to pass input -messages to the BUFRLIB using subsequent calls to subroutine READERME. - -6) A new subroutine GETTAGPR was added which returns the mnemonic corresponding -to a parent sequence in a subset definition, given the mnemonic corresponding -to a child descriptor within that sequence. This can be useful in certain -application codes, especially when Section 3 decoding is being used. - -7) A new function GETVALNB was added which searches for a specified mnemonic -in a subset definition, then searches forward or backward from that point for -a different mnemonic and returns the associated value. This can be useful in -certain application codes, especially when Section 3 decoding is being used. - -8) Functionality was added to improve the portability of reading and writing -BUFR messages across different platforms. All calls to existing FORTRAN -subroutines which read or write BUFR messages from disk (e.g. READMG, UFBMEM, -UFBTAB, WRITSB, WRCMPS, COPYMG, etc.) now use embedded C-language I/O to -perform these tasks. Among other things, this means that any BUFR file can -now be read regardless of whether it has been pre-blocked with FORTRAN -control words using the cwordsh utility. For writing BUFR files, a new -subroutine SETBLOCK was added which allows users to specify whether output -BUFR messages are to be unblocked (which is the new default), big-endian -blocked, or little-endian blocked. - -9) A new subroutine SETBMISS was added which allows users to specify a custom -"missing" value for writing to and reading from BUFR files, rather than using -the BUFRLIB default "missing" value of 10E10. A corresponding function -GETBMISS was also added which returns the current "missing" value in use. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.2.1 - -1) A bug was fixed in the embedded C-language I/O to account for the -difference in index numbering between Fortran and C arrays. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.2.2 - -1) Subroutine OPENBF was modified to fix a bug which caused a segfault in -certain cases when appending to a BUFR file using the embedded C-language I/O. - -2) Subroutines READLC and WRITLC were modified to allow the input mnemonic -string to be up to 14 characters when it contains a '#' condition code. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.2.3 - -1) Subroutine RDUSDX was modified to prevent a segfault when trying to read -DX dictionary information from an empty file. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.2.4 - -1) Configuration files bufrlib.PRM and makebufrlib.sh were updated to -generate a 4_32 build (4-byte REAL, 4-byte INT, 32-bit compilation) on -the IBM CCS for version 10.2.3 of the BUFRLIB. - -############################################################################## -############################################################################## -############################################################################## - - Changes to BUFR Archive Library, Version 10.2.5 - -1) Subroutine MESGBF was modified to ensure that the input BUFR file is -always closed before exiting the subroutine. - -2) Function COBFL was modified to allow up to 500 characters in the path of -the filename being opened. - -3) A declaration typo was fixed in subroutine BLOCKS. - -4) Global parameter MAXNC (the maximum number of FXY descriptors that can be -written into Section 3 of a BUFR message) was increased from 300 to 600. diff --git a/src/bufr/adn30.f b/src/bufr/adn30.f deleted file mode 100644 index c7306f7b8d..0000000000 --- a/src/bufr/adn30.f +++ /dev/null @@ -1,85 +0,0 @@ - FUNCTION ADN30(IDN,L30) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ADN30 -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CONVERTS A DESCRIPTOR FROM ITS BIT-WISE -C (INTEGER) REPRESENTATION TO ITS FIVE OR SIX CHARACTER ASCII -C REPRESENTATION. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: ADN30 (IDN, L30) -C INPUT ARGUMENT LIST: -C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) -C VALUE -C L30 - INTEGER: LENGTH OF ADN30 (NUMBER OF CHARACTERS, 5 OR -C 6) -C -C OUTPUT ARGUMENT LIST: -C ADN30 - CHARACTER*(*): CHARACTER FORM OF DESCRIPTOR (FXY -C VALUE) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: CADN30 DXINIT ISTDESC NEMTBD -C NUMTAB RDMTBB RDMTBD READS3 -C SEQSDX SNTBDE UFBQCD UPDS3 -C WRDXTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*(*) ADN30 - CHARACTER*128 BORT_STR - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(LEN(ADN30).LT.L30 ) GOTO 900 - IF(IDN.LT.0 .OR. IDN.GT.65535) GOTO 901 - IF(L30.EQ.5) THEN - WRITE(ADN30,'(I5)') IDN - ELSEIF(L30.EQ.6) THEN - IDF = ISHFT(IDN,-14) - IDX = ISHFT(ISHFT(IDN,NBITW-14),-(NBITW-6)) - IDY = ISHFT(ISHFT(IDN,NBITW- 8),-(NBITW-8)) - WRITE(ADN30,'(I1,I2,I3)') IDF,IDX,IDY - ELSE - GOTO 902 - ENDIF - - DO I=1,L30 - IF(ADN30(I:I).EQ.' ') ADN30(I:I) = '0' - ENDDO - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: ADN30 - FUNCTION RETURN STRING TOO SHORT') -901 CALL BORT('BUFRLIB: ADN30 - INTEGER REPRESENTATION OF '// - . 'DESCRIPTOR OUT OF 16-BIT RANGE') -902 WRITE(BORT_STR,'("BUFRLIB: ADN30 - CHARACTER LENGTH (",I4,") '// - . 'MUST BE EITHER 5 OR 6")') L30 - CALL BORT(BORT_STR) - END diff --git a/src/bufr/atrcpt.f b/src/bufr/atrcpt.f deleted file mode 100644 index d59809c691..0000000000 --- a/src/bufr/atrcpt.f +++ /dev/null @@ -1,104 +0,0 @@ - SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ATRCPT -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE, APPENDS THE -C TANK RECEIPT TIME TO SECTION 1, AND WRITES THE RESULT TO A NEW BUFR -C MESSAGE FOR OUTPUT. THE TANK RECEIPT TIME MUST HAVE BEEN SPECIFIED -C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE STRCPT. THE -C OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE INPUT MESSAGE, SO -C THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL ATRCPT (MSGIN, LMSGOT, MSGOT) -C INPUT ARGUMENT LIST: -C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE -C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; -C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT -C OVERFLOW THE MSGOT ARRAY -C -C OUTPUT ARGUMENT LIST: -C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE -C WITH TANK RECEIPT TIME APPENDED TO SECTION 1 -C -C REMARKS: -C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. -C -C THIS ROUTINE CALLS: BORT GETLENS IUPBS01 MVB -C PKB -C THIS ROUTINE IS CALLED BY: MSGWRT -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MSGIN(*), MSGOT(*) - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT - - CHARACTER*1 CTRT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Get some section lengths and addresses from the input message. - - CALL GETLENS(MSGIN,1,LEN0,LEN1,L2,L3,L4,L5) - - IAD1 = LEN0 - IAD2 = IAD1 + LEN1 - - LENM = IUPBS01(MSGIN,'LENM') - -C Check for overflow of the output array. Note that the new -C message will be 6 bytes longer than the input message. - - LENMOT = LENM + 6 - IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 - - LEN1OT = LEN1 + 6 - -C Write Section 0 of the new message into the output array. - - CALL MVB ( MSGIN, 1, MSGOT, 1, 4 ) - IBIT = 32 - CALL PKB ( LENMOT, 24, MSGOT, IBIT ) - CALL MVB ( MSGIN, 8, MSGOT, 8, 1 ) - -C Store the length of the new Section 1. - - IBIT = IAD1*8 - CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) - -C Copy the remainder of Section 1 from the input array to the -C output array. - - CALL MVB ( MSGIN, IAD1+4, MSGOT, (IBIT/8)+1, LEN1-3 ) - -C Append the tank receipt time data to the new Section 1. - - IBIT = IAD2*8 - CALL PKB ( ITRYR, 16, MSGOT, IBIT ) - CALL PKB ( ITRMO, 8, MSGOT, IBIT ) - CALL PKB ( ITRDY, 8, MSGOT, IBIT ) - CALL PKB ( ITRHR, 8, MSGOT, IBIT ) - CALL PKB ( ITRMI, 8, MSGOT, IBIT ) - -C Copy Sections 2, 3, 4 and 5 from the input array to the -C output array. - - CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LENM-IAD2 ) - - RETURN -900 CALL BORT('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE '// - . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END diff --git a/src/bufr/bfrini.f b/src/bufr/bfrini.f deleted file mode 100644 index f9b4b0804e..0000000000 --- a/src/bufr/bfrini.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE BFRINI - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BFRINI -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE IS CALLED ONLY ONE TIME (DURING THE FIRST -C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF) IN ORDER TO -C INITIALIZE SOME GLOBAL VARIABLES AND ARRAYS WITHIN SEVERAL COMMON -C BLOCKS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- MODIFIED TO MAKE Y2K COMPLIANT -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); INITIALIZES -C VARIABLE JSR AS ZERO IN NEW COMMON BLOCK -C /BUFRSR/ (WAS IN VERIFICATION VERSION); -C UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2004-08-18 J. ATOR -- ADDED INITIALIZATION OF COMMON /MSGSTD/; -C MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- ADDED INITIALIZATION OF COMMON /MSGCMP/ -C AND CALLS TO PKVS1 AND PKVS01 -C 2009-03-23 J. ATOR -- ADDED INITIALIZATION OF COMMON /DSCACH/, -C COMMON /MSTINF/ AND COMMON /TNKRCP/ -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE -C -- ADDED INITIALIZATION OF COMMON BLOCKS -C -- /ENDORD/ AND /BUFRBMISS/ -C -C USAGE: CALL BFRINI -C -C REMARKS: -C THIS ROUTINE CALLS: IFXY IPKM PKVS01 -C THIS ROUTINE IS CALLED BY: OPENBF -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS - COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 - COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) - COMMON /STBFR / IOLUN(NFILES),IOMSG(NFILES) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM), - . IDCACH(MXCNEM,MAXNC) - COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) - COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT - COMMON /DATELN/ LENDAT - COMMON /ACMODE/ IAC - COMMON /BUFRSR/ JUNN,JILL,JIMM,JBIT,JBYT,JMSG,JSUB,KSUB,JNOD,JDAT, - . JSR(NFILES),JBAY(MXMSGLD4) - COMMON /MSGSTD/ CSMF - COMMON /MSGCMP/ CCMF - COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT - COMMON /MSTINF/ LUN1,LUN2,LMTD,MTDIR - COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) - - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*100 MTDIR - CHARACTER*56 DXSTR - CHARACTER*10 TAG - CHARACTER*8 CNEM - CHARACTER*6 ADSN(5,2),DNDX(25,10) - CHARACTER*3 TYPX(5,2),TYPS,TYP - CHARACTER*1 REPX(5,2),REPS - CHARACTER*1 CSMF - CHARACTER*1 CCMF - CHARACTER*1 CTRT - DIMENSION NDNDX(10),NLDXA(10),NLDXB(10),NLDXD(10),NLD30(10) - DIMENSION LENX(5) - - DATA ADSN / '101000','360001','360002','360003','360004' , - . '101255','031002','031001','031001','031000' / - DATA TYPX / 'REP', 'DRP', 'DRP', 'DRS' , 'DRB' , - . 'SEQ', 'RPC', 'RPC', 'RPS' , 'SEQ' / - DATA REPX / '"', '(', '{', '[' , '<' , - . '"', ')', '}', ']' , '>' / - DATA LENX / 0 , 16 , 8 , 8 , 1 / - - DATA (DNDX(I,1),I=1,25)/ - .'102000','031001','000001','000002', - .'110000','031001','000010','000011','000012','000013','000015', - . '000016','000017','000018','000019','000020', - .'107000','031001','000010','000011','000012','000013','101000', - . '031001','000030'/ - - DATA (DNDX(I,2),I=1,15)/ - .'103000','031001','000001','000002','000003', - .'101000','031001','300004', - .'105000','031001','300003','205064','101000','031001','000030'/ - - DATA NDNDX / 25 , 15 , 8*0 / - DATA NLDXA / 35 , 67 , 8*0 / - DATA NLDXB / 80 , 112 , 8*0 / - DATA NLDXD / 38 , 70 , 8*0 / - DATA NLD30 / 5 , 6 , 8*0 / - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C INITIALIZE /ENDORD/ TO CONTROL OUTPUT BLOCKING -1=LE 0=NONE +1=BE -C ----------------------------------------------------------------- - - IBLOCK = 0 - -C INITIALIZE /BUFRBMISS/ -C ---------------------- - - BMISS = 10E10 - -C INITIALIZE /BITBUF/ -C ------------------- - - MAXBYT = 10000 - -C INITIALIZE /MAXCMP/ -C ------------------- - - MAXCMB = MAXBYT - MAXROW = 0 - MAXCOL = 0 - NCMSGS = 0 - NCSUBS = 0 - NCBYTS = 0 - -C INITIALIZE /PADESC/ -C ------------------- - - IBCT = IFXY('063000') - IPD1 = IFXY('102000') - IPD2 = IFXY('031001') - IPD3 = IFXY('206001') - IPD4 = IFXY('063255') - -C INITIALIZE /STBFR/ -C ------------------ - - DO I=1,NFILES - IOLUN(I) = 0 - IOMSG(I) = 0 - ENDDO - -C INITIALIZE /REPTAB/ -C ------------------- - - DO I=1,5 - LENS(I) = LENX(I) - DO J=1,2 - IDNR(I,J) = IFXY(ADSN(I,J)) - TYPS(I,J) = TYPX(I,J) - REPS(I,J) = REPX(I,J) - ENDDO - ENDDO - -C INITIALIZE /TABABD/ (INTERNAL ARRAYS HOLDING DICTIONARY TABLE) -C -------------------------------------------------------------- - -C NTBA(0) is the maximum number of entries w/i internal BUFR table A - - NTBA(0) = MAXTBA - -C NTBB(0) is the maximum number of entries w/i internal BUFR Table B - - NTBB(0) = MAXTBB - -C NTBD(0) is the maximum number of entries w/i internal BUFR Table D - - NTBD(0) = MAXTBD - -C INITIALIZE /DXTAB/ -C ------------------ - - MAXDX = MAXBYT -c .... IDXV is the version number of the local tables - IDXV = 1 - - DO J=1,10 - LDXA(J) = NLDXA(J) - LDXB(J) = NLDXB(J) - LDXD(J) = NLDXD(J) - LD30(J) = NLD30(J) - DXSTR(J) = ' ' - NXSTR(J) = NDNDX(J)*2 - DO I=1,NDNDX(J) - I1 = I*2-1 - CALL IPKM(DXSTR(J)(I1:I1),2,IFXY(DNDX(I,J))) - ENDDO - ENDDO - -C INITIALIZE /TABLES/ -C ------------------- - - MAXTAB = MAXJL - -C INITIALIZE /BUFRMG/ -C ------------------- - - MSGLEN = 0 - -C INITIALIZE /MRGCOM/ -C ------------------- - - NRPL = 0 - NMRG = 0 - NAMB = 0 - NTOT = 0 - -C INITIALIZE /DATELN/ -C ------------------- - - IF(LENDAT.NE.10) LENDAT = 8 - -C INITIALIZE /ACMODE/ -C ------------------_ - -c .... DK: What does this control?? - IAC = 0 - -C INITIALIZE /BUFRSR/ -C ------------------- - - DO I=1,NFILES - JSR(I) = 0 - ENDDO - -C INITIALIZE /DSCACH/ -C ------------------- - - NCNEM = 0 - -C INITIALIZE /MSGSTD/ -C ------------------- - - CSMF = 'N' - -C INITIALIZE /MSGCMP/ -C ------------------- - - CCMF = 'N' - -C INITIALIZE /TNKRCP/ -C ------------------- - - CTRT = 'N' - -C INITIALIZE /MSTINF/ -C ------------------- - - MTDIR = '/nwprod/fix' - LMTD = 11 - - LUN1 = 98 - LUN2 = 99 - -C INITIALIZE /S01CM/ -C ------------------- - - CALL PKVS01('INIT',-99) - - RETURN - END diff --git a/src/bufr/blocks.f b/src/bufr/blocks.f deleted file mode 100644 index c602d14d3f..0000000000 --- a/src/bufr/blocks.f +++ /dev/null @@ -1,117 +0,0 @@ - SUBROUTINE BLOCKS(MBAY,MWRD) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BLOCKS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 -C -C ABSTRACT: BLOCKS WILL ADD IEEE FORTRAN TYPE RECORD CONTROL -C WORDS TO A PURE BUFR RECORD PASSED FROM MSGWRT, IN -C PREPARATION FOR OUTPUTING THE RECORD TO DISK. THE -C DEFAULT OUTPUT TYPE IS PURE (NO CONTROL WORDS), IN -C WHICH CASE THIS ROUTINE DOES NOTHING. AN APPLICATION -C CAN SPECIFY THAT EITHER BIG OR LITTLE ENDIAN RECORD -C CONTROL WORDS ARE TO BE APPENDED TO PURE BUFR RECORDS -C VIA A PREVIOUS CALL TO SUBROUTINE SETBLOCK. -C -C THE FOLLOWING DIAGRAM ILLUSTRATES IEEE CONTROL WORDS FOUND -C IN AN UNFORMATTED FORTRAN RECORD CONRTAINING FOUR 4-BYTE WORDS -C -C ctw1-wrd1-wrd2-wrd3-wrd4-ctw2 -C | | | | | | -C 0016-aaaa-bbbb-cccc-dddd-0016 -C -C CTW1 AND CTW2 CONTAIN A BYTE COUNT FOR THE DATA RECORD THAT -C THEY ENCLOSE. THEY CAN BE STORED IN EITHER BIG OR LITTLE -C ENDIAN BYTE ORDERING (NOTE: CTWS ARE ALWAYS 4-BYTE WORDS) -C -C PROGRAM HISTORY LOG: -C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR -C -C USAGE: CALL BLOCKS(MBAY,MWRD) -C INPUT ARGUMENTS: -c MBAY - INTEGER ARRAY CONTAINING PURE BUFR MESSAGE -c MWRD - INTEGER WORD COUNT FOR MBAY -C -C OUTPUT ARGUMENTS: -c MBAY - INTEGER ARRAY CONTAINING INPUT BUFR MESSAGE, POSSIBLY -c WITH CONTROL WORDS ADDED DEPENDING ON WHETHER SUBROUTINE -c SETBLOCK WAS PREVIOUSLY CALLED -c MWRD - INTEGER WORD COUNT FOR MBAY -C -C REMARKS: -C THIS ROUTINE CALLS: None -C -C THIS ROUTINE IS CALLED BY: MSGWRT -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) - - INTEGER*4 MBAY(MWRD),IINT,JINT - - CHARACTER*1 CINT(4),DINT(4) - EQUIVALENCE(CINT,IINT) - EQUIVALENCE(DINT,JINT) - - DATA IFIRST/0/ - SAVE IFIRST - -c---------------------------------------------------------------------- -c---------------------------------------------------------------------- - - if(iblock.eq.0) return - - if(ifirst.eq.0) then - -c Initialize some arrays for later use. Note that Fortran -c record control words are always 4 bytes. - - iint=0; cint(1)=char(1) - do i=1,4 - if(cint(1).eq.char(01)) then - iordbe(i)=4-i+1 - iordle(i)=i - else - iordle(i)=4-i+1 - iordbe(i)=i - endif - enddo - ifirst=1 - endif - -c make room in mbay for control words - one at each end of the record -c ------------------------------------------------------------------- - - if(nbytw.eq.8) mwrd=mwrd*2 - - do m=mwrd,1,-1 - mbay(m+1) = mbay(m) - enddo - -c store the endianized control word in bytes in dint/jint -c ------------------------------------------------------- - - iint=mwrd*4 - - do i=1,4 - if(iblock.eq.+1) dint(i)=cint(iordbe(i)) - if(iblock.eq.-1) dint(i)=cint(iordle(i)) - enddo - -c increment mrwd and install the control words in their proper places -c ------------------------------------------------------------------- - - mwrd = mwrd+2 - mbay(1) = jint - mbay(mwrd) = jint - - if(nbytw.eq.8) mwrd=mwrd/2 - - return - end diff --git a/src/bufr/bort.f b/src/bufr/bort.f deleted file mode 100644 index e1a0554002..0000000000 --- a/src/bufr/bort.f +++ /dev/null @@ -1,88 +0,0 @@ - SUBROUTINE BORT(STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BORT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 -C -C ABSTRACT: THIS SUBROUTINE WRITES (VIA BUFR ARCHIVE LIBRARY SUBROUTINE -C ERRWRT) A GIVEN ERROR STRING AND THEN CALLS BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT_EXIT TO ABORT THE APPLICATION PROGRAM CALLING THE -C BUFR ARCHIVE LIBRARY SOFTWARE. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT2, EXCEPT BORT2 WRITES TWO ERROR STRINGS. -C -C PROGRAM HISTORY LOG: -C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR (REPLACED CRAY LIBRARY -C ROUTINE ABORT) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION; REPLACED CALL TO -C INTRINSIC C ROUTINE "EXIT" WITH CALL TO -C BUFRLIB C ROUTINE "BORT_EXIT" WHICH ALWAYS -C RETURNS A NON-ZERO STATUS BACK TO EXECUTING -C SHELL SCRIPT -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL BORT (STR) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): ERROR MESSAGE TO BE WRITTEN VIA -C SUBROUTINE ERRWRT -C -C REMARKS: -C THIS ROUTINE CALLS: BORT_EXIT ERRWRT -C THIS ROUTINE IS CALLED BY: ADN30 ATRCPT BVERS CHEKSTAB -C CKTABA CLOSMG CMPMSG CMSGINI -C CNVED4 COBFL COPYBF COPYMG -C COPYSB CPDXMM CPYMEM CPYUPD -C CRBMG CWBMG DATEBF DATELEN -C DRFINI DRSTPL DUMPBF DXDUMP -C DXMINI GETWIN GETTBH IDN30 -C IFBGET IGETNTBI IGETSC IGETTDI -C INCTAB INVMRG IPKM ISIZE -C IUPVS01 IUPM JSTNUM LCMGDF -C LSTJPB MAKESTAB MINIMG MSGINI -C MSGWRT MVB NEMTBA NEMTBAX -C NEMTBB NEMTBD NENUBD NEVN -C NEWWIN NMSUB NUMMTB NVNWIN -C NXTWIN OPENBF OPENMB OPENMG -C PAD PADMSG PARUTG PKBS1 -C PKVS01 POSAPX RCSTPL RDBFDX -C RDCMPS RDMEMM RDMEMS RDMGSB -C RDMSGB RDMSGW RDMTBB RDMTBD -C READDX READERME READLC READMG -C READNS READSB READS3 REWNBF -C RTRCPT SNTBBE SNTBDE STATUS -C STBFDX STDMSG STNDRD STNTBIA -C STRCPT STSEQ TABENT TABSUB -C TRYBUMP UFBCNT UFBCPY UFBCUP -C UFBDMP UFBEVN UFBGET UFBIN3 -C UFBINT UFBINX UFBMEM UFBMEX -C UFBMMS UFBMNS UFBOVR UFBPOS -C UFBQCD UFBQCP UFBREP UFBRMS -C UFBSEQ UFBSTP UFBTAB UFBTAM -C UFDUMP UPDS3 UPFTBV UPTDD -C USRTPL WRCMPS WRDESC WRDLEN -C WRDXTB WRITDX WRITLC WRITSA -C WRITSB WTSTAT -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - - CALL ERRWRT(' ') - CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') - CALL ERRWRT(STR) - CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') - CALL ERRWRT(' ') - - CALL BORT_EXIT - - END diff --git a/src/bufr/bort2.f b/src/bufr/bort2.f deleted file mode 100644 index 5b9d90750e..0000000000 --- a/src/bufr/bort2.f +++ /dev/null @@ -1,52 +0,0 @@ - SUBROUTINE BORT2(STR1,STR2) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BORT2 -C PRGMMR: KEYSER ORG: NP22 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE WRITES (VIA BUFR ARCHIVE LIBRARY SUBROUTINE -C ERRWRT) TWO GIVEN ERROR STRINGS AND THEN CALLS BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT_EXIT TO ABORT THE APPLICATION PROGRAM CALLING THE -C BUFR ARCHIVE LIBRARY SOFTWARE. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT, EXCEPT BORT PRINTS ONLY ONE ERROR STRING. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 D. KEYSER -- ORIGINAL AUTHOR -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL BORT2 (STR1, STR2) -C INPUT ARGUMENT LIST: -C STR1 - CHARACTER*(*): FIRST ERROR MESSAGE TO BE WRITTEN VIA -C SUBROUTINE ERRWRT -C STR2 - CHARACTER*(*): SECOND ERROR MESSAGE TO BE WRITTEN VIA -C SUBROUTINE ERRWRT -C -C REMARKS: -C THIS ROUTINE CALLS: BORT_EXIT ERRWRT -C THIS ROUTINE IS CALLED BY: ELEMDX GETNTBE MTINFO PARSTR -C PARUSR PARUTG RDUSDX READMT -C SEQSDX SNTBBE SNTBDE STRING -C UFBINT UFBOVR UFBREP UFBSTP -C VALX -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR1, STR2 - - CALL ERRWRT(' ') - CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') - CALL ERRWRT(STR1) - CALL ERRWRT(STR2) - CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') - CALL ERRWRT(' ') - - CALL BORT_EXIT - - END diff --git a/src/bufr/bort_exit.c b/src/bufr/bort_exit.c deleted file mode 100644 index e0e1679eaa..0000000000 --- a/src/bufr/bort_exit.c +++ /dev/null @@ -1,35 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BORT_EXIT -C PRGMMR: ATOR ORG: NP12 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE WILL TERMINATE THE APPLICATION PROGRAM AND -C RETURN AN IMPLEMENTATION-DEFINED NON-ZERO STATUS CODE TO THE -C EXECUTING SHELL SCRIPT. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. ATOR -- ORIGINAL AUTHOR -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF -C 2004-08-18 J. ATOR -- USE bufrlib.h INCLUDE FILE -C 2007-01-19 J. ATOR -- FIX DECLARATION FOR ANSI-C -C -C USAGE: CALL BORT_EXIT -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: BORT BORT2 -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -void bort_exit( void ) -{ - exit( EXIT_FAILURE ); -} diff --git a/src/bufr/bufrlib.h b/src/bufr/bufrlib.h deleted file mode 100644 index c787444c94..0000000000 --- a/src/bufr/bufrlib.h +++ /dev/null @@ -1,143 +0,0 @@ -#include -#include -#include -#include - -/* -** Define a global variable for sharing of file pointers across different -** subprograms within the BUFRLIB software. -*/ -#ifdef BUFRLIB_GLOBAL - FILE *pbf[2]; /* each element will automatically initialize to NULL */ -#else - extern FILE *pbf[2]; -#endif - -/* -** On certain operating systems, the FORTRAN compiler appends an underscore -** to subprogram names in its object namespace. Therefore, on such systems, -** a matching underscore must be appended to any C language references to the -** same subprogram names so that the linker can correctly resolve such -** references across the C <-> FORTRAN interface at link time. -*/ -#ifdef UNDERSCORE -#define bort bort_ -#define bort_exit bort_exit_ -#define cadn30 cadn30_ -#define ccbfl ccbfl_ -#define cmpia cmpia_ -#define cobfl cobfl_ -#define crbmg crbmg_ -#define cwbmg cwbmg_ -#define elemdx elemdx_ -#define gets1loc gets1loc_ -#define ichkstr ichkstr_ -#define icvidx icvidx_ -#define ifxy ifxy_ -#define igetntbi igetntbi_ -#define igettdi igettdi_ -#define ipkm ipkm_ -#define istdesc istdesc_ -#define iupbs01 iupbs01_ -#define iupm iupm_ -#define mstabs mstabs_ -#define nemtab nemtab_ -#define nemtbb nemtbb_ -#define nummtb nummtb_ -#define numtbd numtbd_ -#define pktdd pktdd_ -#define rbytes rbytes_ -#define restd restd_ -#define stntbi stntbi_ -#define strnum strnum_ -#define stseq stseq_ -#define uptdd uptdd_ -#define wrdesc wrdesc_ -#define wrdlen wrdlen_ -#define openrb openrb_ -#define openwb openwb_ -#define openab openab_ -#define backbufr backbufr_ -#define cewind cewind_ -#define closfb closfb_ -#define crdbufr crdbufr_ -#define cwrbufr cwrbufr_ -#endif - -/* -** In order to ensure that the C <-> FORTRAN interface works properly (and -** portably!), the default size of an "INTEGER" declared in FORTRAN must be -** identical to that of an "int" declared in C. If this is not the case (e.g. -** some FORTRAN compilers, most notably AIX via the -qintsize= option, allow the -** sizes of INTEGERs to be definitively prescribed outside of the source code -** itself!), then the following conditional directive (or a variant of it) can -** be used to ensure that the size of an "int" in C remains identical to that -** of an "INTEGER" in FORTRAN. -*/ -#ifdef F77_INTSIZE_8 - typedef long f77int; -#else - typedef int f77int; -#endif - -/* -** Declare prototypes for ANSI C compatibility. -*/ -void bort( char *, f77int ); -void bort_exit( void ); -void cadn30( f77int *, char *, f77int ); -void ccbfl( void ); -int cmpia( const f77int *, const f77int * ); -void cobfl( char *, char * ); -void crbmg( char *, f77int *, f77int *, f77int * ); -void cwbmg( char *, f77int *, f77int * ); -void elemdx( char *, f77int *, f77int ); -void gets1loc( char *, f77int *, f77int *, f77int *, f77int *, f77int ); -f77int ichkstr ( char *, char *, f77int *, f77int, f77int ); -f77int ifxy( char *, f77int ); -f77int igetntbi( f77int *, char *, f77int ); -f77int igettdi( f77int * ); -void ipkm( char *, f77int *, f77int *, f77int ); -f77int istdesc( f77int * ); -f77int iupbs01 ( f77int *, char *, f77int ); -f77int iupm ( char *, f77int *, f77int ); -void nemtab( f77int *, char *, f77int *, char *, f77int *, f77int, f77int ); -void nemtbb( f77int *, f77int *, char *, f77int *, f77int *, f77int *, f77int ); -void nummtb( f77int *, char *, f77int * ); -void numtbd( f77int *, f77int *, char *, char *, f77int *, f77int, f77int ); -void pktdd( f77int *, f77int *, f77int *, f77int * ); -f77int rbytes( char *, f77int *, f77int, f77int ); -void restd( f77int *, f77int *, f77int *, f77int * ); -void strnum( char *, f77int *, f77int ); -void stseq( f77int *, f77int *, f77int *, char *, char *, f77int *, f77int * ); -void uptdd( f77int *, f77int *, f77int *, f77int * ); -void wrdesc( f77int, f77int *, f77int * ); -void wrdlen( void ); - -/* -** The following parameters must also be identically defined within -** "bufrlib.PRM" for use by several FORTRAN routines. See "bufrlib.PRM" -** for a description of these parameters. -*/ -#define MAXNC 600 -#define MXMTBB 4000 -#define MXMTBD 1000 -#define MAXCD 250 -#define MXNAF 3 -#define NFILES 32 - -/* -** Enable access to FORTRAN COMMON block /MSTABS/ from within C. -*/ -#ifdef COMMON_MSTABS - extern struct { - f77int nmtb; f77int ibfxyn[MXMTBB]; char cbscl[MXMTBB][4]; - char cbsref[MXMTBB][12]; char cbbw[MXMTBB][4]; - char cbunit[MXMTBB][14]; char cbmnem[MXMTBB][8]; - char cbelem[MXMTBB][120]; - f77int nmtd; f77int idfxyn[MXMTBD]; char cdseq[MXMTBD][120]; - char cdmnem[MXMTBD][8]; f77int ndelem[MXMTBD]; - f77int idefxy[MXMTBD*MAXCD]; - char cdelem[MXMTBD*MAXCD][120]; - } mstabs; -#endif diff --git a/src/bufr/bufrlib0.PRM b/src/bufr/bufrlib0.PRM deleted file mode 100755 index 370656a3d4..0000000000 --- a/src/bufr/bufrlib0.PRM +++ /dev/null @@ -1,202 +0,0 @@ -C----------------------------------------------------------------------- -C Define the BUFRLIB build types. - -#define NORMAL 1 -#define SUPERSIZE 2 -#define C32BITS 3 -C----------------------------------------------------------------------- -C Maximum number of BUFR files that can be connected to the -C BUFRLIB software (for reading or writing) at any one time. -C (NOTE: This parameter must also be identically defined -C within "bufrlib.h" for use by several C routines!) - -#if BUILD == C32BITS - PARAMETER ( NFILES = 10 ) -#else - PARAMETER ( NFILES = 32 ) -#endif -C----------------------------------------------------------------------- -C Maximum length (in bytes) of a BUFR message that can be -C read or written by the BUFRLIB software. - -#if BUILD == SUPERSIZE - PARAMETER ( MXMSGL = 2500000 ) -#else - PARAMETER ( MXMSGL = 600000 ) -#endif - PARAMETER ( MXMSGLD4 = MXMSGL/4 ) -C----------------------------------------------------------------------- -C Maximum number of Section 3 FXY descriptors that can be -C written into a BUFR message by the BUFRLIB software. -C (NOTE: This parameter must also be identically defined -C within "bufrlib.h" for use by several C routines!) - - PARAMETER ( MAXNC = 600 ) -C----------------------------------------------------------------------- -C Maximum number of default Section 0 or Section 1 values -C that can be overwritten within a BUFR message by the -C BUFRLIB software. - - PARAMETER ( MXS01V = 10 ) -C----------------------------------------------------------------------- -C Maximum number of data values that can be read from or written -C into a subset by the BUFRLIB software. - -#if BUILD == SUPERSIZE - PARAMETER ( MAXSS = 120000 ) -#else - PARAMETER ( MAXSS = 80000 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of data values that can be written into a subset -C of a compressed BUFR message by the BUFRLIB software. - -#if BUILD == SUPERSIZE - PARAMETER ( MXCDV = 50000 ) -#elif BUILD == C32BITS - PARAMETER ( MXCDV = 1000 ) -#else - PARAMETER ( MXCDV = 3000 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of subsets that can be written into a compressed -C BUFR message by the BUFRLIB software. - -#if BUILD == C32BITS - PARAMETER ( MXCSB = 2000 ) -#else - PARAMETER ( MXCSB = 4000 ) -#endif -C----------------------------------------------------------------------- -C Maximum length of a character string that can be written into a -C compressed BUFR message by the BUFRLIB software. - -#if BUILD == SUPERSIZE - PARAMETER ( MXLCC = 12 ) -#elif BUILD == C32BITS - PARAMETER ( MXLCC = 24 ) -#else - PARAMETER ( MXLCC = 32 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of entries in the internal BUFR Table A for each -C BUFR file that is connected to the BUFRLIB software. - - PARAMETER ( MAXTBA = 150 ) -C----------------------------------------------------------------------- -C Maximum number of entries in the internal BUFR Table B for each -C BUFR file that is connected to the BUFRLIB software. - - PARAMETER ( MAXTBB = 500 ) -C----------------------------------------------------------------------- -C Maximum number of entries in the internal BUFR Table D for each -C BUFR file that is connected to the BUFRLIB software. - - PARAMETER ( MAXTBD = 500 ) -C----------------------------------------------------------------------- -C Maximum number of entries in the master BUFR Table B. -C (NOTE: This parameter must also be identically defined -C within "bufrlib.h" for use by several C routines!) - - PARAMETER ( MXMTBB = 4000 ) -C----------------------------------------------------------------------- -C Maximum number of entries in the master BUFR Table D. -C (NOTE: This parameter must also be identically defined -C within "bufrlib.h" for use by several C routines!) - - PARAMETER ( MXMTBD = 1000 ) -C----------------------------------------------------------------------- -C Maximum number of child descriptors that can be included -C within the sequence definition of a Table D descriptor. -C (NOTE: This value does *not* need to take into account -C the recursive resolution of any child descriptors -C which may themselves be Table D descriptors!) -C (NOTE: This parameter must also be identically defined -C within "bufrlib.h" for use by several C routines!) - - PARAMETER ( MAXCD = 250 ) -C----------------------------------------------------------------------- -C Maximum number of entries in the internal jump/link table. - -#if BUILD == SUPERSIZE - PARAMETER ( MAXJL = NFILES*4000 ) -#else - PARAMETER ( MAXJL = NFILES*3000 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of entries in the internal string cache. - - PARAMETER ( MXS = 1000 ) -C----------------------------------------------------------------------- -C Maximum number of entries in the internal descriptor list cache. - - PARAMETER ( MXCNEM = MAXTBA*3 ) -C----------------------------------------------------------------------- -C Maximum number of "long" character strings (i.e. greater than -C 8 bytes) which can be read from a subset of a compressed BUFR -C message. - -#if BUILD == SUPERSIZE - PARAMETER ( MXRST = 500 ) -#else - PARAMETER ( MXRST = 50 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of BUFR messages that can be stored within -C internal memory. - -#if BUILD == C32BITS - PARAMETER ( MAXMSG = 20000 ) -#else - PARAMETER ( MAXMSG = 200000 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of bytes that can be used to store BUFR -C messages within internal memory. - -#if BUILD == SUPERSIZE - PARAMETER ( MAXMEM = 75000000 ) -#elif BUILD == C32BITS - PARAMETER ( MAXMEM = 400000 ) -#else - PARAMETER ( MAXMEM = 50000000 ) -#endif -C----------------------------------------------------------------------- -C Maximum number of jump/link table entries which can be used to -C store new reference values (as defined using the 2-03 operator). - - PARAMETER ( MXNRV = 12 ) -C----------------------------------------------------------------------- -C Maximum number of 2-04 associated fields that can be in effect -C at the same time for any given Table B descriptor. - - PARAMETER ( MXNAF = 3 ) -C----------------------------------------------------------------------- -C Maximum number of dictionary tables that can be stored for use -C with BUFR messages in internal memory. - - PARAMETER ( MXDXTS = 200 ) -C----------------------------------------------------------------------- -C Maximum number of dictionary messages that can be stored for use -C with BUFR messages in internal memory. - - PARAMETER ( MXDXM = MXDXTS*3 ) - - PARAMETER ( MXDXW = MXDXM*MXMSGLD4) -C----------------------------------------------------------------------- -C Maximum number of bytes that can be copied between BUFR -C messages within internal memory. - -#if BUILD == SUPERSIZE - PARAMETER ( MXIMB = 750000 ) -#else - PARAMETER ( MXIMB = 400000 ) -#endif -C----------------------------------------------------------------------- -C BUFRLIB "missing" value. The default value for BMISS is set -C within subroutine BFRINI, but it can be modified by the user via -C a subsequent call to subroutine SETBMISS. - - COMMON /BUFRBMISS/ BMISS - REAL*8 BMISS -C----------------------------------------------------------------------- diff --git a/src/bufr/bvers.f b/src/bufr/bvers.f deleted file mode 100644 index 16d9dcf7c0..0000000000 --- a/src/bufr/bvers.f +++ /dev/null @@ -1,50 +0,0 @@ - SUBROUTINE BVERS (CVERSTR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BVERS -C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER STRING CONTAINING THE -C VERSION NUMBER OF THE BUFR ARCHIVE LIBRARY SOFTWARE. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C 2011-09-26 J. ATOR -- UPDATED TO VERSION 10.0.1 -C 2012-02-24 J. ATOR -- UPDATED TO VERSION 10.1.0 -C 2012-10-12 J. ATOR -- UPDATED TO VERSION 10.2.0 -C 2012-11-29 J. ATOR -- UPDATED TO VERSION 10.2.1 -C 2012-12-04 J. ATOR -- UPDATED TO VERSION 10.2.2 -C 2013-01-08 J. ATOR -- UPDATED TO VERSION 10.2.3 -C 2013-01-09 J. ATOR -- UPDATED TO VERSION 10.2.4 -C 2013-01-25 J. ATOR -- UPDATED TO VERSION 10.2.5 -C -C USAGE: CALL BVERS (CVERSTR) -C -C OUTPUT ARGUMENT LIST: -C CVERSTR - CHARACTER*(*): VERSION STRING -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: WRDLEN -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) CVERSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF (LEN(CVERSTR).LT.8) GOTO 900 - - CVERSTR = '10.2.5' - - RETURN -900 CALL BORT('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE '// - . 'FOR AT LEAST 8 CHARACTERS') - END diff --git a/src/bufr/cadn30.f b/src/bufr/cadn30.f deleted file mode 100644 index 4ea344f8ca..0000000000 --- a/src/bufr/cadn30.f +++ /dev/null @@ -1,45 +0,0 @@ - SUBROUTINE CADN30( IDN, ADN ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CADN30 -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF THE FXY VALUE -C FOR A DESCRIPTOR, THIS ROUTINE CALLS FUNCTION ADN30 AND STORES -C ITS RETURN VALUE (I.E. THE ASCII-EQUIVALENT FXY VALUE) AS THE -C ROUTINE OUTPUT VALUE. THIS MECHANISM (I.E. A FORTRAN SUBROUTINE -C WRAPPER RETURNING ADN AS A CALL PARAMETER, RATHER THAN DIRECTLY -C CALLING THE FORTRAN FUNCTION ADN30 FROM WITHIN A C ROUTINE) -C ALLOWS SAFE AND PORTABLE (ALBEIT INDIRECT) ACCESS TO THE ADN30 -C FUNCTION LOGIC FROM WITHIN A C ROUTINE. -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CADN30( IDN, ADN ) -C INPUT ARGUMENT LIST: -C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE -C -C OUTPUT ARGUMENT LIST: -C ADN - CHARACTER*(*): ASCII-CHARACTER FORM OF IDN -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 -C THIS ROUTINE IS CALLED BY: NUMMTB RESTD STSEQ -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) ADN - CHARACTER*6 ADN30 - - ADN = ADN30( IDN, 6 ) - - RETURN - END diff --git a/src/bufr/capit.f b/src/bufr/capit.f deleted file mode 100644 index 373743f7ee..0000000000 --- a/src/bufr/capit.f +++ /dev/null @@ -1,64 +0,0 @@ - SUBROUTINE CAPIT(STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CAPIT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE CAPITALIZES A STRING OF CHARACTERS. THIS -C ENABLES THE USE OF MIXED CASE IN THE UNIT SECTION OF THE ASCII -C BUFR TABLES. AN EXAMPLE: A PROGRAM WHICH GENERATES AN ASCII BUFR -C TABLE FROM THE "MASTER TABLE B" MIGHT END UP COPYING SOME UNITS -C FIELDS IN MIXED OR LOWER CASE. IF THE UNITS ARE 'CODE TABLE' OR -C 'FLAG TABLE' OR CERTAIN OTHER UNIT DESIGNATIONS, THE TABLE WILL BE -C PARSED INCORRECTLY, AND THE DATA READ OR INCORRECTLY AS A RESULT. -C THIS MAKES SURE ALL UNIT DESIGNATIONS ARE SEEN BY THE PARSER IN -C UPPER CASE TO AVOID THESE TYPES OF PROBLEMS. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2012-03-02 J. ATOR -- CHANGED NAME OF UPS ARRAY TO UPCS TO AVOID -C NAMESPACE CONTENTION WITH NEW FUNCTION UPS -C -C USAGE: CALL CAPIT (STR) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING POSSIBLY CONTAINING MIXED UPPER- -C AND LOWER-CASE CHARACTERS -C -C OUTPUT ARGUMENT LIST: -C STR - CHARACTER*(*): SAME STRING AS INPUT BUT NOW CONTAINING -C ALL UPPER-CASE CHARACTERS -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: CMPMSG ELEMDX STBFDX STDMSG -C STRCPT -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - CHARACTER*26 UPCS,LWCS - DATA UPCS/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - DATA LWCS/'abcdefghijklmnopqrstuvwxyz'/ - - DO 20 I=1,LEN(STR) - DO 10 J=1,26 - IF(STR(I:I).EQ.LWCS(J:J)) THEN - STR(I:I) = UPCS(J:J) - GOTO 20 - ENDIF -10 CONTINUE -20 CONTINUE - - RETURN - END diff --git a/src/bufr/ccbfl.c b/src/bufr/ccbfl.c deleted file mode 100644 index 279280e759..0000000000 --- a/src/bufr/ccbfl.c +++ /dev/null @@ -1,36 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CCBFL -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS ROUTINE CLOSES (AND FLUSHES ANY REMAINING OUTPUT TO!) -C ANY SYSTEM FILES THAT ARE STILL OPEN FROM ANY PREVIOUS CALLS TO BUFR -C ARCHIVE LIBRARY SUBROUTINE COBFL. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL CCBFL -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -void ccbfl( void ) -{ - unsigned short i; - - for ( i = 0; i < 2; i++ ) { - if ( pbf[i] != NULL ) fclose( pbf[i] ); - } -} diff --git a/src/bufr/chekstab.f b/src/bufr/chekstab.f deleted file mode 100644 index bb0032be15..0000000000 --- a/src/bufr/chekstab.f +++ /dev/null @@ -1,111 +0,0 @@ - SUBROUTINE CHEKSTAB(LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CHEKSTAB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CHECKS THAT AN INTERNAL BUFR TABLE -C REPRESENTATION IS SELF-CONSISTENT AND FULLY DEFINED. IF ANY ERRORS -C ARE FOUND, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL CHEKSTAB (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: BORT NEMTAB NEMTBB NEMTBD -C THIS ROUTINE IS CALLED BY: MAKESTAB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*128 BORT_STR - CHARACTER*24 UNIT - CHARACTER*8 NEMO,NEMS(MAXCD) - CHARACTER*1 TAB - DIMENSION IRPS(MAXCD),KNTS(MAXCD) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C THERE MUST BE ENTRIES IN TABLES A, B, AND D -C ------------------------------------------- - - IF(NTBA(LUN).EQ.0) GOTO 900 - IF(NTBB(LUN).EQ.0) GOTO 901 - IF(NTBD(LUN).EQ.0) GOTO 902 - -C MAKE SURE EACH TABLE A ENTRY DEFINED AS A SEQUENCE -C -------------------------------------------------- - - DO I=1,NTBA(LUN) - NEMO = TABA(I,LUN)(4:11) - CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) - IF(TAB.NE.'D') GOTO 903 - ENDDO - -C CHECK TABLE B CONTENTS -C ---------------------- - - DO ITAB=1,NTBB(LUN) - CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) - ENDDO - -C CHECK TABLE D CONTNETS -C ---------------------- - - DO ITAB=1,NTBD(LUN) - CALL NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) - ENDDO - -C EXITS -C ----- - - RETURN -900 CALL BORT - . ('BUFRLIB: CHEKSTAB - EMPTY TABLE A IN INTERNAL BUFR TABLES') -901 CALL BORT - . ('BUFRLIB: CHEKSTAB - EMPTY TABLE B IN INTERNAL BUFR TABLES') -902 CALL BORT - . ('BUFRLIB: CHEKSTAB - EMPTY TABLE D IN INTERNAL BUFR TABLES') -903 WRITE(BORT_STR,'("BUFRLIB: CHEKSTAB - TABLE A ENTRY: ",A," NOT '// - . 'DEFINED AS A SEQUENCE")') NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/chrtrn.f b/src/bufr/chrtrn.f deleted file mode 100644 index 5f61fc1fd4..0000000000 --- a/src/bufr/chrtrn.f +++ /dev/null @@ -1,48 +0,0 @@ - SUBROUTINE CHRTRN(STR,CHR,N) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CHRTRN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF CHARACTERS -C FROM A CHARACTER ARRAY INTO A CHARACTER STRING. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C -C USAGE: CALL CHRTRN (STR, CHR, N) -C INPUT ARGUMENT LIST: -C CHR - CHARACTER*1: N-WORD CHARACTER ARRAY -C N - INTEGER: NUMBER OF CHARACTERS TO COPY -C -C OUTPUT ARGUMENT LIST: -C STR - CHARACTER*(*): CHARACTER STRING -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: STBFDX -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - CHARACTER*1 CHR(N) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - DO I=1,N - STR(I:I) = CHR(I) - ENDDO - RETURN - END diff --git a/src/bufr/chrtrna.f b/src/bufr/chrtrna.f deleted file mode 100644 index 582ce70f70..0000000000 --- a/src/bufr/chrtrna.f +++ /dev/null @@ -1,64 +0,0 @@ - SUBROUTINE CHRTRNA(STR,CHR,N) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CHRTRNA -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF CHARACTERS -C FROM A CHARACTER ARRAY INTO A CHARACTER STRING. THE DIFFERENCE -C BETWEEN THIS SUBROUTINE AND BUFR ARCHIVE LIBRARY SUBROUTINE CHRTRN -C IS THAT, IN THIS SUBROUTINE, THE INPUT CHARACTER ARRAY IS ASSUMED -C TO BE IN ASCII; THUS, FOR CASES WHERE THE NATIVE MACHINE IS EBCDIC, -C AN ASCII TO EBCDIC TRANSLATION IS DONE ON THE FINAL STRING BEFORE -C IT IS OUTPUT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C -C USAGE: CALL CHRTRNA (STR, CHR, N) -C INPUT ARGUMENT LIST: -C CHR - CHARACTER*1: N-WORD CHARACTER ARRAY IN ASCII -C N - INTEGER: NUMBER OF CHARACTERS TO COPY -C -C OUTPUT ARGUMENT LIST: -C STR - CHARACTER*(*): CHARACTER STRING IN ASCII OR EBCDIC, -C DEPENDING ON NATIVE MACHINE -C -C REMARKS: -C THIS ROUTINE CALLS: IPKM IUPM -C THIS ROUTINE IS CALLED BY: ICHKSTR STBFDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) - - CHARACTER*(*) STR - CHARACTER*1 CHR(N) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C Loop on N characters of CHR - - DO I=1,N - STR(I:I) = CHR(I) - -C If this is an EBCDIC machine, then translate the character -C from ASCII -> EBCDIC. - - IF(IASCII.EQ.0) CALL IPKM(STR(I:I),1,IATOE(IUPM(STR(I:I),8))) - ENDDO - RETURN - END diff --git a/src/bufr/cktaba.f b/src/bufr/cktaba.f deleted file mode 100644 index af8988a868..0000000000 --- a/src/bufr/cktaba.f +++ /dev/null @@ -1,292 +0,0 @@ - SUBROUTINE CKTABA(LUN,SUBSET,JDATE,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CKTABA -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 -C -C ABSTRACT: THIS SUBROUTINE PARSES THE TABLE A MNEMONIC AND THE DATE -C OUT OF SECTION 1 OF A BUFR MESSAGE PREVIOUSLY READ FROM UNIT LUNIT -C USING BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR EQUIVALENT (AND NOW -C STORED IN THE INTERNAL MESSAGE BUFFER, ARRAY MBAY IN COMMON BLOCK -C /BITBUF/). THE TABLE A MNEMONIC IS ASSOCIATED WITH THE BUFR -C MESSAGE TYPE/SUBTYPE IN SECTION 1. IT ALSO FILLS IN THE MESSAGE -C CONTROL WORD PARTITION ARRAYS IN COMMON BLOCK /MSGCWD/. -C -C PROGRAM HISTORY LOG: -C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR - CONSOLIDATED MESSAGE -C DECODING LOGIC THAT HAD BEEN REPLICATED IN -C READMG, READFT, READERME, RDMEMM AND READIBM -C (CKTABA IS NOW CALLED BY THESE CODES); -C LOGIC ENHANCED HERE TO ALLOW COMPRESSED AND -C STANDARD BUFR MESSAGES TO BE READ -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THE SECTION 1 -C MESSAGE SUBTYPE DOES NOT AGREE WITH THE -C SECTION 1 MESSAGE SUBTYPE IN THE DICTIONARY -C IF THE MESSAGE TYPE MNEMONIC IS NOT OF THE -C FORM "NCtttsss", WHERE ttt IS THE BUFR TYPE -C AND sss IS THE BUFR SUBTYPE (E.G., IN -C "PREPBUFR" FILES); MODIFIED DATE -C CALCULATIONS TO NO LONGER USE FLOATING -C POINT ARITHMETIC SINCE THIS CAN LEAD TO -C ROUND OFF ERROR AND AN IMPROPER RESULTING -C DATE ON SOME MACHINES (E.G., NCEP IBM -C FROST/SNOW), INCREASES PORTABILITY; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN; SUBSET DEFINED AS " " IF -C IRET RETURNED AS 11 (BEFORE WAS UNDEFINED) -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE IUPBS01, IGETDATE AND GETLENS -C 2006-04-14 J. ATOR -- ALLOW "FRtttsss" AND "FNtttsss" AS POSSIBLE -C TABLE A MNEMONICS, WHERE ttt IS THE BUFR -C TYPE AND sss IS THE BUFR SUBTYPE -C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; -C USE IUPBS3 AND ERRWRT -C -C USAGE: CALL CKTABA (LUN, SUBSET, JDATE, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING CHECKED: -C " " = IRET equal to 11 (see IRET below) -C and not using Section 3 decoding -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING CHECKED, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = unrecognized Table A (message type) value -C 11 = this is a BUFR table (dictionary) message -C -C REMARKS: -C THIS ROUTINE CALLS: BORT DIGIT ERRWRT GETLENS -C I4DY IGETDATE IUPB IUPBS01 -C IUPBS3 NEMTBAX NUMTAB OPENBT -C RDUSDX -C THIS ROUTINE IS CALLED BY: RDMEMM READERME READMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 - COMMON /UNPTYP/ MSGUNP(NFILES) - COMMON /QUIET / IPRT - - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*8 SUBSET,TAMNEM - CHARACTER*2 CPFX(3) - CHARACTER*1 TAB - LOGICAL TRYBT, DIGIT - - DATA CPFX / 'NC', 'FR', 'FN' / - DATA NCPFX / 3 / - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - - TRYBT = .TRUE. - - JDATE = IGETDATE(MBAY(1,LUN),IYR,IMO,IDY,IHR) - -c .... Message type - MTYP = IUPBS01(MBAY(1,LUN),'MTYP') -c .... Message subtype - MSBT = IUPBS01(MBAY(1,LUN),'MSBT') - - IF(MTYP.EQ.11) THEN -c .... This is a BUFR table (dictionary) message. - IRET = 11 -c .... There's no need to proceed any further unless Section 3 is being -c .... used for decoding. - IF(ISC3(LUN).EQ.0) THEN - SUBSET = " " - GOTO 100 - ENDIF - ENDIF - -C PARSE SECTION 3 -C --------------- - - CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5) - - IAD3 = LEN0+LEN1+LEN2 - -c .... First descriptor (integer) - KSUB = IUPB(MBAY(1,LUN),IAD3+8 ,16) -c .... Second descriptor (integer) - ISUB = IUPB(MBAY(1,LUN),IAD3+10,16) - -C LOCATE SECTION 4 -C ---------------- - - IAD4 = IAD3+LEN3 - -C NOW, TRY TO GET "SUBSET" (MNEMONIC ASSOCIATED WITH TABLE A) FROM MSG -C -------------------------------------------------------------------- - -C FIRST CHECK WHETHER SECTION 3 IS BEING USED FOR DECODING -C -------------------------------------------------------- - - IF(ISC3(LUN).NE.0) THEN - SUBSET = TAMNEM(LUN) -c .... is SUBSET from Table A? - CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) - IF(INOD.GT.0) THEN -c .... yes it is - MBYT(LUN) = 8*(IAD4+4) - MSGUNP(LUN) = 1 - GOTO 10 - ENDIF - ENDIF - -C IF ISUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=0 -C ---------------------------------------------------- - -c .... get SUBSET from ISUB -5 CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) -c .... is SUBSET from Table A? - CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) - IF(INOD.GT.0) THEN -c .... yes it is - MBYT(LUN) = (IAD4+4) - MSGUNP(LUN) = 0 - GOTO 10 - ENDIF - -C IF KSUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=1 (standard) -C --------------------------------------------------------------- - -c .... get SUBSET from KSUB - CALL NUMTAB(LUN,KSUB,SUBSET,TAB,ITAB) -c .... is SUBSET from Table A? - CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) - IF(INOD.GT.0) THEN -c .... yes it is - MBYT(LUN) = 8*(IAD4+4) - MSGUNP(LUN) = 1 - GOTO 10 - ENDIF - -C OKAY, STILL NO "SUBSET", LETS MAKE IT "NCtttsss" (where ttt=MTYP -C and sss=MSBT) AND SEE IF IT DEFINES TABLE A. IF NOT, THEN ALSO -C TRY "FRtttsss" AND "FNtttsss". -C ---------------------------------------------------------------- - - II=1 - DO WHILE(II.LE.NCPFX) - WRITE(SUBSET,'(A2,2I3.3)') CPFX(II),MTYP,MSBT -c .... is SUBSET from Table A? - CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) - IF(INOD.GT.0) THEN -c .... yes it is - IF(KSUB.EQ.IBCT) THEN - MBYT(LUN) = (IAD4+4) - MSGUNP(LUN) = 0 - ELSE - MBYT(LUN) = 8*(IAD4+4) - MSGUNP(LUN) = 1 - ENDIF - GOTO 10 - ENDIF - II=II+1 - ENDDO - -C NOW WE HAVE A GENERATED "SUBSET", BUT IT STILL DOES NOT DEFINE -C TABLE A - MAKE ONE LAST DESPERATE ATTEMPT - SEE IF AN EXTERNAL -C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT IS DEFINED -C IN OPENBT (ONLY POSSIBLE IF APPLICATION PROGRAM HAS AN IN-LINE -C OPENBT OVERRIDING THE ONE IN THE BUFR ARCHIVE LIBRARY) -C ------------------------------------------------------------------ - - IF(TRYBT) THEN - TRYBT = .FALSE. - IF(IPRT.GE.1) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - ERRSTR = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL'// - . ' BUFR TABLE VIA CALL TO IN-LINE OPENBT' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - CALL OPENBT(LUNDX,MTYP) - IF(LUNDX.GT.0) THEN -c .... Good news, there is a unit (LUNDX) connected to a table file, -c .... so store the table internally - CALL RDUSDX(LUNDX,LUN) - GOTO 5 - ENDIF - ENDIF - -C IF ALL ATTEMPTS TO DEFINE TABLE A FAIL SKIP GIVE UP -C --------------------------------------------------- - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE ('// - . SUBSET // ') - RETURN WITH IRET = -1' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IRET = -1 - GOTO 100 - -C CHECK THE VALIDITY OF THE MTYP/MSBT AND FOR COMPRESSION (MSGUNP=2) -C ------------------------------------------------------------------ - -10 IF(ISC3(LUN).EQ.0) THEN - IF(MTYP.NE.MTY1) GOTO 900 - IF(MSBT.NE.MSB1.AND.DIGIT(SUBSET(3:8))) GOTO 901 - ENDIF - IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) MSGUNP(LUN) = 2 - -C SET THE OTHER REQUIRED PARAMETERS IN MESSAGE CONTROL WORD PARTITION -C ------------------------------------------------------------------- - -c .... Date for this message - IDATE(LUN) = I4DY(JDATE) -c .... Positional index of Table A mnem. - INODE(LUN) = INOD -c .... Number of subsets in this message - MSUB(LUN) = IUPBS3(MBAY(1,LUN),'NSUB') -c .... Number of subsets read so far from this message - NSUB(LUN) = 0 - - IF(IRET.NE.11) THEN -c .... Number of non-dictionary messages read so far from this file - NMSG(LUN) = NMSG(LUN)+1 - ENDIF - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH '// - . '(SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') SUBSET,MTYP,MTY1 - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH '// - . '(SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') SUBSET,MSBT,MSB1 - CALL BORT(BORT_STR) - END diff --git a/src/bufr/closbf.f b/src/bufr/closbf.f deleted file mode 100644 index 3f9d2d311e..0000000000 --- a/src/bufr/closbf.f +++ /dev/null @@ -1,68 +0,0 @@ - SUBROUTINE CLOSBF(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CLOSBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE IS CALLED IN ORDER TO TERMINATE BUFR -C ARCHIVE LIBRARY SOFTWARE ACCESS TO A LOGICAL UNIT LUNIT FOR INPUT -C OR OUTPUT OPERATIONS (PREVIOUSLY OPENED BY A FORTRAN "OPEN" ON THE -C LOGICAL UNIT AND BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF). -C CLOSBF MUST BE CALLED WHEN LUNIT IS CONNECTED TO A BUFR FILE OPEN -C FOR OUTPUT IN ORDER TO PROPERLY CLOSE AND WRITE ANY CURRENT BUFR -C MESSAGE WHICH MAY STILL EXIST IN INTERNAL MEMORY (AND MOST LIKELY -C NOT BE FULL). IT IS NOT MANDATORY THAT CLOSBF BE CALLED WHEN LUNIT -C IS CONNECTED TO A BUFR FILE OPEN FOR INPUT, BUT IT IS STILL A GOOD -C IDEA TO DO SO. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- DON'T CLOSE LUNIT IF OPENED AS A NULL FILE -C BY OPENBF {NULL(LUN) = 1 IN NEW COMMON -C BLOCK /NULBFR/} (WAS IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C -- ADDED CALL TO CLOSFB TO CLOSE C FILES -C -C USAGE: CALL CLOSBF (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C OUTPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: CLOSFB CLOSMG STATUS WTSTAT -C THIS ROUTINE IS CALLED BY: COPYBF MESGBF UFBINX UFBMEM -C UFBMEX UFBTAB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /NULBFR/ NULL(NFILES) - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.GT.0 .AND. IM.NE.0) CALL CLOSMG(LUNIT) - if(IL.NE.0 .AND. NULL(LUN).EQ.0) call closfb(lun) - CALL WTSTAT(LUNIT,LUN,0,0) - -C CLOSE fortran UNIT IF NULL(LUN) = 0 -C ----------------------------------- - - IF(NULL(LUN).EQ.0) CLOSE(LUNIT) - - RETURN - END diff --git a/src/bufr/closmg.f b/src/bufr/closmg.f deleted file mode 100644 index cbde84915a..0000000000 --- a/src/bufr/closmg.f +++ /dev/null @@ -1,136 +0,0 @@ - SUBROUTINE CLOSMG(LUNIN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CLOSMG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C ABS(LUNIN) HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT CLOSES A BUFR -C MESSAGE PREVIOUSLY OPENED BY EITHER BUFR ARCHIVE LIBRARY -C SUBROUTINES OPENMG OR OPENMB AND WRITES IT TO THE UNIT ABS(LUNIN). -C SINCE OPENMG AND OPENMB NORMALLY CALL THIS INTERNALLY, IT IS NOT -C CALLED TOO OFTEN FROM AN APPLICATION PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-05-19 J. WOOLLEN -- CORRECTED A PROBLEM INTRODUCED IN A -C PREVIOUS (MAY 2002) IMPLEMENTATION WHICH -C PREVENTED THE DUMP CENTER TIME AND -C INTITIATION TIME MESSAGES FROM BEING -C WRITTEN OUT (THIS AFFECTED APPLICATION -C PROGRAM BUFR_DUMPMD, IF IT WERE RECOMPILED, -C IN THE DATA DUMPING PROCESS) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-05-26 D. KEYSER -- ALLOWS OVERRIDE OF PREVIOUS LOGIC THAT HAD -C ALWAYS WRITTEN OUT MESSAGE NUMBERS 1 AND 2 -C EVEN WHEN THEY CONTAINED ZERO SUBSETS -C (ASSUMED THESE ARE DUMMIES, CONTAINING ONLY -C CENTER AND DUMP TIME) (NO OTHER EMPTY -C MESSAGES WERE WRITTEN OUT), DONE BY PASSING -C IN A NEGATIVE UNIT NUMBER ARGUMENT THE -C FIRST TIME THIS ROUTINE IS CALLED BY AN -C APPLICATION PROGRAM (ALL EMPTY MESSAGES ARE -C SKIPPED) (ASSUMES DUMMY MESSAGES ARE NOT IN -C INPUT FILE), NOTE: THIS REMAINS SET FOR THE -C PARTICULAR FILE BEING WRITTEN TO EACH TIME -C CLOSMG IS CALLED, REGARDLESS OF THE SIGN OF -C THE UNIT NUMBER - THIS IS NECESSARY BECAUSE -C THIS ROUTINE IS CALLED BY OTHER BUFRLIB -C ROUTINES WHICH ALWAYS PASS IN A POSITIVE -C UNIT NUMBER (THE APPLICATION PROGRAM SHOULD -C ALWAYS CALL CLOSMG WITH A NEGATIVE UNIT -C NUMBER IMMEDIATELY AFTER CALLING OPENBF FOR -C THIS OUTPUT FILE IF THE INTENTION IS TO -C NOT WRITE ANY EMPTY MESSAGES) -C -C USAGE: CALL CLOSMG (LUNIN) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE -C - IF LUNIN IS GREATER THAN ZERO, THEN MESSAGE NUMBER -C 1 OR 2 IS WRITTEN OUT EVEN IF THE NUMBER OF -C SUBSETS WRITTEN INTO THE MESSAGE IS ZERO (THIS -C ALLOWS "DUMMY" MESSAGES CONTAINING DUMP CENTER AND -C INITIATION TIME TO BE COPIED), MESSAGE NUMBERS 3 -C AND HIGHER ARE NOT WRITTEN OUT IF THEY CONTAIN -C ZERO SUBSETS -C - IF LUNIN IS LESS THAN ZERO, THEN NO MESSAGES WITH -C ZERO SUBSETS WRITTEN INTO THEM ARE WRITTEN OUT -C FOR A PARTICULAR FILE BOTH IN THIS CALL AND IN ALL -C SUBSEQUENT CALLS TO THIS ROUTINE BY AN APPLICATION -C PROGRAM -C -C REMARKS: -C THIS ROUTINE CALLS: BORT MSGWRT STATUS WRCMPS -C WTSTAT -C THIS ROUTINE IS CALLED BY: CLOSBF MAKESTAB OPENMB OPENMG -C WRITSA -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - - DIMENSION MSGLIM(NFILES) - - DATA MSGLIM/NFILES*3/ - - SAVE MSGLIM - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS -C --------------------- - - LUNIT = ABS(LUNIN) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(LUNIT.NE.LUNIN) MSGLIM(LUN) = 0 - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.NE.0) THEN - IF(NSUB(LUN).GT.0) THEN - CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) - ELSE IF(NSUB(LUN).EQ.0.AND.NMSG(LUN).LT.MSGLIM(LUN)) THEN - CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) - ELSE IF(NSUB(LUN).LT.0) THEN - CALL WRCMPS(-LUNIT) - ENDIF - ENDIF - CALL WTSTAT(LUNIT,LUN,IL,0) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') - END diff --git a/src/bufr/cmpia.c b/src/bufr/cmpia.c deleted file mode 100644 index cec2a25ff9..0000000000 --- a/src/bufr/cmpia.c +++ /dev/null @@ -1,42 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMPIA -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS ROUTINE DEFINES A COMPARISON BETWEEN TWO INTEGERS -C FOR USE BY THE BINARY SEARCH FUNCTION BSEARCH. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL CMPIA( PF1, PF2 ) -C INPUT ARGUMENT LIST: -C PF1 - INTEGER: FIRST INTEGER TO BE COMPARED -C PF2 - INTEGER: SECOND INTEGER TO BE COMPARED -C -C OUTPUT ARGUMENT LIST: -C CMPIA - INTEGER: RESULT OF COMPARISON: -C -1 = PF1 is less than PF2 -C 0 = PF1 is equal to PF2 -C 1 = PF1 is greater than PF2 -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: NUMMTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -int cmpia( const f77int *pf1, const f77int *pf2 ) -{ - if ( *pf1 == *pf2 ) return 0; - - return ( *pf1 < *pf2 ? -1 : 1 ); -} diff --git a/src/bufr/cmpmsg.f b/src/bufr/cmpmsg.f deleted file mode 100644 index fd1952fe55..0000000000 --- a/src/bufr/cmpmsg.f +++ /dev/null @@ -1,56 +0,0 @@ - SUBROUTINE CMPMSG(CF) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMPMSG -C PRGMMR: ATOR ORG: NP12 DATE: 2005-03-09 -C -C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT BUFR -C MESSAGES CREATED BY FUTURE CALLS TO EITHER OF THE BUFR ARCHIVE -C LIBRARY SUBROUTINES WRITSB OR WRITSA ARE TO BE COMPRESSED. -C THIS SUBROUTINE CAN BE CALLED AT ANY TIME AFTER THE FIRST CALL -C TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE POSSIBLE VALUES -C FOR CF ARE 'N' (= 'NO', WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). -C -C PROGRAM HISTORY LOG: -C 2005-03-09 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL CMPMSG (CF) -C INPUT ARGUMENT LIST: -C CF - CHARACTER*1: FLAG INDICATING WHETHER BUFR MESSAGES -C OUTPUT BY FUTURE CALLS TO WRITSB OR WRITSA ARE TO -C BE COMPRESSED: -C 'N' = 'NO' (THE DEFAULT) -C 'Y' = 'YES' -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CAPIT -C THIS ROUTINE IS CALLED BY: COPYSB WRITCP -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /MSGCMP/ CCMF - - CHARACTER*128 BORT_STR - CHARACTER*1 CCMF, CF - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL CAPIT(CF) - IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - CCMF = CF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: CMPMSG - INPUT ARGUMENT IS ",A1,'// - . '", IT MUST BE EITHER Y OR N")') CF - CALL BORT(BORT_STR) - END diff --git a/src/bufr/cmsgini.f b/src/bufr/cmsgini.f deleted file mode 100644 index 0adad76ff9..0000000000 --- a/src/bufr/cmsgini.f +++ /dev/null @@ -1,211 +0,0 @@ - SUBROUTINE CMSGINI(LUN,MESG,SUBSET,IDATE,NSUB,NBYT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMSGINI -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE INITIALIZES A NEW BUFR MESSAGE FOR OUTPUT -C IN COMPRESSED BUFR. THE ACTUAL LENGTH OF SECTION 4 (CONTAINING -C COMPRESSED DATA) IS ALREADY KNOWN. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY; LEN3 INITIALIZED AS -C ZERO (BEFORE WAS UNDEFINED WHEN FIRST -C REFERENCED) -C 2004-08-18 J. ATOR -- ADDED COMMON /MSGSTD/ AND OTHER LOGIC TO -C ALLOW OPTION OF CREATING A SECTION 3 THAT IS -C FULLY WMO-STANDARD; IMPROVED DOCUMENTATION; -C MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 -C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13; -C REMOVED STANDARDIZATION LOGIC FOR SECTION 3 -C -C USAGE: CALL CMSGINI (LUN, MESG, SUBSET, IDATE, NSUB, NBYT) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING WRITTEN -C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING WRITTEN, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C NSUB - INTEGER: NUMBER OF SUBSETS, STORED IN SECTION 3 OF -C BUFR MESSAGE BEING WRITTEN -C NBYT - INTEGER: ACTUAL LENGTH (IN BYTES) OF "COMPRESSED DATA -C PORTION" OF SECTION 4 (I.E. ALL OF SECTION 4 EXCEPT -C FOR THE FIRST FOUR BYTES) -C -C OUTPUT ARGUMENT LIST: -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE -C NBYT - INTEGER: ACTUAL LENGTH OF BUFR MESSAGE (IN BYTES) UP -C TO THE POINT IN SECTION 4 WHERE COMPRESSED DATA ARE -C TO BE WRITTEN -C -C REMARKS: -C THIS ROUTINE CALLS: BORT I4DY NEMTAB NEMTBA -C PKB PKC -C THIS ROUTINE IS CALLED BY: WRCMPS -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - CHARACTER*4 BUFR - CHARACTER*1 TAB - DIMENSION MESG(*) - - DATA BUFR/'BUFR'/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE -C --------------------------------------------------- - -c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD - CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD) - CALL NEMTAB(LUN,SUBSET,ISUB,TAB,IRET) - IF(IRET.EQ.0) GOTO 900 - -C DATE CAN BE YYMMDDHH OR YYYYMMDDHH -C ---------------------------------- - - JDATE = I4DY(IDATE) - MCEN = MOD(JDATE/10**8,100)+1 - MEAR = MOD(JDATE/10**6,100) - MMON = MOD(JDATE/10**4,100) - MDAY = MOD(JDATE/10**2,100) - MOUR = MOD(JDATE ,100) - MMIN = 0 - -c .... DK: Don't think this can happen, because IDATE=0 is returned -c as 2000000000 by I4DY meaning MCEN would be 21 - IF(MCEN.EQ.1) GOTO 901 - - IF(MEAR.EQ.0) MCEN = MCEN-1 - IF(MEAR.EQ.0) MEAR = 100 - -C INITIALIZE THE MESSAGE -C ---------------------- - - MBIT = 0 - -C SECTION 0 -C --------- - - CALL PKC(BUFR , 4 , MESG,MBIT) - -C NOTE THAT THE ACTUAL SECTION 0 LENGTH WILL BE COMPUTED AND -C STORED BELOW; FOR NOW, WE ARE REALLY ONLY INTERESTED IN -C ADVANCING MBIT BY THE CORRECT AMOUNT, SO WE'LL JUST STORE -C A DEFAULT VALUE OF 0. - - CALL PKB( 0 , 24 , MESG,MBIT) - CALL PKB( 3 , 8 , MESG,MBIT) - -C SECTION 1 -C --------- - - LEN1 = 18 - - CALL PKB(LEN1 , 24 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - CALL PKB( 3 , 8 , MESG,MBIT) - CALL PKB( 7 , 8 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - CALL PKB(MTYP , 8 , MESG,MBIT) - CALL PKB(MSBT , 8 , MESG,MBIT) - CALL PKB( 13 , 8 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - CALL PKB(MEAR , 8 , MESG,MBIT) - CALL PKB(MMON , 8 , MESG,MBIT) - CALL PKB(MDAY , 8 , MESG,MBIT) - CALL PKB(MOUR , 8 , MESG,MBIT) - CALL PKB(MMIN , 8 , MESG,MBIT) - CALL PKB(MCEN , 8 , MESG,MBIT) - -C SECTION 3 -C --------- - - LEN3 = 10 - - CALL PKB(LEN3 , 24 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - CALL PKB(NSUB , 16 , MESG,MBIT) - CALL PKB( 192 , 8 , MESG,MBIT) - CALL PKB(ISUB , 16 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - -C SECTION 4 -C --------- - -C STORE THE TOTAL LENGTH OF SECTION 4. - -C REMEMBER THAT THE INPUT VALUE OF NBYT ONLY CONTAINS THE -C LENGTH OF THE "COMPRESSED DATA PORTION" OF SECTION 4, SO -C WE NEED TO ADD FOUR BYTES TO THIS NUMBER IN ORDER TO -C ACCOUNT FOR THE TOTAL LENGTH OF SECTION 4. - - CALL PKB((NBYT+4) , 24 , MESG,MBIT) - CALL PKB( 0 , 8 , MESG,MBIT) - -C THE ACTUAL "COMPRESSED DATA PORTION" OF SECTION 4 WILL -C BE FILLED IN LATER BY SUBROUTINE WRCMPS. - -C SECTION 5 -C --------- - -C THIS SECTION WILL BE FILLED IN LATER BY SUBROUTINE WRCMPS. - -C RETURN WITH THE CORRECT NEW MESSAGE BYTE COUNT -C ---------------------------------------------- - -C NOW, NOTING THAT MBIT CURRENTLY POINTS TO THE LAST BIT OF -C THE FOURTH BYTE OF SECTION 4, THEN WE HAVE: -C (TOTAL LENGTH OF BUFR MESSAGE (IN SECTION 0)) = -C (LENGTH OF MESSAGE UP THROUGH FOURTH BYTE OF SECTION 4) -C + (LENGTH OF "COMPRESSED DATA PORTION" OF SECTION 4) -C + (LENGTH OF SECTION 5) - MBYT = - . MBIT/8 - . + NBYT - . + 4 - -C NOW, MAKE NBYT POINT TO THE CURRENT LOCATION OF MBIT -C (I.E. THE BYTE AFTER WHICH TO ACTUALLY BEGIN WRITING THE -C COMPRESSED DATA INTO SECTION 4). - - NBYT = MBIT/8 - -C NOW, STORE THE TOTAL LENGTH OF THE BUFR MESSAGE (IN SECTION 0). - - MBIT = 32 - CALL PKB(MBYT,24,MESG,MBIT) - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE '// - . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBSET - CALL BORT(BORT_STR) -901 CALL BORT - . ('BUFRLIB: CMSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') - END diff --git a/src/bufr/cnved4.f b/src/bufr/cnved4.f deleted file mode 100644 index 6dbb1a0f16..0000000000 --- a/src/bufr/cnved4.f +++ /dev/null @@ -1,137 +0,0 @@ - SUBROUTINE CNVED4(MSGIN,LMSGOT,MSGOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CNVED4 -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE ENCODED USING -C BUFR EDITION 3 AND OUTPUTS AN EQUIVALENT BUFR MESSAGE ENCODED USING -C BUFR EDITION 4. THE OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE -C INPUT MESSAGE, SO THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE -C MSGOT ARRAY. NOTE THAT MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2009-08-12 J. ATOR -- ALLOW SILENT RETURN (INSTEAD OF BORT RETURN) -C IF MSGIN IS ALREADY ENCODED USING EDITION 4 -C -C USAGE: CALL CNVED4 (MSGIN, LMSGOT, MSGOT) -C INPUT ARGUMENT LIST: -C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE ENCODED -C USING BUFR EDITION 3 -C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; -C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT -C OVERFLOW THE MSGOT ARRAY -C -C OUTPUT ARGUMENT LIST: -C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE -C NOW ENCODED USING BUFR EDITION 4 -C -C REMARKS: -C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. -C -C THIS ROUTINE CALLS: BORT GETLENS IUPBS01 MVB -C NMWRD PKB -C THIS ROUTINE IS CALLED BY: MSGWRT -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MSGIN(*), MSGOT(*) - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(IUPBS01(MSGIN,'BEN').EQ.4) THEN - -C The input message is already encoded using edition 4, so just -C copy it from MSGIN to MSGOT and then return. - - NMW = NMWRD(MSGIN) - IF(NMW.GT.LMSGOT) GOTO 900 - DO I = 1, NMW - MSGOT(I) = MSGIN(I) - ENDDO - RETURN - ENDIF - -C Get some section lengths and addresses from the input message. - - CALL GETLENS(MSGIN,3,LEN0,LEN1,LEN2,LEN3,L4,L5) - - IAD2 = LEN0 + LEN1 - IAD4 = IAD2 + LEN2 + LEN3 - - LENM = IUPBS01(MSGIN,'LENM') - -C Check for overflow of the output array. Note that the new -C edition 4 message will be a total of 3 bytes longer than the -C input message (i.e. 4 more bytes in Section 1, but 1 fewer -C byte in Section 3). - - LENMOT = LENM + 3 - IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 - - LEN1OT = LEN1 + 4 - LEN3OT = LEN3 - 1 - -C Write Section 0 of the new message into the output array. - - CALL MVB ( MSGIN, 1, MSGOT, 1, 4 ) - IBIT = 32 - CALL PKB ( LENMOT, 24, MSGOT, IBIT ) - CALL PKB ( 4, 8, MSGOT, IBIT ) - -C Write Section 1 of the new message into the output array. - - CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'BMT'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'OGCE'), 16, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'GSES'), 16, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'USN'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'ISC2')*128, 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'MTYP'), 8, MSGOT, IBIT ) - -C Set a default of 255 for the international subcategory. - - CALL PKB ( 255, 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'MSBT'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'MTV'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'MTVL'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'YEAR'), 16, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'MNTH'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'DAYS'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'HOUR'), 8, MSGOT, IBIT ) - CALL PKB ( IUPBS01(MSGIN,'MINU'), 8, MSGOT, IBIT ) - -C Set a default of 0 for the second. - - CALL PKB ( 0, 8, MSGOT, IBIT ) - -C Copy Section 2 (if it exists) through the next-to-last byte -C of Section 3 from the input array to the output array. - - CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LEN2+LEN3-1 ) - -C Store the length of the new Section 3. - - IBIT = ( LEN0 + LEN1OT + LEN2 ) * 8 - CALL PKB ( LEN3OT, 24, MSGOT, IBIT ) - -C Copy Section 4 and Section 5 from the input array to the -C output array. - - IBIT = IBIT + ( LEN3OT * 8 ) - 24 - CALL MVB ( MSGIN, IAD4+1, MSGOT, (IBIT/8)+1, LENM-IAD4 ) - - RETURN -900 CALL BORT('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) '// - . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END diff --git a/src/bufr/cobfl.c b/src/bufr/cobfl.c deleted file mode 100644 index 7a034d2822..0000000000 --- a/src/bufr/cobfl.c +++ /dev/null @@ -1,106 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: COBFL -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS ROUTINE OPENS A SPECIFIED SYSTEM FILE FOR READING -C OR WRITING VIA THE BUFR ARCHIVE LIBRARY C I/O INTERFACE. THERE -C CAN BE AT MOST TWO SYSTEM FILES OPEN AT ANY GIVEN TIME (ONE FOR -C READING/INPUT AND ONE FOR WRITING/OUTPUT). IF A CALL TO THIS -C ROUTINE IS MADE FOR EITHER READING/INPUT OR WRITING/OUTPUT AND -C SUCH A FILE IS ALREADY OPEN TO THE BUFR ARCHIVE LIBRARY C I/O -C INTERFACE, THEN THAT FILE WILL BE CLOSED BEFORE OPENING THE -C NEW ONE. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL COBFL( BFL, IO ) -C INPUT ARGUMENT LIST: -C BFL - CHARACTER*(*): SYSTEM FILE TO BE OPENED. INCLUSION -C OF DIRECTORY PREFIXES OR OTHER LOCAL FILESYSTEM -C NOTATION IS ALLOWED UP TO 120 TOTAL CHARACTERS. -C IO - CHARACTER: FLAG INDICATING HOW BFL IS TO BE OPENED -C FOR USE WITH THE C I/O INTERFACE: -C 'r' = READING (INPUT) -C 'w' = WRITING (OUTPUT) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#define BUFRLIB_GLOBAL -#include "bufrlib.h" - -#define MXFNLEN 500 - -void cobfl( char *bfl, char *io ) -{ - char lbf[MXFNLEN+1]; - char lio; - - char errstr[129]; - - char foparg[3] = " b"; /* 3rd character will automatically - initialize to NULL */ - unsigned short i, j; - -/* -** Copy the input arguments into local variables and check them for validity. -** This is especially important in case either of the arguments was passed in -** as a string literal by the calling program or else doesn't have a trailing -** NULL character. -*/ - for ( i = 0; ( ! isspace( bfl[i] ) && ! iscntrl( bfl[i] ) ); i++ ) { - if ( i == MXFNLEN ) { - sprintf( errstr, "BUFRLIB: COBFL - INPUT FILENAME CONTAINS" - " MORE THAN %d CHARACTERS", MXFNLEN ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - lbf[i] = bfl[i]; - } - lbf[i] = '\0'; - - lio = io[0]; - if ( ( foparg[0] = (char) tolower( lio ) ) == 'r' ) { - j = 0; - } - else if ( foparg[0] == 'w' ) { - j = 1; - } - else { - sprintf( errstr, "BUFRLIB: COBFL - SECOND ARGUMENT WAS (%c)," - " WHICH IS AN ILLEGAL VALUE", lio ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - -/* -** If a file of this type is already open, then close it before -** opening the new one. -*/ - if ( pbf[j] != NULL ) fclose( pbf[j] ); - -/* -** Open the requested file. -*/ - if ( ( pbf[j] = fopen( lbf, foparg ) ) == NULL ) { - sprintf( errstr, "BUFRLIB: COBFL - COULD NOT OPEN FILE %s", lbf ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - -/* -** Call wrdlen to initialize some important information about the -** local machine, just in case it hasn't already been called. -*/ - wrdlen( ); - - return; -} diff --git a/src/bufr/conwin.f b/src/bufr/conwin.f deleted file mode 100644 index 791acff928..0000000000 --- a/src/bufr/conwin.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE CONWIN(LUN,INC1,INC2) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CONWIN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SEARCHES CONSECUTIVE SUBSET BUFFER SEGMENTS -C FOR AN ELEMENT IDENTIFIED IN THE USER STRING AS A CONDITIONAL NODE -C (I.E. AN ELEMENT WHICH MUST MEET A CONDITION IN ORDER TO BE READ -C FROM OR WRITTEN TO A DATA SUBSET). IF A CONDITIONAL ELEMENT IS -C FOUND AND IT CONFORMS TO THE CONDITION, THEN THE INTERNAL SUBSET -C BUFFER INDICES OF THE "WINDOW" (SEE BELOW REMARKS) ARE RETURNED TO -C THE CALLER FOR PROCESSING. -C -C THE FOUR CONDITIONS WHICH CAN BE EXERCISED ARE: -C '<' - LESS THAN -C '>' - GREATER THAN -C '=' - EQUAL -C '!' - NOT EQUAL -C -C EACH CONDITION IN A STRING IS APPLIED TO ONE ELEMENT, AND ALL -C CONDITIONS ARE 'AND'ED TO EVALUATE AN OUTCOME. FOR EXAMPLE, IF THE -C CONDITION STRING IS: "POB<500 TOB>30 TQM<4" THEN THE ONLY LEVELS OF -C DATA READ OR WRITTEN ARE THOSE WITH PRESSURE LT 500 MB, TEMPERATURE -C GT 30 DEG, AND TEMPERATURE QUALITY MARK < 4. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2010-04-27 J. WOOLLEN -- CORRECT LOGICAL FLAW AND ADD DOCUMENTATION -C -C USAGE: CALL CONWIN (LUN, INC1, INC2) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INC1 - INTEGER: SUBSET BUFFER START INDEX -C INC2 - INTEGER: SUBSET BUFFER ENDING INDEX -C -C OUTPUT ARGUMENT LIST: -C INC1 - INTEGER: SUBSET BUFFER START INDEX -C INC2 - INTEGER: SUBSET BUFFER ENDING INDEX -C -C REMARKS: -C -C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN -C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. -C -C FUNCTION CONWIN WORKS WITH FUNCTION INVCON TO IDENTIFY SUBSET -C BUFFER SEGMENTS WHICH CONFORM TO THE SET OF CONDITIONS. -C -C THIS ROUTINE CALLS: GETWIN INVCON -C THIS ROUTINE IS CALLED BY: UFBEVN UFBIN3 UFBRW -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C SPECIAL CASE -C ------------ - - IF(NCON.EQ.0) THEN -c .... There are no condition nodes in the string - INC1 = 1 - INC2 = NVAL(LUN) - GOTO 100 - ENDIF - -C EVALUATE CONDITIONS TO SEE IF ANY MORE CASES -C -------------------------------------------- - -15 CALL GETWIN(NODC(1),LUN,INC1,INC2) - IF(INC1.GT.0) THEN - DO NC=1,NCON - ICON = INVCON(NC,LUN,INC1,INC2) - IF(ICON.EQ.0) GOTO 15 - ENDDO - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/copybf.f b/src/bufr/copybf.f deleted file mode 100644 index 6a10802c71..0000000000 --- a/src/bufr/copybf.f +++ /dev/null @@ -1,106 +0,0 @@ - SUBROUTINE COPYBF(LUNIN,LUNOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: COPYBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES AN ENTIRE BUFR FILE FROM LOGICAL -C UNIT LUNIN TO LOGICAL UNIT LUNOT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE RDMSGW AND NMWRD -C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE -C USE READMG AND COPYMG TO COPY FILE -C -C USAGE: CALL COPYBF (LUNIN, LUNOT) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C INPUT FILES: -C UNIT "LUNIN" - BUFR FILE -C -C OUTPUT FILES: -C UNIT "LUNOT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CLOSBF IUPBS01 MSGWRT -C OPENBF RDMSGW STATUS WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - DIMENSION MBAY(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION -C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) -C --------------------------------------------------------------- - - CALL WRDLEN - -C CHECK BUFR FILE STATUSES -C ------------------------ - - CALL STATUS(LUNIN,LUN,IL,IM) - IF(IL.NE.0) GOTO 900 - CALL STATUS(LUNOT,LUN,IL,IM) - IF(IL.NE.0) GOTO 901 - -C CONNECT THE FILES FOR READING/WRITING TO THE C-I-O INTERFACE -C ------------------------------------------------------------ - - CALL OPENBF(LUNIN,'INX',LUNIN) - CALL OPENBF(LUNOT,'OUX',LUNIN) - -C READ AND COPY A BUFR FILE ON UNIT LUNIN TO UNIT LUNOT -C ----------------------------------------------------- - -1 CALL RDMSGW(LUNIN,MBAY,IER) - IF(IER.EQ.0) THEN - CALL MSGWRT(LUNOT,MBAY,IUPBS01(MBAY,'LENM')) - GOTO 1 - ENDIF - -C FREE UP THE FILE CONNECTIONS FOR THE TWO FILES -C ---------------------------------------------- - - CALL CLOSBF(LUNIN) - CALL CLOSBF(LUNOT) - -C EXITS -C ----- - - RETURN -900 CALL BORT - . ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') -901 CALL BORT - . ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') - END diff --git a/src/bufr/copymg.f b/src/bufr/copymg.f deleted file mode 100644 index 06916ad9c4..0000000000 --- a/src/bufr/copymg.f +++ /dev/null @@ -1,136 +0,0 @@ - SUBROUTINE COPYMG(LUNIN,LUNOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: COPYMG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM LOGICAL -C UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT -C VIA A PREVIOUS CALL TO OPENBF. THE MESSAGE COPIED FROM LOGICAL -C UNIT LUNIN WILL BE THE ONE MOST RECENTLY READ USING BUFR ARCHIVE -C LIBRARY SUBROUTINE READMG. THE OUTPUT FILE MUST HAVE NO CURRENTLY -C OPEN MESSAGES. ALSO, BOTH FILES MUST HAVE BEEN OPENED TO THE BUFR -C INTERFACE WITH IDENTICAL BUFR TABLES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE IUPBS01 -C 2009-06-26 J. ATOR -- USE IOK2CPY -C -C USAGE: CALL COPYMG (LUNIN, LUNOT) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IOK2CPY IUPBS01 MSGWRT -C NEMTBA STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*8 SUBSET - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUSES -C ----------------------- - - CALL STATUS(LUNIN,LIN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - - CALL STATUS(LUNOT,LOT,IL,IM) - IF(IL.EQ.0) GOTO 903 - IF(IL.LT.0) GOTO 904 - IF(IM.NE.0) GOTO 905 - -C MAKE SURE BOTH FILES HAVE THE SAME TABLES -C ----------------------------------------- - - SUBSET = TAG(INODE(LIN)) -c .... Given SUBSET, returns MTYP,MSBT,INOD - CALL NEMTBA(LOT,SUBSET,MTYP,MSBT,INOD) - IF(INODE(LIN).NE.INOD) THEN - IF(IOK2CPY(LIN,LOT).NE.1) GOTO 906 - ENDIF - -C EVERYTHING OKAY, COPY A MESSAGE -C ------------------------------- - - MBYM = IUPBS01(MBAY(1,LIN),'LENM') - CALL MSGWRT(LUNOT,MBAY(1,LIN),MBYM) - -C SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT -C ----------------------------------------------------------------- - - NMSG (LOT) = NMSG(LOT) + 1 - NSUB (LOT) = MSUB(LIN) - MSUB (LOT) = MSUB(LIN) - IDATE(LOT) = IDATE(LIN) - INODE(LOT) = INOD - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -904 CALL BORT('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -905 CALL BORT('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN '// - . 'OUTPUT BUFR FILE, A MESSAGE IS OPEN') -906 CALL BORT('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST '// - . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') - END diff --git a/src/bufr/copysb.f b/src/bufr/copysb.f deleted file mode 100644 index e073626edb..0000000000 --- a/src/bufr/copysb.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE COPYSB(LUNIN,LUNOT,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: COPYSB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A PACKED DATA SUBSET, INTACT, FROM -C LOGICAL UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR -C ARCHIVE LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED -C FOR OUTPUT VIA A PREVIOUS CALL TO OPENBF. THE BUFR MESSAGE MUST -C HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE -C LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED -C OR UNCOMPRESSED. ALSO, BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR -C OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A -C BUFR MESSAGE WITHIN MEMORY FOR UNIT LUNOT. EACH CALL TO COPYSB -C ADVANCES THE POINTER TO THE BEGINNING OF THE NEXT SUBSET IN BOTH -C THE INPUT AND OUTPUT FILES, UNLESS INPUT PARAMETER LUNOT IS .LE. -C ZERO, IN WHICH CASE THE OUTPUT POINTER IS NOT ADVANCED. THE -C COMPRESSION STATUS OF THE OUTPUT SUBSET/BUFR MESSAGE WILL ALWAYS -C MATCH THAT OF THE INPUT SUBSET/BUFR MESSAGE {I.E., IF INPUT MESSAGE -C IS UNCOMPRESSED(COMPRESSED) OUTPUT MESSAGE WILL BE UNCOMPRESSED -C (COMPRESSED)}. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-09-16 J. WOOLLEN -- NOW WRITES OUT COMPRESSED SUBSET/MESSAGE IF -C INPUT SUBSET/MESSAGE IS COMPRESSED (BEFORE -C COULD ONLY WRITE OUT UNCOMPRESSED SUBSET/ -C MESSAGE REGARDLESS OF COMPRESSION STATUS OF -C INPUT SUBSET/MESSAGE) -C 2009-06-26 J. ATOR -- USE IOK2CPY -C -C USAGE: CALL COPYSB ( LUNIN, LUNOT, IRET ) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the input -C BUFR message -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CMPMSG CPYUPD IOK2CPY -C MESGBC READSB STATUS UFBCPY -C UPB WRITSB -C THIS ROUTINE IS CALLED BY: ICOPYSB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*3 TYP - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUSES -C ----------------------- - - CALL STATUS(LUNIN,LIN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - - IF(LUNOT.GT.0) THEN - CALL STATUS(LUNOT,LOT,IL,IM) - IF(IL.EQ.0) GOTO 903 - IF(IL.LT.0) GOTO 904 - IF(IM.EQ.0) GOTO 905 - IF(INODE(LIN).NE.INODE(LOT)) THEN - IF( (TAG(INODE(LIN)).NE.TAG(INODE(LOT))) .OR. - . (IOK2CPY(LIN,LOT).NE.1) ) GOTO 906 - ENDIF - ENDIF - -C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE -C --------------------------------------------- - - IF(NSUB(LIN).EQ.MSUB(LIN)) THEN - IRET = -1 - GOTO 100 - ENDIF - -C CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH -C -------------------------------------------------------------------- - - CALL MESGBC(-LUNIN,MEST,ICMP) - - IF(ICMP.EQ.1) THEN - -C ------------------------------------------------------- -C THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES -C ------------------------------------------------------- -C READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG -C -------------------------------------------------------------------- - - CALL READSB(LUNIN,IRET) - IF(LUNOT.GT.0) THEN - CALL UFBCPY(LUNIN,LUNOT) - CALL CMPMSG('Y') - CALL WRITSB(LUNOT) - CALL CMPMSG('N') - ENDIF - GOTO 100 - ELSE IF(ICMP.EQ.0) THEN - -C ------------------------------------------------------- -C THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES -C ------------------------------------------------------- -C COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS -C --------------------------------------------------------------- - - IBIT = (MBYT(LIN))*8 - CALL UPB(NBYT,16,MBAY(1,LIN),IBIT) - IF(LUNOT.GT.0) CALL CPYUPD(LUNOT,LIN,LOT,NBYT) - MBYT(LIN) = MBYT(LIN) + NBYT - NSUB(LIN) = NSUB(LIN) + 1 - ELSE - GOTO 907 - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -904 CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -905 CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') -906 CALL BORT('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '// - . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') -907 WRITE(BORT_STR,'("BUFRLIB: COPYSB - INVALID COMPRESSION '// - . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '// - . 'ROUTINE MESGBC")') ICMP - CALL BORT(BORT_STR) - END diff --git a/src/bufr/cpbfdx.f b/src/bufr/cpbfdx.f deleted file mode 100644 index 031bde4473..0000000000 --- a/src/bufr/cpbfdx.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE CPBFDX(LUD,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CPBFDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES BUFR TABLE (DICTIONARY) MESSAGES -C FROM ONE LOCATION TO ANOTHER WITHIN INTERNAL MEMORY (ARRAYS IN -C COMMON BLOCKS /MSGCWD/ AND /TABABD/). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: CALL CPBFDX (LUD, LUN) -C INPUT ARGUMENT LIST: -C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR INPUT TABLE LOCATION -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR OUTPUT TABLE LOCATION -C -C REMARKS: -C THIS ROUTINE CALLS: DXINIT -C THIS ROUTINE IS CALLED BY: MAKESTAB READDX WRDXTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C INITIALIZE THE DICTIONARY TABLE PARTITION -C ----------------------------------------- - - CALL DXINIT(LUN,0) - -C COPY ONE TABLE PARTITION TO ANOTHER -C ----------------------------------- - -c .... Positional index for Table A mnem. - INODE(LUN) = INODE(LUD) - -c .... Set the number of Table A entries - NTBA(LUN) = NTBA(LUD) -c .... Set the number of Table B entries - NTBB(LUN) = NTBB(LUD) -c .... Set the number of Table D entries - NTBD(LUN) = NTBD(LUD) - -c .... Copy Table A entries - DO I=1,NTBA(LUD) -c .... Message type - IDNA(I,LUN,1) = IDNA(I,LUD,1) -c .... Message subtype - IDNA(I,LUN,2) = IDNA(I,LUD,2) -c .... Table A entries - TABA(I,LUN) = TABA(I,LUD) -c .... Pointer indices into internal tbl - MTAB(I,LUN) = MTAB(I,LUD) - ENDDO - -c .... Copy Table B entries - DO I=1,NTBB(LUD) -c .... Integer repr. of FXY descr. - IDNB(I,LUN) = IDNB(I,LUD) -c .... Table B entries - TABB(I,LUN) = TABB(I,LUD) - ENDDO - -c .... Copy Table D entries - DO I=1,NTBD(LUD) -c .... Integer repr. of FXY descr. - IDND(I,LUN) = IDND(I,LUD) -c .... Table B entries - TABD(I,LUN) = TABD(I,LUD) - ENDDO - - RETURN - END diff --git a/src/bufr/cpdxmm.f b/src/bufr/cpdxmm.f deleted file mode 100644 index ff3ba28417..0000000000 --- a/src/bufr/cpdxmm.f +++ /dev/null @@ -1,162 +0,0 @@ - SUBROUTINE CPDXMM( LUNIT ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CPDXMM -C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT, -C THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE -C ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO COMMON /MSGMEM/. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C REPLACED FORTRAN BACKSPACE WITH C BACKBUFR -C -C USAGE: CALL CPDXMM (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C REMARKS: -C -C THE FOLLOWING VALUES ARE STORED WITHIN COMMON /MSGMEM/ BY THIS -C SUBROUTINE: -C -C LDXM = number of array words filled within MDX -C -C MDX(I=1,LDXM) = DX dictionary messages for use in decoding -C data messages stored within MSGS array (in -C COMMON /MSGMEM/) -C -C NDXM = number of DX dictionary messages within MDX -C -C IPDXM(I=1,NDXM) = pointer to first word of (I)th message -C within MDX -C -C NDXTS = number of DX dictionary tables represented by -C messages within MDX -C -C IFDXTS(J=1,NDXTS) = sequential number of first message -C within MDX which is part of (J)th -C dictionary table -C -C ICDXTS(J=1,NDXTS) = count of consecutive messages within MDX -C (beginning with IFDXTS(J)) which -C constitute (J)th dictionary table -C -C IPMSGS(J=1,NDXTS) = sequential number of first data message -C within MSGS array (in COMMON /MSGMEM/) -C to which (J)th dictionary table applies -C -C LDXTS = current dictionary table that is in scope -C (i.e. a number between 1 and NDXTS) -C -C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IUPBS3 -C NMWRD RDMSGW -C THIS ROUTINE IS CALLED BY: UFBMEM -C Not normally called by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET/ IPRT - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - - DIMENSION MBAY(MXMSGLD4) - - CHARACTER*128 ERRSTR - - LOGICAL DONE - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF ( NDXTS .GE. MXDXTS ) GOTO 900 - - ICT = 0 - DONE = .FALSE. - call status(lunit,lun,il,im) - -C Read a complete dictionary table from LUNIT, as a set of one or -C more DX dictionary messages. - - DO WHILE ( .NOT. DONE ) - CALL RDMSGW ( LUNIT, MBAY, IER ) - IF ( IER .EQ. -1 ) THEN - -C Don't abort for an end-of-file condition, since it may be -C possible for a file to end with dictionary messages. -C Instead, backspace the file pointer and let the calling -C routine diagnose the end-of-file condition and deal with -C it as it sees fit. - - call backbufr(lun) - DONE = .TRUE. - ELSE IF ( IER .EQ. -2 ) THEN - GOTO 901 - ELSE IF ( IDXMSG(MBAY) .NE. 1 ) THEN - -C This is a non-DX dictionary message. Assume we've reached -C the end of the dictionary table, and backspace LUNIT so that -C the next read (e.g. in the calling routine) will get this -C same message. - - call backbufr(lun) - DONE = .TRUE. - ELSE IF ( IUPBS3(MBAY,'NSUB') .EQ. 0 ) THEN - -C This is a DX dictionary message, but it doesn't contain any -C actual dictionary information. Assume we've reached the end -C of the dictionary table. - - DONE = .TRUE. - ELSE - -C Store this message into COMMON /MSGMEM/. - - ICT = ICT + 1 - IF ( ( NDXM + ICT ) .GT. MXDXM ) GOTO 902 - IPDXM(NDXM+ICT) = LDXM + 1 - LMEM = NMWRD(MBAY) - IF ( ( LDXM + LMEM ) .GT. MXDXW ) GOTO 903 - DO J = 1, LMEM - MDX(LDXM+J) = MBAY(J) - ENDDO - LDXM = LDXM + LMEM - ENDIF - ENDDO - -C Update the table information within COMMON /MSGMEM/. - - IF ( ICT .GT. 0 ) THEN - IFDXTS(NDXTS+1) = NDXM + 1 - ICDXTS(NDXTS+1) = ICT - IPMSGS(NDXTS+1) = MSGP(0) + 1 - NDXM = NDXM + ICT - NDXTS = NDXTS + 1 - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A)') - . 'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', NDXTS, - . ' CONSISTING OF ', ICT, ' MESSAGES' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ENDIF - - RETURN - 900 CALL BORT('BUFRLIB: CPDXMM - MXDXTS OVERFLOW') - 901 CALL BORT('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR') - 902 CALL BORT('BUFRLIB: CPDXMM - MXDXM OVERFLOW') - 903 CALL BORT('BUFRLIB: CPDXMM - MXDXW OVERFLOW') - END diff --git a/src/bufr/cpymem.f b/src/bufr/cpymem.f deleted file mode 100644 index c5151515c4..0000000000 --- a/src/bufr/cpymem.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE CPYMEM(LUNOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CPYMEM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM -C INTERNAL MEMORY, STORED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE UFBMEM, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT VIA A -C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. THE -C MESSAGE COPIED FROM INTERNAL MEMORY WILL BE THE ONE MOST RECENTLY -C READ INTO THE MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/) -C USING BUFR ARCHIVE LIBRARY SUBROUTINE RDMEMM OR READMM. THE OUTPUT -C FILE MUST HAVE NO CURENTLY OPEN MESSAGES. ALSO, THE INTERNAL BUFR -C TABLES ASSOCIATED WITH THE INPUT MESSAGE MUST BE IDENTICAL TO THE -C BUFR TABLES USED TO OPEN LUNOT TO THE BUFR INTERFACE. THIS -C SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE COPYMG -C EXCEPT THE INPUT MESSAGE IS FROM INTERNAL MEMORY NOT FROM A -C PHYSICAL BUFR FILE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2005-11-29 J. ATOR -- USE IUPBS01 -C 2009-06-26 J. ATOR -- USE IOK2CPY -C -C USAGE: CALL CPYMEM (LUNOT) -C INPUT ARGUMENT LIST: -C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IOK2CPY IUPBS01 MSGWRT -C NEMTBA STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*8 SUBSET - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUSES -C ----------------------- - - CALL STATUS(MUNIT,LIN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - - CALL STATUS(LUNOT,LOT,IL,IM) - IF(IL.EQ.0) GOTO 903 - IF(IL.LT.0) GOTO 904 - IF(IM.NE.0) GOTO 905 - -C MAKE SURE BOTH FILES HAVE THE SAME TABLES -C ----------------------------------------- - - SUBSET = TAG(INODE(LIN)) -c .... Given SUBSET, returns MTYP,MSBT,INOD - CALL NEMTBA(LOT,SUBSET,MTYP,MSBT,INOD) - IF(INODE(LIN).NE.INOD) THEN - IF(IOK2CPY(LIN,LOT).NE.1) GOTO 906 - ENDIF - -C EVERYTHING OKAY, COPY A MESSAGE -C ------------------------------- - - MBYM = IUPBS01(MBAY(1,LIN),'LENM') - CALL MSGWRT(LUNOT,MBAY(1,LIN),MBYM) - -C SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT -C ----------------------------------------------------------------- - - NMSG (LOT) = NMSG(LOT) + 1 - NSUB (LOT) = MSUB(LIN) - MSUB (LOT) = MSUB(LIN) - IDATE(LOT) = IDATE(LIN) - INODE(LOT) = INOD - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: CPYMEM - LOGICAL UNIT NO. ASSOC. WITH INPUT'// - . ' BUFR MESSAGES IN INTERNAL MEMORY IS CLOSED, IT MUST BE OPEN '// - . 'FOR INPUT') -901 CALL BORT('BUFRLIB: CPYMEM - LOGICAL UNIT NO. ASSOC. WITH INPUT'// - . ' BUFR MESSAGES IN INTERNAL MEMORY OPEN FOR OUTPUT, MUST BE '// - . ' OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE') -903 CALL BORT('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -904 CALL BORT('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -905 CALL BORT('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN '// - . 'OUTPUT BUFR FILE, A MESSAGE IS OPEN') -906 CALL BORT('BUFRLIB: CPYMEM - INPUT BUFR MESSAGES IN INTERNAL '// - . 'MEMORY AND OUTPUT BUFR FILE MUST HAVE SAME INTERNAL TABLES '// - . '(DIFFERENT HERE)') - - END diff --git a/src/bufr/cpyupd.f b/src/bufr/cpyupd.f deleted file mode 100644 index 4faf788ed3..0000000000 --- a/src/bufr/cpyupd.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE CPYUPD(LUNIT,LIN,LUN,IBYT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CPYUPD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A SUBSET FROM ONE MESSAGE BUFFER -C (ARRAY MBAY IN COMMON BLOCK /BITBUF/) TO ANOTHER AND/OR RESETS THE -C POINTERS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- USE MSGFULL -C -C USAGE: CALL CPYUPD (LUNIT, LIN, LUN, IBYT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LIN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR INPUT MESSAGE LOCATION -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR OUTPUT MESSAGE LOCATION -C IBYT - INTEGER: NUMBER OF BYTES OCCUPIED BY THIS SUBSET -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IUPB MSGFULL MSGINI -C MSGWRT MVB PKB -C THIS ROUTINE IS CALLED BY: COPYSB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - CHARACTER*128 BORT_STR - - LOGICAL MSGFULL - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C SEE IF THE NEW SUBSET FITS -C -------------------------- - - IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) THEN - CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) - CALL MSGINI(LUN) - ENDIF - - IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) GOTO 900 - -C TRANSFER SUBSET FROM ONE MESSAGE TO THE OTHER -C --------------------------------------------- - -C Note that we want to append the data for this subset to the end -C of Section 4, but the value in MBYT(LUN) already includes the -C length of Section 5 (i.e. 4 bytes). Therefore, we need to begin -C writing at the point 3 bytes prior to the byte currently pointed -C to by MBYT(LUN). - - CALL MVB(MBAY(1,LIN),MBYT(LIN)+1,MBAY(1,LUN),MBYT(LUN)-3,IBYT) - -C UPDATE THE SUBSET AND BYTE COUNTERS -C -------------------------------------- - - MBYT(LUN) = MBYT(LUN) + IBYT - NSUB(LUN) = NSUB(LUN) + 1 - - LBIT = (NBY0+NBY1+NBY2+4)*8 - CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT) - - LBYT = NBY0+NBY1+NBY2+NBY3 - NBYT = IUPB(MBAY(1,LUN),LBYT+1,24) - LBIT = LBYT*8 - CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT) - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: CPYUPD - THE LENGTH OF THIS SUBSET '// - . 'EXCEEDS THE MAXIMUM MESSAGE LENGTH (",I6,")")') MAXBYT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/crbmg.c b/src/bufr/crbmg.c deleted file mode 100644 index 4633a501b2..0000000000 --- a/src/bufr/crbmg.c +++ /dev/null @@ -1,150 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CRBMG -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS ROUTINE READS THE NEXT BUFR MESSAGE FROM THE SYSTEM -C FILE MOST RECENTLY OPENED FOR READING/INPUT VIA BUFR ARCHIVE LIBRARY -C ROUTINE COBFL. ANY BUFR EDITION 0 OR EDITION 1 MESSAGES THAT ARE -C READ ARE AUTOMATICALLY CONVERTED TO BUFR EDITION 2. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL CRBMG( BMG, MXMB, NMB, IRET ) -C INPUT ARGUMENT LIST: -C MXMB - INTEGER: DIMENSIONED SIZE (IN BYTES) OF BMG; USED -C BY THE ROUTINE TO ENSURE THAT IT DOES NOT OVERFLOW -C THE BMG ARRAY -C -C OUTPUT ARGUMENT LIST: -C BMG - CHARACTER*1: ARRAY CONTAINING BUFR MESSAGE -C NMB - INTEGER: SIZE (IN BYTES) OF BUFR MESSAGE IN BMG -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C 1 = overflow of BMG array -C 2 = "7777" indicator not found in expected location -C -1 = end-of-file encountered while reading -C -2 = I/O error encountered while reading -C -C REMARKS: -C THIS ROUTINE CALLS: BORT GETS1LOC ICHKSTR IPKM -C IUPBS01 IUPM RBYTES -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) -{ - f77int i1 = 1, i2 = 2, i3 = 3, i4 = 4, i24 = 24; - f77int wkint[2]; - f77int iben, isbyt, iwid; - - char errstr[129]; - - unsigned short i, nsecs; - unsigned int lsec; -/* -** Make sure that a file is open for reading. -*/ - if ( pbf[0] == NULL ) { - sprintf( errstr, "BUFRLIB: CRBMG - NO FILE IS OPEN FOR READING" ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } -/* -** Initialize the first 4 characters of the output array to blanks. -*/ - if ( *mxmb < 4 ) { - *iret = 1; - return; - } - strncpy( bmg, " ", 4); -/* -** Look for the start of the next BUFR message. -*/ - while ( ichkstr( "BUFR", bmg, &i4, 4, 4 ) != 0 ) { - memmove( bmg, &bmg[1], 3 ); - if ( ( *iret = rbytes( bmg, mxmb, 3, 1 ) ) != 0 ) return; - } -/* -** Read the next 4 bytes and determine the BUFR edition number that was used -** to encode the message. -*/ - if ( ( *iret = rbytes( bmg, mxmb, 4, 4 ) ) != 0 ) return; - memcpy( wkint, bmg, 8 ); - iben = iupbs01( wkint, "BEN", 3 ); - - if ( iben >= 2 ) { -/* -** Get the length of the BUFR message. -*/ - *nmb = iupbs01( wkint, "LENM", 4 ); -/* -** Read the remainder of the BUFR message. -*/ - if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; - } - else { -/* -** Read the remainder of the BUFR message and then convert it to BUFR -** edition 2. The message length isn't encoded in Section 0, so we need -** to compute it by unpacking and summing the lengths of the individual -** sections. -*/ - lsec = 4; /* length of Section 0 */ -/* -** Get the length of Section 1 and add it to the total. -*/ - gets1loc( "LEN1", &iben, &isbyt, &iwid, &wkint[0], 4 ); - *nmb = lsec + iupm( &bmg[lsec+isbyt-1], &iwid, 3 ); -/* -** Read up through the end of Section 1. -*/ - if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; -/* -** Is there a Section 2? -*/ - gets1loc( "ISC2", &iben, &isbyt, &iwid, &wkint[0], 4 ); - nsecs = iupm( &bmg[lsec+isbyt-1], &iwid, 1 ) + 2; -/* -** Read up through the end of Section 4. -*/ - for ( i = 1; i <= nsecs; i++ ) { - if ( ( *iret = rbytes( bmg, mxmb, *nmb, 3 ) ) != 0 ) return; - lsec = iupm( &bmg[*nmb], &i24, 3 ); - if ( ( *iret = rbytes( bmg, mxmb, *nmb+3, lsec-3 ) ) != 0 ) return; - *nmb += lsec; - } -/* -** Read Section 5. -*/ - if ( ( *iret = rbytes( bmg, mxmb, *nmb, 4 ) ) != 0 ) return; - *nmb += 4; -/* -** Expand Section 0 from 4 bytes to 8 bytes, then encode the message length -** and new edition number (i.e. 2) into the new (expanded) Section 0. -*/ - if ( *nmb + 4 > *mxmb ) { - *iret = 1; - return; - } - memmove( &bmg[8], &bmg[4], *nmb-4 ); - *nmb += 4; - ipkm( &bmg[4], &i3, nmb, 3 ); - ipkm( &bmg[7], &i1, &i2, 1 ); - } -/* -** Check that the "7777" is in the expected location. -*/ - *iret = ( ( ichkstr( "7777", &bmg[*nmb-4], &i4, 4, 4 ) == 0 ) ? 0 : 2 ); - - return; -} diff --git a/src/bufr/cread.c b/src/bufr/cread.c deleted file mode 100644 index ed2f05088e..0000000000 --- a/src/bufr/cread.c +++ /dev/null @@ -1,94 +0,0 @@ -/*C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CREAD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 -C -C ABSTRACT: CREAD IS A PACKAGE OF C LANGUAGE I/O ROUTINES WHICH -C ARE DESIGNED TO OPERATE BUFRLIB INPUT AND OUTPUT -C FUNCTIONS IN A LESS RESTRICTIVE WAY COMPARED TO -C THOSE AVAILABLE IN STANDARD FORTRAN IMPLEMENTATIONS. -C THE PACKAGE CONSISTS OF THREE FILE OPEN ROUTINES, -C ONE FILE CLOSE ROUTINE, TWO FILE POSITIONING -C ROUTINES, ONE READ BUFR AND ONE WRITE BUFR ROUTINE. -C ARRAYS OF FILE CONNECTION DESCRIPTORS AND FILE -C POSITION POINTERS PROVIDE THE CONNECTION TO THE -C BUFRLIB INTERNAL FILE STATUS INDICATORS. THE -C BUFRLIB FILE CONNECTION INDEX LUN, OBTAINED BY -C CALLS TO STATUS, IS USED TO REFERENCE THE CREAD -C DESCRIPTOR AND POINTER ARRAYS. -C -C PROGRAM HISTORY LOG: -C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR -C -C USAGE: CALL openrb(nfile,ufile) - open ufile for binary reading -C CALL openwb(nfile,ufile) - open ufile for binary writing -C CALL openab(nfile,ufile) - open ufile for binary appending -C CALL backbufr(nfile) - backspace file nfile 1 message -C CALL cewind(nfile) - rewind file nfile to beginning -C CALL closfb(nfile) - disconnect file nfile from c -C CALL crdbufr(nfile,bufr,maxbyt) - read next bufr message from file nfile into bufr -C CALL cwrbufr(nfile,bufr,nwrd) - write bufr message from bufr into file nfile -C -C INPUT ARGUMENTS: -c nfile - integer bufrlib file connection index -C ufile - full file path/filename -c bufr - in crdbufr: char array to read a bufr message into -c maxbyt - in crdbufr: maximum number of bytes allowed to read -c bufr - in cwrbufr: integer array to write a bufr message from -c nwrd - in cwrbufr: number of words to write for bufr message -C -C OUTPUT ARGUMENTS: -c crdbufr - return code from reading -c -3 - sec0 message length > maxbyt -c -2 - error reading bufr message -c -1 - no more more messages in file -c 0 - read a bufr message -C -C REMARKS: -C THIS ROUTINE CALLS: IUPBS01 -C -C THIS ROUTINE IS CALLED BY: -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -/* The following arrays are dimensioned one larger than NFILES because of the difference in array - indexing between Fortran and C. In each of the following C functions, the value passed in for - nfile will a be Fortran index ranging from 1 to NFILES, so we need to allow for this same range - of values in C, which would otherwise expect the array indices to range from 0 to NFILES-1. */ -FILE *pb[NFILES+1]; fpos_t lstpos[NFILES+1]; - -void openrb (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "rb " ); } -void openwb (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "wb " ); } -void openab (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "a+b" ); } -void backbufr (nfile ) f77int *nfile; { fsetpos(pb[*nfile],&lstpos[*nfile]);} -void cewind (nfile ) f77int *nfile; { rewind(pb[*nfile]); } -void closfb (nfile ) f77int *nfile; { fclose(pb[*nfile]); } - -f77int crdbufr (nfile,bufr,mxbyt) -f77int *nfile; f77int *mxbyt; char *bufr; -{ f77int nbyt; f77int nb; f77int wkint[2]; fpos_t nxtpos; - fgetpos(pb[*nfile],&lstpos[*nfile]); - nb = sizeof(*bufr); bufr[0]=bufr[1]; - while ( strncmp(bufr,"BUFR",4)!=0) - { memmove(bufr,&bufr[1],3); - if(fread(bufr+3,nb,1,pb[*nfile])!=1) return -1; - } - fgetpos(pb[*nfile],&nxtpos); if(fread(bufr+4,nb,4,pb[*nfile])!=4) return -1; - memcpy(wkint,bufr,8); nbyt=iupbs01(wkint,"LENM",4)-8; - if(nbyt+8>*mxbyt) {fsetpos(pb[*nfile],&nxtpos);return -3;}; - if(fread(bufr+8,nb,nbyt,pb[*nfile])!=nbyt) {fsetpos(pb[*nfile],&nxtpos);return -2;}; - if(strncmp(bufr+nbyt+4,"7777",4)!=0) {fsetpos(pb[*nfile],&nxtpos);return -2;}; - return 0; -} - -void cwrbufr (nfile,bufr,nwrd) -f77int *nfile; f77int *nwrd; f77int *bufr; -{ f77int nb; nb = sizeof(*bufr); - fwrite(bufr,nb,*nwrd,pb[*nfile]); -} diff --git a/src/bufr/cwbmg.c b/src/bufr/cwbmg.c deleted file mode 100644 index a9c675b8ed..0000000000 --- a/src/bufr/cwbmg.c +++ /dev/null @@ -1,54 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CWBMG -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS ROUTINE WRITES A SPECIFIED NUMBER OF BYTES TO THE -C SYSTEM FILE MOST RECENTLY OPENED FOR WRITING/OUTPUT VIA BUFR -C ARCHIVE LIBRARY ROUTINE COBFL. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL CWBMG( BMG, NMB, IRET ) -C INPUT ARGUMENT LIST: -C BMG - CHARACTER*1: ARRAY CONTAINING BYTES TO BE WRITTEN -C NMB - INTEGER: NUMBER OF BYTES WITHIN BMG TO BE WRITTEN -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = I/O error occurred while writing -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -void cwbmg( char *bmg, f77int *nmb, f77int *iret ) -{ - char errstr[129]; - -/* -** Make sure that a file is open for writing. -*/ - if ( pbf[1] == NULL ) { - sprintf( errstr, "BUFRLIB: CWBMG - NO FILE IS OPEN FOR WRITING" ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } -/* -** Write the BUFR message to the file. -*/ - *iret = ( ( fwrite( bmg, 1, *nmb, pbf[1] ) == *nmb ) ? 0 : -1 ); - - return; -} diff --git a/src/bufr/datebf.f b/src/bufr/datebf.f deleted file mode 100644 index 616528f607..0000000000 --- a/src/bufr/datebf.f +++ /dev/null @@ -1,142 +0,0 @@ - SUBROUTINE DATEBF(LUNIT,MEAR,MMON,MDAY,MOUR,IDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DATEBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST -C NON-DICTIONARY BUFR MESSAGE IN LOGICAL UNIT LUNIT, REGARDLESS OF -C THE NUMBER OF SUBSETS IN THE MESSAGE. LUNIT SHOULD NOT BE -C PREVIOUSLY OPENED TO THE BUFR INTERFACE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 1998-08-31 J. WOOLLEN -- MODIFIED TO CORRECT AN ERROR WHICH LEAD TO -C THE YEAR BEING RETURNED IN "MEAR" AS 2- -C DIGIT YEAR WHEN A 4-DIGIT YEAR WAS -C REQUESTED VIA A PRIOR CALL TO DATELEN (THE -C CENTER DATE RETURNED IN "IDATE", IN THE -C FORM YYYYMMDDHH, WAS CORRECT IN THE -C PREVIOUS VERSION OF THIS ROUTINE -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRCT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC -C FUNCTION ICHAR WITH THE NCEP W3LIB C- -C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK -C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ -C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS -C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER -C USE FLOATING POINT ARITHMETIC SINCE THIS -C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER -C RESULTING DATE ON SOME MACHINES (E.G., NCEP -C IBM FROST/SNOW), INCREASES PORTABILITY; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN -C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY -C TO EBCDIC MACHINES -C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE -C INFORMATION (IN CASE IT HAS NOT YET BEEN -C CALLED), THIS ROUTINE DOES NOT REQUIRE IT -C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES -C THAT DO REQUIRE IT -C 2005-11-29 J. ATOR -- USE IGETDATE, IUPBS01 AND RDMSGW -C 2009-03-23 J. ATOR -- USE IDXMSG AND ERRWRT -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE -C THE C FILE WITHOUT CLOSING THE FORTRAN FILE -C -C -C USAGE: CALL DATEBF (LUNIT, MEAR, MMON, MDAY, MOUR, IDATE) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C MEAR - INTEGER: SECTION 1 YEAR (YYYY OR YY, DEPENDING ON -C DATELEN() VALUE -C MMON - INTEGER: SECTION 1 MONTH MM -C MDAY - INTEGER: SECTION 1 DAY DD -C MOUR - INTEGER: SECTION 1 HOUR HH -C IDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE IN -C FORMAT OF EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON -C DATELEN() VALUE; OR -1 IF SECTION 1 DATE COULD NOT BE -C LOCATED -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE -C RDMSGW STATUS WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET / IPRT - - DIMENSION MBAY(MXMSGLD4) - - CHARACTER*128 ERRSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION -C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) -C --------------------------------------------------------------- - - CALL WRDLEN - - IDATE = -1 - -C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) -C ----------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,JL,JM) - IF(JL.NE.0) GOTO 900 - CALL OPENBF(LUNIT,'INX',LUNIT) - -C READ TO A DATA MESSAGE AND PICK OUT THE DATE -C -------------------------------------------- - -1 CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.LT.0) GOTO 100 - IF(IDXMSG(MBAY).EQ.1) GOTO 1 - - IDATE = IGETDATE(MBAY,MEAR,MMON,MDAY,MOUR) - -100 IF(IPRT.GE.1 .AND. IDATE.EQ.-1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: DATEBF - SECTION 1 DATE COULD NOT BE '// - . 'LOCATED - RETURN WITH IDATE = -1' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXITS -C ----- - - CALL CLOSBF(LUNIT) - RETURN -900 CALL BORT - . ('BUFRLIB: DATEBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') - END diff --git a/src/bufr/datelen.f b/src/bufr/datelen.f deleted file mode 100644 index 0d0a6dcb24..0000000000 --- a/src/bufr/datelen.f +++ /dev/null @@ -1,73 +0,0 @@ - SUBROUTINE DATELEN(LEN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DATELEN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 -C -C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY THE LENGTH OF DATE-TIME -C VALUES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR -C ARCHIVE LIBRARY SUBROUTINES WHICH READ BUFR MESSAGES (E.G. READMG, -C READERME, ETC.). POSSIBLE VALUES ARE "8" (WHICH IS THE DEFAULT) -C AND "10". -C -C PROGRAM HISTORY LOG: -C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN READMG) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE -C INFORMATION (IN CASE IT HAS NOT YET BEEN -C CALLED), THIS ROUTINE DOES NOT REQUIRE IT -C BUT IT MAY SOMEDAY CALL OTHER ROUTINES THAT -C DO REQUIRE IT -C -C USAGE: CALL DATELEN (LEN) -C INPUT ARGUMENT LIST: -C LEN - INTEGER: LENGTH OF DATE-TIME VALUES TO BE OUTPUT BY -C READ SUBROUTINES: * -C 8 = YYMMDDHH (2-digit year) -C 10 = YYYYMMDDHH (4-digit year) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /DATELN/ LENDAT - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION -C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) -C --------------------------------------------------------------- - - CALL WRDLEN - - IF(LEN.NE.8 .AND. LEN.NE.10) GOTO 900 - LENDAT = LEN - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: DATELEN - INPUT ARGUMENT IS",I4," - '// - . 'IT MUST BE EITHER 8 OR 10")') LEN - CALL BORT(BORT_STR) - END diff --git a/src/bufr/digit.f b/src/bufr/digit.f deleted file mode 100644 index 4aa114a250..0000000000 --- a/src/bufr/digit.f +++ /dev/null @@ -1,52 +0,0 @@ - LOGICAL FUNCTION DIGIT(STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DIGIT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS LOGICAL FUNCTION TESTS THE CHARACTERS IN A STRING TO -C DETERMINE IF THEY ARE ALL DIGITS ('0','1','2','3','4','5','6','7', -C '8' OR '9'). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2007-01-19 J. ATOR -- SIMPLIFIED LOGIC -C 2009-03-23 J. ATOR -- FIXED MINOR BUG CAUSED BY TYPO -C -C USAGE: DIGIT (STR) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING -C -C OUTPUT ARGUMENT LIST: -C DIGIT - LOGICAL: TRUE IF ALL CHARACTERS IN STR ARE DIGITS -C ('0' - '9'), OTHERWISE FALSE -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: CKTABA NUMBCK STNTBIA -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - DIGIT = .FALSE. - DO I=1,LEN(STR) - IF( LLT(STR(I:I),'0') .OR. LGT(STR(I:I),'9') ) GOTO 100 - ENDDO - DIGIT = .TRUE. - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/drfini.f b/src/bufr/drfini.f deleted file mode 100644 index fc5be3b35b..0000000000 --- a/src/bufr/drfini.f +++ /dev/null @@ -1,105 +0,0 @@ - SUBROUTINE DRFINI(LUNIT,MDRF,NDRF,DRFTAG) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DRFINI -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE INITIALIZES DELAYED REPLICATION FACTORS -C AND EXPLICITLY ALLOCATES A CORRESPONDING AMOUNT OF SPACE IN THE -C INTERNAL SUBSET ARRAYS, THEREBY ALLOWING THE SUBSEQUENT USE OF BUFR -C ARCHIVE LIBRARY SUBROUTINE UFBSEQ TO WRITE DATA DIRECTLY INTO -C DELAYED REPLICATION SEQUENCES. NOTE THAT THIS SAME TYPE OF -C INITIALIZATION IS DONE IMPLICTLY WITHIN BUFR ARCHIVE LIBRARY -C SUBROUTINE UFBINT FOR DELAYED REPLICATION SEQUENCES WHICH APPEAR -C ONLY ONE TIME WITHIN AN OVERALL SUBSET DEFINITION. HOWEVER, BY -C USING SUBROUTINE DRFINI ALONG WITH A SUBSEQUENT CALL TO SUBROUTINE -C UFBSEQ, IT IS ACTUALLY POSSIBLE TO HAVE MULTIPLE OCCURRENCES OF A -C PARTICULAR DELAYED REPLICATION SEQUENCE WITHIN A SINGLE OVERALL -C SUBSET DEFINITION. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2005-03-04 J. ATOR -- UPDATED DOCUMENTATION -C -C USAGE: CALL DRFINI (LUNIT, MDRF, NDRF, DRFTAG) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C MDRF - INTEGER: ARRAY OF DELAYED REPLICATION FACTORS, -C IN ONE-TO-ONE CORRESPONDENCE WITH THE NUMBER OF -C OCCURRENCES OF DRFTAG WITHIN THE OVERALL SUBSET -C DEFINITION, AND EXPLICITLY DEFINING HOW MUCH SPACE -C (I.E. HOW MANY REPLICATIONS) TO ALLOCATE WITHIN -C EACH SUCCESSIVE OCCURRENCE -C NDRF - INTEGER: NUMBER OF DELAYED REPLICATION FACTORS -C WITHIN MDRF -C DRFTAG - CHARACTER*(*): SEQUENCE MNEMONIC, BRACKETED BY -C APPROPRIATE DELAYED REPLICATION NOTATION -C (E.G. {}, () OR <>) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT STATUS USRTPL -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*(*) DRFTAG - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*3 TYP - REAL*8 VAL - DIMENSION MDRF(NDRF) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(NDRF.GT.100) GOTO 900 - - CALL STATUS(LUNIT,LUN,IL,IM) - -C COMFORM THE TEMPLATES TO THE DELAYED REPLICATION FACTORS -C -------------------------------------------------------- - - M = 0 - N = 0 - -10 DO N=N+1,NVAL(LUN) - NODE = INV(N,LUN) - IF(ITP(NODE).EQ.1 .AND. TAG(NODE).EQ.DRFTAG) THEN - M = M+1 - CALL USRTPL(LUN,N,MDRF(M)) - GOTO 10 - ENDIF - ENDDO - -C EXITS -C ----- - - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: DRFINI - THE NUMBER OF DELAYED '// - . 'REPLICATION FACTORS (",I5,") EXCEEDS THE LIMIT (100)")') NDRF - CALL BORT(BORT_STR) - END diff --git a/src/bufr/drstpl.f b/src/bufr/drstpl.f deleted file mode 100644 index 0265a1a8e1..0000000000 --- a/src/bufr/drstpl.f +++ /dev/null @@ -1,99 +0,0 @@ - SUBROUTINE DRSTPL(INOD,LUN,INV1,INV2,INVN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DRSTPL -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE IS CALLED BY BUFR ARCHIVE LIBRARY SUBROUTINE -C UFBRW WHENEVER IT CAN'T FIND A MNEMONIC IT WANTS TO WRITE WITHIN THE -C CURRENT SUBSET BUFFER. IT LOOKS FOR THE MNEMONIC WITHIN ANY -C UNEXPANDED "DRS" (STACK) OR "DRB" (1-BIT DELAYED REPLICATION) -C SEQUENCES INSIDE OF THE PORTION OF THE SUBSET BUFFER BOUNDED BY THE -C INDICES INV1 AND INV2. IF FOUND, IT EXPANDS THE APPLICABLE "DRS" OR -C "DRB" SEQUENCE TO THE POINT WHERE THE MNEMONIC IN QUESTION NOW -C APPEARS IN THE SUBSET BUFFER, AND IN DOING SO IT WILL ALSO RETURN -C A NEW VALUE FOR INV2. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" (LATER REMOVED, UNKNOWN -C WHEN) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION -C -C USAGE: CALL DRSTPL (INOD, LUN, INV1, INV2, INVN) -C -C INPUT ARGUMENT LIST: -C INOD - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET -C BUFFER CURRENTLY BEING PROCESSED BY UFBRW -C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET -C BUFFER CURRENTLY BEING PROCESSED BY UFBRW -C -C OUTPUT ARGUMENT LIST: -C INVN - INTEGER: LOCATION INDEX OF INOD WITHIN SUBSET BUFFER: -C 0 = NOT FOUND -C INV2 - INTEGER: IF INVN = 0, THEN INV2 IS UNCHANGED FROM ITS -C INPUT VALUE. OTHERWISE, IT CONTAINS THE REDEFINED -C ENDING INDEX OF THE PORTION OF THE SUBSET BUFFER -C CURRENTLY BEING PROCESSED BY UFBRW, SINCE EXPANDING A -C DELAYED REPLICATION SEQUENCE WILL HAVE NECESSARILY -C INCREASED THE SIZE OF THIS BUFFER. -C -C REMARKS: -C THIS ROUTINE CALLS: INVWIN NEWWIN USRTPL -C THIS ROUTINE IS CALLED BY: UFBRW -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -1 NODE = INOD -2 NODE = JMPB(NODE) - IF(NODE.EQ.0) GOTO 100 - IF(TYP(NODE).EQ.'DRS' .OR. TYP(NODE).EQ.'DRB') THEN - INVN = INVWIN(NODE,LUN,INV1,INV2) - IF(INVN.GT.0) THEN - CALL USRTPL(LUN,INVN,1) - CALL NEWWIN(LUN,INV1,INV2) - INVN = INVWIN(INOD,LUN,INVN,INV2) - IF(INVN.GT.0) GOTO 100 - GOTO 1 - ENDIF - ENDIF - GOTO 2 - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/dumpbf.f b/src/bufr/dumpbf.f deleted file mode 100644 index ba2a318de3..0000000000 --- a/src/bufr/dumpbf.f +++ /dev/null @@ -1,174 +0,0 @@ - SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DUMPBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-12-11 -C -C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST -C TWO NON-DICTIONARY BUFR MESSAGES IN LOGICAL UNIT LUNIT WHICH -C CONTAIN ZERO SUBSETS. NORMALLY, THESE "DUMMY" MESSAGES APPEAR -C ONLY IN DATA DUMP FILES AND ARE IMMEDIATELY AFTER THE DICTIONARY -C MESSAGES. THEY CONTAIN A DUMP "CENTER TIME" AND A DUMP FILE -C "PROCESSING TIME", RESPECTIVELY. LUNIT SHOULD NOT BE PREVIOUSLY -C OPENED TO THE BUFR INTERFACE. -C -C PROGRAM HISTORY LOG: -C 1996-12-11 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-12-17 J. WOOLLEN -- CORRECTED ERROR IN DUMP DATE READER -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC -C FUNCTION ICHAR WITH THE NCEP W3LIB C- -C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK -C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ -C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS -C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER -C USE FLOATING POINT ARITHMETIC SINCE THIS -C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER -C RESULTING DATE ON SOME MACHINES (E.G., NCEP -C IBM FROST/SNOW), INCREASES PORTABILITY; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN -C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY -C TO EBCDIC MACHINES -C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE -C INFORMATION (IN CASE IT HAS NOT YET BEEN -C CALLED), THIS ROUTINE DOES NOT REQUIRE IT -C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES -C THAT DO REQUIRE IT -C 2005-11-29 J. ATOR -- USE IUPBS01, IGETDATE, GETLENS AND RDMSGW -C 2009-03-23 J. ATOR -- USE IDXMSG, IUPBS3 AND ERRWRT -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE -C THE C FILE WITHOUT CLOSING THE FORTRAN FILE -C -C USAGE: CALL DUMPBF (LUNIT, JDATE, JDUMP) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C JDATE - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR -C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), -C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE -C FIRST NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS -C (NORMALLY THE DATA DUMP CENTER TIME IN A DATA DUMP -C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED -C JDUMP - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR -C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), -C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE -C SECOND NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS -C (NORMALLY THE FILE PROCESSING TIME IN A DATA DUMP -C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE -C IUPBS01 IUPBS3 RDMSGW STATUS -C WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET / IPRT - - DIMENSION MBAY(MXMSGLD4) - DIMENSION JDATE(5),JDUMP(5) - - CHARACTER*128 ERRSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION -C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) -C --------------------------------------------------------------- - - CALL WRDLEN - - DO I=1,5 - JDATE(I) = -1 - JDUMP(I) = -1 - ENDDO - -C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) -C ----------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,JL,JM) - IF(JL.NE.0) GOTO 900 - call openbf(lunit,'INX',lunit) - -C READ PAST ANY DICTIONARY MESSAGES -C --------------------------------- - -1 CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.LT.0) GOTO 200 - IF(IDXMSG(MBAY).EQ.1) GOTO 1 - -C DUMP CENTER YY,MM,DD,HH,MM IS IN THE FIRST EMPTY MESSAGE -C -------------------------------------------------------- -C i.e. the first message containing zero subsets - - IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200 - - IGD = IGETDATE(MBAY,JDATE(1),JDATE(2),JDATE(3),JDATE(4)) - JDATE(5) = IUPBS01(MBAY,'MINU') - -C DUMP CLOCK YY,MM,DD,HH,MM IS IN THE SECOND EMPTY MESSAGE -C -------------------------------------------------------- -C i.e. the second message containing zero subsets - - CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.LT.0) GOTO 200 - - IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200 - - IGD = IGETDATE(MBAY,JDUMP(1),JDUMP(2),JDUMP(3),JDUMP(4)) - JDUMP(5) = IUPBS01(MBAY,'MINU') - - call closbf(lunit) - GOTO 100 - -200 IF(IPRT.GE.1 .AND. (JDATE(1).EQ.-1.OR.JDUMP(1).EQ.-1)) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - IF(JDATE(1).EQ.-1) THEN - ERRSTR = 'BUFRLIB: DUMPBF - FIRST EMPTY BUFR MESSAGE '// - . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// - . 'JDATE = 4*-1' - CALL ERRWRT(ERRSTR) - ENDIF - IF(JDUMP(1).EQ.-1) THEN - ERRSTR = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE '// - . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// - . 'JDUMP = 4*-1' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT - . ('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') - END diff --git a/src/bufr/dxdump.f b/src/bufr/dxdump.f deleted file mode 100644 index 675e2c0514..0000000000 --- a/src/bufr/dxdump.f +++ /dev/null @@ -1,334 +0,0 @@ - SUBROUTINE DXDUMP(LUNIT,LDXOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DXDUMP -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: THIS SUBROUTINE WRITES, TO LOGICAL UNIT LDXOT, AN ASCII -C COPY OF THE BUFR DICTIONARY TABLE INFORMATION ASSOCIATED WITH -C THE BUFR FILE DEFINED BY LOGICAL UNIT LUNIT. IT IS ESPECIALLY -C USEFUL FOR DETERMINING THE CONTENTS OF ARCHIVE BUFR FILES WHICH -C MAY HAVE SUCH INFORMATION EMBEDDED AS DX MESSAGES AT THE FRONT -C OF THE FILE. THE OUTPUT FILE WILL BE IN A FORMAT SUITABLE FOR -C SUBSEQUENT INPUT AS A USER-DEFINED DICTIONARY TABLES FILE TO -C BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND IN THAT SENSE THIS -C SUBROUTINE CAN BE VIEWED AS THE LOGICAL INVERSE OF BUFR ARCHIVE -C LIBRARY SUBROUTINE RDUSDX. NOTE THAT THE BUFR FILE ASSOCIATED -C WITH LOGICAL UNIT LUNIT MUST HAVE ALREADY BEEN IDENTIFIED TO -C THE BUFR ARCHIVE LIBRARY SOFTWARE VIA A PRIOR CALL TO OPENBF. -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C 2007-01-19 J. ATOR -- CORRECTED OUTPUT FOR REFERENCE VALUES -C LONGER THAN 8 DIGITS -C -C USAGE: CALL DXDUMP (LUNIT, LDXOT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LDXOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT FILE -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE WITH EMBEDDED DX DICTIONARY MESSAGES -C -C OUTPUT FILES: -C UNIT "LDXOT" - ASCII VERSION OF DX DICTIONARY INFORMATION, IN -C FORMAT SUITABLE FOR SUBSEQUENT INPUT TO OPENBF -C -C REMARKS: -C THIS ROUTINE CALLS: BORT NEMTBD STATUS STRSUC -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*80 CARD,CARDI1,CARDI2,CARDI3,CARDI4 - CHARACTER*20 CMSTR - CHARACTER*10 WRK3 - CHARACTER*8 NEMS(MAXCD),WRK1,WRK2 - CHARACTER*6 ADN - CHARACTER*3 TYPS - CHARACTER*1 REPS - - DIMENSION IRPS(MAXCD),KNTS(MAXCD) - - LOGICAL TBSKIP, TDSKIP, XTRCI1 - - DATA CARDI1( 1:40) - . /'| | | '/ - DATA CARDI1(41:80) - . /' |'/ - DATA CARDI2( 1:40) - . /'| | '/ - DATA CARDI2(41:80) - . /' |'/ - DATA CARDI3( 1:40) - . /'| | | | | '/ - DATA CARDI3(41:80) - . /' |-------------|'/ - DATA CARDI4( 1:40) - . /'|---------------------------------------'/ - DATA CARDI4(41:80) - . /'---------------------------------------|'/ - -C----------------------------------------------------------------------- - TBSKIP(ADN) = ((ADN.EQ.'063000').OR.(ADN.EQ.'063255').OR. - . (ADN.EQ.'031000').OR.(ADN.EQ.'031001').OR. - . (ADN.EQ.'031002')) - TDSKIP(ADN) = ((ADN.EQ.'360001').OR.(ADN.EQ.'360002').OR. - . (ADN.EQ.'360003').OR.(ADN.EQ.'360004')) -C----------------------------------------------------------------------- - -C DETERMINE LUN FROM LUNIT. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - -C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE -C DESCRIPTOR DEFINITION SECTION. - - CARD=CARDI4 - CARD( 1: 1)='.' - CARD(80:80)='.' - WRITE (LDXOT,'(A)') CARD - - CARD=CARDI4 - CARD( 2: 2)=' ' - CARD(79:79)=' ' - CARD(15:64)=' USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D ' - WRITE (LDXOT,'(A)') CARD - - WRITE (LDXOT,'(A)') CARDI4 - - CARD=CARDI1 - CARD( 3:10)='MNEMONIC' - CARD(14:19)='NUMBER' - CARD(23:33)='DESCRIPTION' - WRITE (LDXOT,'(A)') CARD - - CARD=CARDI4 - CARD(12:12)='|' - CARD(21:21)='|' - WRITE (LDXOT,'(A)') CARD - -C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR -C DEFINITION CARDS. - - WRITE (LDXOT,'(A)') CARDI1 - - XTRCI1=.FALSE. - DO N=1,NTBD(LUN) - IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN - CARD=CARDI1 - CARD( 3:10)=TABD(N,LUN)( 7:14) - CARD(14:19)=TABD(N,LUN)( 1: 6) - CARD(23:77)=TABD(N,LUN)(16:70) - -C CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC. -C IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE -C LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA -C CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE -C THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS. - - DO NA=1,NTBA(LUN) - IF(TABA(NA,LUN)(4:11).EQ.TABD(N,LUN)(7:14)) THEN - CARD(14:14)='A' - IF(NA.EQ.NTBA(LUN)) XTRCI1=.TRUE. - GOTO 10 - END IF - END DO - 10 WRITE (LDXOT,'(A)') CARD - IF(XTRCI1) THEN - WRITE (LDXOT,'(A)') CARDI1 - XTRCI1=.FALSE. - END IF - END IF - END DO - -C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR -C DEFINITION CARDS. - - WRITE (LDXOT,'(A)') CARDI1 - - DO N=1,NTBB(LUN) - IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN - CARD=CARDI1 - CARD( 3:10)=TABB(N,LUN)( 7:14) - CARD(14:19)=TABB(N,LUN)( 1: 6) - CARD(23:77)=TABB(N,LUN)(16:70) - WRITE (LDXOT,'(A)') CARD - END IF - END DO - - WRITE (LDXOT,'(A)') CARDI1 - -C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE -C SEQUENCE DEFINITION SECTION. - - WRITE (LDXOT,'(A)') CARDI4 - - CARD=CARDI2 - CARD( 3:10)='MNEMONIC' - CARD(14:21)='SEQUENCE' - WRITE (LDXOT,'(A)') CARD - - CARD=CARDI4 - CARD(12:12)='|' - WRITE (LDXOT,'(A)') CARD - -C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE -C DEFINITION CARDS. - - WRITE (LDXOT,'(A)') CARDI2 - - DO N=1,NTBD(LUN) - IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN - CARD=CARDI2 - CARD( 3:10)=TABD(N,LUN)( 7:14) - IC = 14 - -C GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR, -C AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO -C THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR. - - CALL NEMTBD(LUN,N,NSEQ,NEMS,IRPS,KNTS) - IF(NSEQ.GT.0) THEN - DO NC=1,NSEQ - CMSTR=' ' - ICMS=0 - CALL STRSUC(NEMS(NC),WRK2,NCH) - IF(IRPS(NC).NE.0) THEN - -C ADD THE OPENING REPLICATION TAG. - - ICMS=ICMS+1 - CMSTR(ICMS:ICMS)=REPS(IRPS(NC),1) - END IF - CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH) - ICMS=ICMS+NCH - IF(IRPS(NC).NE.0) THEN - -C ADD THE CLOSING REPLICATION TAG. - - ICMS=ICMS+1 - CMSTR(ICMS:ICMS)=REPS(IRPS(NC),2) - END IF - IF(KNTS(NC).NE.0) THEN - -C ADD THE FIXED REPLICATION COUNT. - - WRK1=' ' - WRITE (WRK1,'(I3)') KNTS(NC) - CALL STRSUC(WRK1,WRK2,NCH) - CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH) - ICMS=ICMS+NCH - END IF - -C WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT -C INTO THE CURRENT SEQUENCE DEFINITION CARD? IF NOT, THEN -C WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A -C NEW ONE TO HOLD THIS CHILD. - - IF(IC.GT.(79-ICMS)) THEN - WRITE (LDXOT,'(A)') CARD - CARD=CARDI2 - CARD( 3:10)=TABD(N,LUN)( 7:14) - IC = 14 - END IF - CARD(IC:IC+ICMS-1)=CMSTR(1:ICMS) - -C NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH -C CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE -C READABILITY). - - IC=IC+ICMS+2 - END DO - WRITE (LDXOT,'(A)') CARD - WRITE (LDXOT,'(A)') CARDI2 - END IF - END IF - END DO - -C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE -C ELEMENT DEFINITION SECTION. - - WRITE (LDXOT,'(A)') CARDI4 - - CARD=CARDI3 - CARD( 3:10)='MNEMONIC' - CARD(14:17)='SCAL' - CARD(21:29)='REFERENCE' - CARD(35:37)='BIT' - CARD(41:45)='UNITS' - WRITE (LDXOT,'(A)') CARD - - CARD=CARDI4 - CARD(12:12)='|' - CARD(19:19)='|' - CARD(33:33)='|' - CARD(39:39)='|' - CARD(66:66)='|' - WRITE (LDXOT,'(A)') CARD - -C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT -C DEFINITION CARDS. - - WRITE (LDXOT,'(A)') CARDI3 - - DO N=1,NTBB(LUN) - IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN - CARD=CARDI3 - CARD( 3:10)=TABB(N,LUN)( 7:14) - CARD(41:64)=TABB(N,LUN)(71:94) - -C ADD THE SCALE FACTOR. - - CALL STRSUC(TABB(N,LUN)(96:98),WRK2,NCH) - CARD(17-NCH+1:17)=WRK2 - IF(TABB(N,LUN)(95:95).EQ.'-') CARD(17-NCH:17-NCH)='-' - -C ADD THE REFERENCE VALUE. - - CALL STRSUC(TABB(N,LUN)(100:109),WRK3,NCH) - CARD(31-NCH+1:31)=WRK3 - IF(TABB(N,LUN)(99:99).EQ.'-') CARD(31-NCH:31-NCH)='-' - -C ADD THE BIT WIDTH. - - CALL STRSUC(TABB(N,LUN)(110:112),WRK2,NCH) - CARD(37-NCH+1:37)=WRK2 - WRITE (LDXOT,'(A)') CARD - END IF - END DO - - WRITE (LDXOT,'(A)') CARDI3 - -C CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD. - - CARD=CARDI4 - CARD( 1: 1)='`' - CARD(80:80)='''' - WRITE (LDXOT,'(A)') CARD - - RETURN -900 CALL BORT('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') - - END diff --git a/src/bufr/dxinit.f b/src/bufr/dxinit.f deleted file mode 100644 index 371dec6558..0000000000 --- a/src/bufr/dxinit.f +++ /dev/null @@ -1,141 +0,0 @@ - SUBROUTINE DXINIT(LUN,IOI) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DXINIT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE INITIALIZES THE INTERNAL ARRAYS -C (COMMON BLOCK /TABABD/) HOLDING THE DICTIONARY TABLE. IT THEN -C INITIALIZES THE TABLE WITH APRIORI TABLE B AND D ENTRIES -C (OPTIONAL). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2009-03-23 J. ATOR -- REMOVE INITIALIZATION OF COMMON /MSGCWD/ -C -C USAGE: CALL DXINIT (LUN, IOI) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IOI - INTEGER: SWITCH: -C 0 = do not initialize the table with apriori -C Table B and D entries -C else = initialize the table with apriori Table B -C and D entries -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 IFXY PKTDD -C THIS ROUTINE IS CALLED BY: CPBFDX OPENBF RDBFDX RDUSDX -C READERME READS3 -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 - COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*8 INIB(6,5),INID(5) - CHARACTER*6 ADN30 - CHARACTER*3 TYPS - CHARACTER*1 REPS - - DATA INIB /'------','BYTCNT ','BYTES ','+0','+0','16', - . '------','BITPAD ','NONE ','+0','+0','1 ', - . '031000','DRF1BIT ','NUMERIC','+0','+0','1 ', - . '031001','DRF8BIT ','NUMERIC','+0','+0','8 ', - . '031002','DRF16BIT','NUMERIC','+0','+0','16'/ - DATA NINIB /5/ - - DATA INID /' ', - . 'DRP16BIT', - . 'DRP8BIT ', - . 'DRPSTAK ', - . 'DRP1BIT '/ - DATA NINID /5/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CLEAR OUT A TABLE PARTITION -C --------------------------- - - NTBA(LUN) = 0 - DO I=1,NTBA(0) - TABA(I,LUN) = ' ' - MTAB(I,LUN) = 0 - ENDDO - - NTBB(LUN) = 0 - DO I=1,NTBB(0) - TABB(I,LUN) = ' ' - ENDDO - - NTBD(LUN) = 0 - DO I=1,NTBD(0) - TABD(I,LUN) = ' ' -c .... This zeroes the counter in TABD array, IRET returns as 0 and -c is not tested - CALL PKTDD(I,LUN,0,IRET) - ENDDO - - IF(IOI.EQ.0) GOTO 100 - -C INITIALIZE TABLE WITH APRIORI TABLE B AND D ENTRIES -C --------------------------------------------------- - - INIB(1,1) = ADN30(IBCT,6) - INIB(1,2) = ADN30(IPD4,6) - - DO I=1,NINIB - NTBB(LUN) = NTBB(LUN)+1 - IDNB(I,LUN) = IFXY(INIB(1,I)) - TABB(I,LUN)( 1: 6) = INIB(1,I) - TABB(I,LUN)( 7: 70) = INIB(2,I) - TABB(I,LUN)( 71: 94) = INIB(3,I) - TABB(I,LUN)( 95: 98) = INIB(4,I) - TABB(I,LUN)( 99:109) = INIB(5,I) - TABB(I,LUN)(110:112) = INIB(6,I) - ENDDO - - DO I=2,NINID - N = NTBD(LUN)+1 - IDND(N,LUN) = IDNR(I,1) - TABD(N,LUN)(1: 6) = ADN30(IDNR(I,1),6) - TABD(N,LUN)(7:70) = INID(I) -c .... DK: what if IRET = -1 ??? - CALL PKTDD(N,LUN,IDNR(1,1),IRET) -c .... DK: what if IRET = -1 ??? - CALL PKTDD(N,LUN,IDNR(I,2),IRET) - NTBD(LUN) = N - ENDDO - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/dxmini.f b/src/bufr/dxmini.f deleted file mode 100644 index 1425635aa6..0000000000 --- a/src/bufr/dxmini.f +++ /dev/null @@ -1,178 +0,0 @@ - SUBROUTINE DXMINI(LUN,MBAY,MBYT,MB4,MBA,MBB,MBD) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: DXMINI -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE INITIALIZES A BUFR TABLE (DICTIONARY) -C MESSAGE, WRITING ALL THE PRELIMINARY INFORMATION INTO SECTIONS 0, -C 1, 3, 4. BUFR ARCHIVE LIBRARY SUBROUTINE WRDXTB WILL WRITE THE -C ACTUAL TABLE INFORMATION INTO THE MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION -C WRITTEN IN SECTION 0 FROM 2 TO 3 -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 -C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13 -C -C USAGE: CALL DXMINI (LUN, MBAY, MBYT, MB4, MBA, MBB, MBD) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C OUTPUT ARGUMENT LIST: -C MBAY - INTEGER: (MXMSGLD4)-WORD PACKED BINARY ARRAY -C CONTAINING BUFR MESSAGE -C MBYT - INTEGER: LENGTH OF BUFR MESSAGE (BYTES) -C MB4 - INTEGER: BYTE NUMBER IN MESSAGE OF FIRST BYTE IN -C SECTION 4 -C MBA - INTEGER: BYTE NUMBER IN MESSAGE OF FOURTH BYTE IN -C SECTION 4 -C MBB - INTEGER: BYTE NUMBER IN MESSAGE OF FIFTH BYTE IN -C SECTION 4 -C MBD - INTEGER: BYTE NUMBER IN MESSAGE OF SIXTH BYTE IN -C SECTION 4 -C -C REMARKS: -C ARGUMENT LUN IS NOT REFERENCED IN THIS SUBROUTINE. IT IS LEFT -C HERE IN CASE AN APPLICATION PROGRAM CALLS THIS SUBROUTINE. -C -C THIS ROUTINE CALLS: BORT IUPM PKB PKC -C THIS ROUTINE IS CALLED BY: WRDXTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - - CHARACTER*128 BORT_STR - CHARACTER*56 DXSTR - DIMENSION MBAY(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -c .... The local message subtype is set to the version number of the -c local tables (here = 1) - MSBT = IDXV - -C INITIALIZE THE MESSAGE -C ---------------------- - - MBIT = 0 - DO I=1,MXMSGLD4 - MBAY(I) = 0 - ENDDO - -C For dictionary messages, the Section 1 date is simply zeroed out. -C (Note that there is logic in function IDXMSG which relies on this!) - - IH = 0 - ID = 0 - IM = 0 - IY = 0 - -c Dictionary messages get type 11 (see WMO Table A) - MTYP = 11 - NSUB = 1 - - IDXS = IDXV+1 - LDXS = NXSTR(IDXS) - - NBY0 = 8 - NBY1 = 18 - NBY2 = 0 - NBY3 = 7 + NXSTR(IDXS) + 1 - NBY4 = 7 - NBY5 = 4 - MBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5 - - IF(MOD(NBY3,2).NE.0) GOTO 900 - -C SECTION 0 -C --------- - - CALL PKC('BUFR' , 4 , MBAY,MBIT) - CALL PKB( MBYT , 24 , MBAY,MBIT) - CALL PKB( 3 , 8 , MBAY,MBIT) - -C SECTION 1 -C --------- - - CALL PKB( NBY1 , 24 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - CALL PKB( 3 , 8 , MBAY,MBIT) - CALL PKB( 7 , 8 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - CALL PKB( MTYP , 8 , MBAY,MBIT) - CALL PKB( MSBT , 8 , MBAY,MBIT) - CALL PKB( 13 , 8 , MBAY,MBIT) - CALL PKB( IDXV , 8 , MBAY,MBIT) - CALL PKB( IY , 8 , MBAY,MBIT) - CALL PKB( IM , 8 , MBAY,MBIT) - CALL PKB( ID , 8 , MBAY,MBIT) - CALL PKB( IH , 8 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - -C SECTION 3 -C --------- - - CALL PKB( NBY3 , 24 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - CALL PKB( 1 , 16 , MBAY,MBIT) - CALL PKB( 2**7 , 8 , MBAY,MBIT) - DO I=1,LDXS - CALL PKB(IUPM(DXSTR(IDXS)(I:I),8),8,MBAY,MBIT) - ENDDO - CALL PKB( 0 , 8 , MBAY,MBIT) - -C SECTION 4 -C --------- - - MB4 = MBIT/8+1 - CALL PKB(NBY4 , 24 , MBAY,MBIT) - CALL PKB( 0 , 8 , MBAY,MBIT) - MBA = MBIT/8+1 - CALL PKB( 0 , 8 , MBAY,MBIT) - MBB = MBIT/8+1 - CALL PKB( 0 , 8 , MBAY,MBIT) - MBD = MBIT/8+1 - CALL PKB( 0 , 8 , MBAY,MBIT) - - IF(MBIT/8+NBY5.NE.MBYT) GOTO 901 - -C EXITS -C ----- - - RETURN -900 CALL BORT - . ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') -901 WRITE(BORT_STR,'("BUFRLIB: DXMINI - NUMBER OF BYTES STORED FOR '// - . 'A MESSAGE (",I6,") IS NOT THE SAME AS FIRST CALCULATED, MBYT '// - . '(",I6)') MBIT/8+NBY5,MBYT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/elemdx.f b/src/bufr/elemdx.f deleted file mode 100644 index dac17c052d..0000000000 --- a/src/bufr/elemdx.f +++ /dev/null @@ -1,149 +0,0 @@ - SUBROUTINE ELEMDX(CARD,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ELEMDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE DECODES THE SCALE FACTOR, REFERENCE VALUE, -C BIT WIDTH AND UNITS (I.E., THE "ELEMENTS") FROM A TABLE B MNEMONIC -C DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A USER-SUPPLIED BUFR -C DICTIONARY TABLE FILE IN CHARACTER FORMAT BY BUFR ARCHIVE LIBRARY -C SUBROUTINE RDUSDX. THESE DECODED VALUES ARE THEN ADDED TO THE -C ALREADY-EXISTING ENTRY FOR THAT MNEMONIC WITHIN THE INTERNAL BUFR -C TABLE B ARRAY TABB(*,LUN) IN COMMON BLOCK /TABABD/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 -C 2007-01-19 J. ATOR -- ADDED EXTRA ARGUMENT FOR CALL TO JSTCHR -C -C USAGE: CALL ELEMDX (CARD, LUN) -C INPUT ARGUMENT LIST: -C CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ -C FROM A USER-SUPPLIED BUFR DICTIONARY TABLE -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 CAPIT JSTCHR JSTNUM -C NEMTAB -C THIS ROUTINE IS CALLED BY: RDUSDX STSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*80 CARD - CHARACTER*24 UNIT - CHARACTER*11 REFR,REFR_ORIG - CHARACTER*8 NEMO - CHARACTER*4 SCAL,SCAL_ORIG - CHARACTER*3 BITW,BITW_ORIG - CHARACTER*1 SIGN,TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CAPTURE THE VARIOUS ELEMENTS CHARACTERISTICS -C -------------------------------------------- - - NEMO = CARD( 3:10) - SCAL = CARD(14:17) - REFR = CARD(21:31) - BITW = CARD(35:37) - UNIT = CARD(41:64) -c .... Make sure the units are all capitalized - CALL CAPIT(UNIT) - -C FIND THE ELEMENT TAG IN TABLE B -C ------------------------------- - -C Note that an entry for this mnemonic should already exist within -C the internal BUFR Table B array TABB(*,LUN). We now need to -C retrieve the positional index for that entry within TABB(*,LUN) -C so that we can access the entry and then add the scale factor, -C reference value, bit width, and units to it. - - CALL NEMTAB(LUN,NEMO,IDSN,TAB,IELE) - IF(TAB.NE.'B') GOTO 900 - -C LEFT JUSTIFY AND STORE CHARACTERISTICS -C -------------------------------------- - - CALL JSTCHR(UNIT,IRET) - IF(IRET.NE.0) GOTO 904 - TABB(IELE,LUN)(71:94) = UNIT - - SCAL_ORIG=SCAL - CALL JSTNUM(SCAL,SIGN,IRET) - IF(IRET.NE.0) GOTO 901 - TABB(IELE,LUN)(95:95) = SIGN - TABB(IELE,LUN)(96:98) = SCAL - - REFR_ORIG=REFR - CALL JSTNUM(REFR,SIGN,IRET) - IF(IRET.NE.0) GOTO 902 - TABB(IELE,LUN)( 99: 99) = SIGN - TABB(IELE,LUN)(100:109) = REFR - - BITW_ORIG=BITW - CALL JSTNUM(BITW,SIGN,IRET) - IF(IRET.NE.0 ) GOTO 903 - IF(SIGN.EQ.'-') GOTO 903 - TABB(IELE,LUN)(110:112) = BITW - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE B ENTRY '// - . '(UNDEFINED, TAB=",A,")")') NEMO,TAB - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"PARSED SCALE VALUE (=",A,") IS NOT '// - . 'NUMERIC")') SCAL_ORIG - CALL BORT2(BORT_STR1,BORT_STR2) -902 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"PARSED REFERENCE VALUE (=",A,") IS NOT '// - . 'NUMERIC")') REFR_ORIG - CALL BORT2(BORT_STR1,BORT_STR2) -903 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"PARSED BIT WIDTH VALUE (=",A,") IS NOT '// - . 'NUMERIC")') BITW_ORIG - CALL BORT2(BORT_STR1,BORT_STR2) -904 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"UNITS FIELD IS EMPTY")') - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/errwrt.f b/src/bufr/errwrt.f deleted file mode 100644 index 122a22181e..0000000000 --- a/src/bufr/errwrt.f +++ /dev/null @@ -1,57 +0,0 @@ - SUBROUTINE ERRWRT(STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ERRWRT -C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-04-21 -C -C ABSTRACT: THIS SUBROUTINE WRITES A GIVEN ERROR OR OTHER DIAGNOSTIC -C MESSAGE TO A USER-SPECIFIED LOGICAL UNIT. AS DISTRIBUTED WITHIN -C THE BUFR ARCHIVE LIBRARY, THIS SUBROUTINE WILL WRITE ANY SUCH -C MESSAGES TO STANDARD OUTPUT; HOWEVER, APPLICATION PROGRAMS MAY -C SUBSTITUTE AN IN-LINE VERSION OF ERRWRT (OVERRIDING THIS ONE) IN -C ORDER TO DEFINE AN ALTERNATE DESTINATION FOR SUCH MESSAGES. -C -C PROGRAM HISTORY LOG: -C 2009-04-21 J. ATOR -- ORIGINAL AUTHOR -C 2012-11-15 D. KEYSER -- USE FORMATTED PRINT -C -C USAGE: CALL ERRWRT (STR) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): ERROR MESSAGE TO BE PRINTED TO -C STANDARD OUTPUT (DEFAULT) OR TO ANOTHER DESTINATION -C (IF SPECIFIED BY THE USER APPLICATION VIA AN IN-LINE -C REPLACEMENT FOR THIS SUBROUTINE) -C -C OUTPUT FILES: -C UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: BORT BORT2 CKTABA CPDXMM -C DATEBF DUMPBF INVCON INVTAG -C INVWIN JSTNUM MAKESTAB MAXOUT -C MRGINV MSGUPD MSGWRT NVNWIN -C OPENBF OPENBT PKTDD RDBFDX -C RDMEMM RDMEMS READDX READERME -C READLC READMG READMT READS3 -C STRNUM STRSUC UFBEVN UFBIN3 -C UFBINT UFBMEM UFBMEX UFBOVR -C UFBREP UFBRMS UFBRW UFBSEQ -C UFBSTP UFBTAB UFBTAM USRTPL -C VALX WRDLEN -C Can also be called by application -C programs using an in-line version. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - - PRINT'(1X,A)',STR - - RETURN - END diff --git a/src/bufr/getabdb.f b/src/bufr/getabdb.f deleted file mode 100644 index a62fb5a563..0000000000 --- a/src/bufr/getabdb.f +++ /dev/null @@ -1,90 +0,0 @@ - SUBROUTINE GETABDB(LUNIT,TABDB,ITAB,JTAB) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETABDB -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE RETURNS INTERNAL TABLE B AND TABLE D -C INFORMATION FOR LOGICAL UNIT LUNIT IN A PRE-DEFINED ASCII FORMAT. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ADDED TO BUFR ARCHIVE LIBRARY (WAS IN-LINED -C IN PROGRAM NAMSND) -C -C USAGE: CALL GETABDB( LUNIT, TABDB, ITAB, JTAB ) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C ITAB - INTEGER: DIMENSIONED SIZE OF TABDB ARRAY -C -C OUTPUT ARGUMENT LIST: -C TABDB - CHARACTER*128: (JTAB)-WORD ARRAY OF INTERNAL TABLE B -C AND TABLE D INFORMATION -C JTAB - INTEGER: NUMBER OF ENTRIES STORED WITHIN TABDB -C -C REMARKS: -C THIS ROUTINE CALLS: NEMTBD STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*128 TABDB(*) - CHARACTER*8 NEMO,NEMS(MAXCD) - DIMENSION IRPS(MAXCD),KNTS(MAXCD) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - JTAB = 0 - -C MAKE SURE THE FILE IS OPEN -C -------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) RETURN - -C WRITE OUT THE TABLE D ENTRIES FOR THIS FILE -C ------------------------------------------- - - DO I=1,NTBD(LUN) - NEMO = TABD(I,LUN)(7:14) - CALL NEMTBD(LUN,I,NSEQ,NEMS,IRPS,KNTS) - DO J=1,NSEQ,10 - JTAB = JTAB+1 - IF(JTAB.LE.ITAB) THEN - WRITE(TABDB(JTAB),1) NEMO,(NEMS(K),K=J,MIN(J+9,NSEQ)) -1 FORMAT('D ',A8,10(1X,A10)) - ENDIF - ENDDO - ENDDO - -C ADD THE TABLE B ENTRIES -C ----------------------- - - DO I=1,NTBB(LUN) - JTAB = JTAB+1 - IF(JTAB.LE.ITAB) THEN - WRITE(TABDB(JTAB),2) TABB(I,LUN)(7:14),TABB(I,LUN)(71:112) -2 FORMAT('B ',A8,1X,A42) - ENDIF - ENDDO - - RETURN - END diff --git a/src/bufr/getbmiss.f b/src/bufr/getbmiss.f deleted file mode 100644 index 44c0c252da..0000000000 --- a/src/bufr/getbmiss.f +++ /dev/null @@ -1,49 +0,0 @@ - REAL*8 FUNCTION GETBMISS() - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETBMISS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 -C -C ABSTRACT: GETBMISS RETURNS THE CURRENT VALUE OF "BMISS" WHICH DENOTES -C MISSING VALUES BOTH FOR READING FROM BUFR FILES AND FOR -C WRITING TO BUFR FILES. THIS MISSING VALUE IS SET TO A -C DEFAULT VALUE OF 10E10 IN SUBROUTINE BFRINI, BUT APPLICATION -C PROGRAMS MAY SET IT TO A DIFFERENT VALUE VIA A CALL TO -C SUBROUTINE SETBMISS. -C -C PROGRAM HISTORY LOG: -C 2012-10-05 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: GETBMISS() -C -C INPUT ARGUMENTS: -C -C OUTPUT ARGUMENTS: -C GETBMISS - REAL*8: CURRENT VALUE OF BUFR ARCHIVE LIBRARY MISSING -C VALUE "BMISS" -C -C REMARKS: -C THIS ROUTINE CALLS: OPENBF -C -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- - - CALL OPENBF(0,'FIRST',0) - - GETBMISS = BMISS - - RETURN - END diff --git a/src/bufr/getlens.f b/src/bufr/getlens.f deleted file mode 100644 index 76bf4d3d69..0000000000 --- a/src/bufr/getlens.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE GETLENS(MBAY,LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETLENS -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS ALL OF THE INDIVIDUAL -C SECTION LENGTHS OF THE BUFR MESSAGE STORED IN ARRAY MBAY, UP TO A -C SPECIFIED POINT. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR -C EDITION 2, 3 OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING -C "BUFR") MUST BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL GETLENS (MBAY, LL, LEN0, LEN1, LEN2, LEN3, LEN4, LEN5) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR MESSAGE -C LL - INTEGER: NUMBER OF LAST SECTION FOR WHICH THE LENGTH -C IS TO BE UNPACKED. IN OTHER WORDS, SETTING LL = N -C MEANS TO UNPACK THE LENGTHS OF SECTIONS 0 THROUGH N -C (I.E. LEN0, LEN1,...,LEN(N)). ANY SECTION LENGTHS -C THAT ARE NOT UNPACKED ARE RETURNED WITH A DEFAULT -C VALUE OF -1. -C -C OUTPUT ARGUMENT LIST: -C LEN0 - LENGTH OF SECTION 0 (= -1 IF NOT UNPACKED) -C LEN1 - LENGTH OF SECTION 1 (= -1 IF NOT UNPACKED) -C LEN2 - LENGTH OF SECTION 2 (= -1 IF NOT UNPACKED) -C LEN3 - LENGTH OF SECTION 3 (= -1 IF NOT UNPACKED) -C LEN4 - LENGTH OF SECTION 4 (= -1 IF NOT UNPACKED) -C LEN5 - LENGTH OF SECTION 5 (= -1 IF NOT UNPACKED) -C -C REMARKS: -C THIS ROUTINE CALLS: IUPB IUPBS01 -C THIS ROUTINE IS CALLED BY: ATRCPT CKTABA CNVED4 IUPBS3 -C MSGWRT STBFDX STNDRD UPDS3 -C WRDXTB WRITLC -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MBAY(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LEN0 = -1 - LEN1 = -1 - LEN2 = -1 - LEN3 = -1 - LEN4 = -1 - LEN5 = -1 - - IF(LL.LT.0) RETURN - LEN0 = IUPBS01(MBAY,'LEN0') - - IF(LL.LT.1) RETURN - LEN1 = IUPBS01(MBAY,'LEN1') - - IF(LL.LT.2) RETURN - IAD2 = LEN0 + LEN1 - LEN2 = IUPB(MBAY,IAD2+1,24) * IUPBS01(MBAY,'ISC2') - - IF(LL.LT.3) RETURN - IAD3 = IAD2 + LEN2 - LEN3 = IUPB(MBAY,IAD3+1,24) - - IF(LL.LT.4) RETURN - IAD4 = IAD3 + LEN3 - LEN4 = IUPB(MBAY,IAD4+1,24) - - IF(LL.LT.5) RETURN - LEN5 = 4 - - RETURN - END diff --git a/src/bufr/getntbe.f b/src/bufr/getntbe.f deleted file mode 100644 index 8e56f737a8..0000000000 --- a/src/bufr/getntbe.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE GETNTBE ( LUNT, IFXYN, LINE, IRET ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETNTBE -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE GETS THE FIRST LINE OF THE NEXT ENTRY IN -C THE SPECIFIED ASCII MASTER TABLE B OR MASTER TABLE D FILE. THIS -C LINE CONTAINS, AMONG OTHER THINGS, THE FXY NUMBER CORRESPONDING TO -C THIS ENTRY. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL GETNTBE ( LUNT, IFXYN, LINE, IRET ) -C INPUT ARGUMENT LIST: -C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING MASTER TABLE B OR MASTER TABLE D INFORMATION -C -C OUTPUT ARGUMENT LIST: -C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR -C NEXT TABLE ENTRY -C LINE - CHARACTER*(*): FIRST LINE OF NEXT TABLE ENTRY -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = end-of-file encountered while reading -C from LUNT -C -2 = I/O error encountered while reading -C from LUNT -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 IGETNTBL IGETFXY IFXY -C PARSTR -C THIS ROUTINE IS CALLED BY: RDMTBB RDMTBD -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) LINE - CHARACTER*128 BORT_STR1, BORT_STR2 - CHARACTER*20 TAGS(4) - CHARACTER*6 ADSC - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Get the first line of the next entry in the file. - - IRET = IGETNTBL ( LUNT, LINE ) - IF ( IRET .EQ. 0 ) THEN - -C The first field within this line should contain the -C FXY number. - - CALL PARSTR ( LINE(1:20), TAGS, 4, NTAG, '|', .FALSE. ) - IF ( NTAG .LT. 1 ) GOTO 900 - IF ( IGETFXY ( TAGS(1), ADSC ) .NE. 0 ) GOTO 900 - -C Store the bit-wise representation of the FXY number. - - IFXYN = IFXY ( ADSC ) - ENDIF - - RETURN - - 900 BORT_STR1 = 'BUFRLIB: GETNTBE - CARD BEGINNING WITH: ' // - . LINE(1:20) - BORT_STR2 = ' HAS BAD OR MISSING FXY NUMBER' - CALL BORT2(BORT_STR1,BORT_STR2) - - END diff --git a/src/bufr/gets1loc.f b/src/bufr/gets1loc.f deleted file mode 100644 index 3f71b27284..0000000000 --- a/src/bufr/gets1loc.f +++ /dev/null @@ -1,220 +0,0 @@ - SUBROUTINE GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETS1LOC -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE RETURNS THE LOCATION (I.E. STARTING BYTE -C AND BIT WIDTH) OF A SPECIFIED VALUE WITHIN SECTION 1 OF A BUFR -C MESSAGE ENCODED ACCORDING TO A SPECIFIED BUFR EDITION. IT WILL -C WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE -C VALUE FOR WHICH THE LOCATION IS TO BE DETERMINED IS SPECIFIED VIA -C THE MNEMONIC S1MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2006-04-14 D. KEYSER -- ADDED OPTIONS FOR 'YCEN' AND 'CENT' -C -C USAGE: GETS1LOC ( S1MNEM, IBEN, ISBYT, IWID, IRET ) -C INPUT ARGUMENT LIST: -C S1MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE WHOSE -C LOCATION WITHIN SECTION 1 IS TO BE DETERMINED: -C 'LEN1' = LENGTH (IN BYTES) OF SECTION 1 -C 'BMT' = BUFR MASTER TABLE -C 'OGCE' = ORIGINATING CENTER -C 'GSES' = ORIGINATING SUBCENTER -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 3 OR 4 MESSAGES!) -C 'USN' = UPDATE SEQUENCE NUMBER -C 'ISC2' = FLAG INDICATING ABSENCE/PRESENCE OF -C (OPTIONAL) SECTION 2 IN BUFR MESSAGE: -C 0 = SECTION 2 ABSENT -C 1 = SECTION 2 PRESENT -C 'MTYP' = DATA CATEGORY -C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MSBT' = DATA SUBCATEGORY (LOCAL) -C 'MTV' = VERSION NUMBER OF MASTER TABLE -C 'MTVL' = VERSION NUMBER OF LOCAL TABLES -C 'YCEN' = YEAR OF CENTURY (1-100) -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 2 AND 3 MESSAGES!) -C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, -C 21 FOR YEARS 2001-2100) -C (NOTE: THIS VALUE *MAY* BE PRESENT IN -C BUFR EDITION 2 AND 3 MESSAGES, -C BUT IT IS NEVER PRESENT IN ANY -C BUFR EDITION 4 MESSAGES!) -C 'YEAR' = YEAR (4-DIGIT) -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MNTH' = MONTH -C 'DAYS' = DAY -C 'HOUR' = HOUR -C 'MINU' = MINUTE -C 'SECO' = SECOND -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 4 MESSAGES!) -C IBEN - INTEGER: BUFR EDITION NUMBER -C -C -C OUTPUT ARGUMENT LIST: -C ISBYT - INTEGER: NUMBER OF STARTING BYTE WITHIN SECTION 1 -C WHICH CONTAINS VALUE CORRESPONDING TO S1MNEM -C (NOTE: ISBYT IS ALWAYS RETURNED AS 18 WHENEVER -C S1MNEM = 'CENT' AND IBEN = 2 OR 3; IN SUCH -C CASES IT IS THEN UP TO THE CALLING ROUTINE -C TO DETERMINE WHETHER THIS LOCATION ACTUALLY -C CONTAINS A VALID CENTURY VALUE!) -C IWID - INTEGER: WIDTH (IN BITS) OF VALUE CORRESPONDING -C TO S1MNEM -C IRET - INTEGER: RETURN CODE -C 0 = NORMAL RETURN -C -1 = THE INPUT S1MNEM MNEMONIC IS INVALID FOR -C BUFR EDITION IBEN -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: CRBMG IUPBS01 PKBS1 -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) S1MNEM - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - IWID = 8 - - IF(S1MNEM.EQ.'LEN1') THEN - ISBYT = 1 - IWID = 24 - ELSE IF(S1MNEM.EQ.'BMT') THEN - ISBYT = 4 - ELSE IF(S1MNEM.EQ.'OGCE') THEN - IF(IBEN.EQ.3) THEN - ISBYT = 6 - ELSE - -C Note that this location is actually the same for both -C Edition 2 *and* Edition 4 of BUFR! - - ISBYT = 5 - IWID = 16 - ENDIF - ELSE IF(S1MNEM.EQ.'GSES') THEN - IF(IBEN.EQ.3) THEN - ISBYT = 5 - ELSE IF(IBEN.EQ.4) THEN - ISBYT = 7 - IWID = 16 - ELSE - IRET = -1 - ENDIF - ELSE IF(S1MNEM.EQ.'USN') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 9 - ELSE - ISBYT = 7 - ENDIF - ELSE IF(S1MNEM.EQ.'ISC2') THEN - IWID = 1 - IF(IBEN.EQ.4) THEN - ISBYT = 10 - ELSE - ISBYT = 8 - ENDIF - ELSE IF(S1MNEM.EQ.'MTYP') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 11 - ELSE - ISBYT = 9 - ENDIF - ELSE IF(S1MNEM.EQ.'MSBTI') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 12 - ELSE - IRET = -1 - ENDIF - ELSE IF(S1MNEM.EQ.'MSBT') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 13 - ELSE - ISBYT = 10 - ENDIF - ELSE IF(S1MNEM.EQ.'MTV') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 14 - ELSE - ISBYT = 11 - ENDIF - ELSE IF(S1MNEM.EQ.'MTVL') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 15 - ELSE - ISBYT = 12 - ENDIF - ELSE IF(S1MNEM.EQ.'YEAR') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 16 - IWID = 16 - ELSE - IRET = -1 - ENDIF - ELSE IF(S1MNEM.EQ.'YCEN') THEN - IF(IBEN.LT.4) THEN - ISBYT = 13 - ELSE - IRET = -1 - ENDIF - ELSE IF(S1MNEM.EQ.'CENT') THEN - IF(IBEN.LT.4) THEN - ISBYT = 18 - ELSE - IRET = -1 - ENDIF - ELSE IF(S1MNEM.EQ.'MNTH') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 18 - ELSE - ISBYT = 14 - ENDIF - ELSE IF(S1MNEM.EQ.'DAYS') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 19 - ELSE - ISBYT = 15 - ENDIF - ELSE IF(S1MNEM.EQ.'HOUR') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 20 - ELSE - ISBYT = 16 - ENDIF - ELSE IF(S1MNEM.EQ.'MINU') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 21 - ELSE - ISBYT = 17 - ENDIF - ELSE IF(S1MNEM.EQ.'SECO') THEN - IF(IBEN.EQ.4) THEN - ISBYT = 22 - ELSE - IRET = -1 - ENDIF - ELSE - IRET = -1 - ENDIF - - RETURN - END diff --git a/src/bufr/gettagpr.f b/src/bufr/gettagpr.f deleted file mode 100644 index d161f8e86a..0000000000 --- a/src/bufr/gettagpr.f +++ /dev/null @@ -1,101 +0,0 @@ - SUBROUTINE GETTAGPR ( LUNIT, TAGCH, NTAGCH, TAGPR, IRET ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETTAGPR -C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-09-12 -C -C ABSTRACT: GIVEN A MNEMONIC CORRESPONDING TO A CHILD DESCRIPTOR -C WITHIN A PARENT SEQUENCE, THIS SUBROUTINE RETURNS THE MNEMONIC -C CORRESPONDING TO THE PARENT SEQUENCE. A SUBSET DEFINITION MUST -C ALREADY BE IN SCOPE, EITHER VIA A PREVIOUS CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE READSB OR EQUIVALENT (FOR INPUT FILES) OR TO -C SUBROUTINE OPENMB OR EQUIVALENT (FOR OUTPUT FILES). IF THERE IS -C MORE THAN ONE OCCURRENCE OF THE CHILD DESCRIPTOR WITHIN THE -C OVERALL SUBSET DEFINITION, THIS SUBROUTINE WILL RETURN THE PARENT -C MNEMONIC CORRESPONDING TO THE (NTAGCH)th OCCURRENCE OF THE CHILD, -C COUNTING FROM THE BEGINNING OF THE OVERALL SUBSET DEFINITION. -C -C PROGRAM HISTORY LOG: -C 2012-09-12 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL GETTAGPR (LUNIT, TAGCH, NTAGCH, TAGPR, IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C TAGCH - CHARACTER*(*): MNEMONIC CORRESPONDING TO CHILD -C DESCRIPTOR -C NTAGCH - INTEGER: ORDINAL OCCURRENCE OF TAGCH FOR WHICH -C TAGPR IS TO BE RETURNED, COUNTING FROM THE -C BEGINNING OF THE OVERALL SUBSET DEFINITION -C -C OUTPUT ARGUMENT LIST: -C TAGPR - CHARACTER*(*): MNEMONIC CORRESPONDING TO PARENT -C SEQUENCE DESCRIPTOR -C IRET - INTEGER: RETURN CODE -C 0 = NORMAL RETURN -C -1 = PARENT MNEMONIC COULD NOT BE FOUND, OR SOME -C OTHER ERROR OCCURRED -C -C REMARKS: -C THIS ROUTINE CALLS: PARSTR STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*10 TAG,TGS(15) - CHARACTER*3 TYP - - CHARACTER*(*) TAGCH, TAGPR - - REAL*8 VAL - - DATA MAXTG /15/ - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = -1 - -C Get LUN from LUNIT. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF (IL.EQ.0) RETURN - IF (INODE(LUN).NE.INV(1,LUN)) RETURN - -C Get TAGPR from the (NTAGCH)th occurrence of TAGCH. - - CALL PARSTR(TAGCH,TGS,MAXTG,NTG,' ',.TRUE.) - IF (NTG.NE.1) RETURN - - ITAGCT = 0 - DO N=1,NVAL(LUN) - NOD = INV(N,LUN) - IF(TGS(1).EQ.TAG(NOD)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.NTAGCH) THEN - TAGPR = TAG(JMPB(NOD)) - IRET = 0 - RETURN - ENDIF - ENDIF - ENDDO - - RETURN - END diff --git a/src/bufr/gettbh.f b/src/bufr/gettbh.f deleted file mode 100644 index 5c7339d978..0000000000 --- a/src/bufr/gettbh.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETTBH -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE READS AND PARSES THE HEADER LINES FROM TWO -C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES CONTAINING -C EITHER MASTER TABLE B OR MASTER TABLE D INFORMATION. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) -C -C INPUT ARGUMENT LIST: -C LUNS - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING STANDARD TABLE INFORMATION -C LUNL - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING LOCAL TABLE INFORMATION -C TAB - CHARACTER*1: TABLE TYPE ('B' OR 'D') -C -C OUTPUT ARGUMENT LIST: -C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE -C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) -C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM -C STANDARD ASCII FILE -C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE -C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM -C LOCAL ASCII FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IGETNTBL PARSTR VALX -C THIS ROUTINE IS CALLED BY: RDMTBB RDMTBD -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*128 BORT_STR - CHARACTER*40 HEADER - CHARACTER*30 TAGS(5), LABEL - CHARACTER*3 CFTYP - CHARACTER*2 CTTYP - CHARACTER*1 TAB - - LOGICAL BADLABEL - -C----------------------------------------------------------------------- -C Statement function to check for bad header line label: - - BADLABEL ( LABEL ) = ( ( INDEX ( LABEL, CTTYP ) .EQ. 0 ) .OR. - . ( INDEX ( LABEL, CFTYP ) .EQ. 0 ) ) -C----------------------------------------------------------------------- - - CTTYP = TAB // ' ' - -C Read and parse the header line of the standard file. - - CFTYP = 'STD' - IF ( IGETNTBL ( LUNS, HEADER ) .NE. 0 ) GOTO 900 - CALL PARSTR ( HEADER, TAGS, 5, NTAG, '|', .FALSE. ) - IF ( NTAG .LT. 3 ) GOTO 900 - IF ( BADLABEL ( TAGS(1) ) ) GOTO 900 - IMT = VALX ( TAGS(2) ) - IMTV = VALX ( TAGS(3) ) - -C Read and parse the header line of the local file. - - CFTYP = 'LOC' - IF ( IGETNTBL ( LUNL, HEADER ) .NE. 0 ) GOTO 900 - CALL PARSTR ( HEADER, TAGS, 5, NTAG, '|', .FALSE. ) - IF ( NTAG .LT. 4 ) GOTO 900 - IF ( BADLABEL ( TAGS(1) ) ) GOTO 900 - IMT2 = VALX ( TAGS(2) ) - IOGCE = VALX ( TAGS(3) ) - ILTV = VALX ( TAGS(4) ) - -C Verify that both files are for the same master table. - - IF ( IMT .NE. IMT2 ) GOTO 901 - - RETURN - - 900 WRITE(BORT_STR,'("BUFRLIB: GETTBH - BAD OR MISSING HEADER '// - . 'WITHIN ",A," TABLE ",A)') CFTYP, TAB - CALL BORT(BORT_STR) - 901 WRITE(BORT_STR,'("BUFRLIB: GETTBH - MASTER TABLE NUMBER '// - . 'MISMATCH BETWEEN STD AND LOC TABLE ",A)') TAB - CALL BORT(BORT_STR) - END diff --git a/src/bufr/getvalnb.f b/src/bufr/getvalnb.f deleted file mode 100644 index 3adf462865..0000000000 --- a/src/bufr/getvalnb.f +++ /dev/null @@ -1,140 +0,0 @@ - REAL*8 FUNCTION GETVALNB ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETVALNB -C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-09-12 -C -C ABSTRACT: THIS FUNCTION SHOULD ONLY BE CALLED WHEN A BUFR FILE IS -C OPENED FOR INPUT, AND A SUBSET DEFINITION MUST ALREADY BE IN SCOPE -C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR -C EQUIVALENT. THE FUNCTION WILL FIRST SEARCH FOR THE (NTAGPV)th -C OCCURRENCE OF MNEMONIC TAGPV WITHIN THE OVERALL SUBSET DEFINITION, -C COUNTING FROM THE BEGINNING OF THE SUBSET. IF FOUND, IT WILL THEN -C SEARCH FORWARD (IF NTAGNB IS POSITIVE) OR BACKWARD (IF NTAGNB IS -C NEGATIVE) FROM THAT POINT WITHIN THE SUBSET FOR THE (NTAGNB)th -C OCCURRENCE OF MNEMONIC TAGNB AND RETURN THE VALUE CORRESPONDING -C TO THAT MNEMONIC. -C -C PROGRAM HISTORY LOG: -C 2012-09-12 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL GETVALNB (LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C TAGPV - CHARACTER*(*): PIVOT MNEMONIC; THE FUNCTION WILL -C FIRST SEARCH FOR the (NTAGPV)th OCCURRENCE OF THIS -C MNEMONIC, COUNTING FROM THE BEGINNING OF THE OVERALL -C SUBSET DEFINITION -C NTAGPV - INTEGER: ORDINAL OCCURRENCE OF TAGPV TO SEARCH FOR -C TAGNB - CHARACTER*(*): NEARBY MNEMONIC; ASSUMING TAGPV IS -C SUCCESSFULLY FOUND, THE FUNCTION WILL THEN SEARCH -C NEARBY FOR THE (NTAGNB)th OCCURRENCE OF TAGNB AND -C RETURN THE CORRESPONDING VALUE -C NTAGNB - INTEGER: ORDINAL OCCURRENCE OF TAGNB TO SEARCH FOR, -C COUNTING FROM THE LOCATION OF TAGPV WITHIN THE OVERALL -C SUBSET DEFINITION. IF TAGNB IS POSITIVE, THE FUNCTION -C WILL SEARCH IN A FORWARD DIRECTION FROM THE LOCATION OF -C TAGPV, OR IF TAGNB IS NEGATIVE IT WILL INSTEAD SEARCH -C IN A BACKWARDS DIRECTION. -C -C OUTPUT ARGUMENT LIST: -C GETVALNB - REAL*8: VALUE CORRESPONDING TO (NTAGNB)th OCCURRENCE -C OF TAGNB. IF FOR ANY REASON THIS VALUE CANNOT BE -C LOCATED, THEN THE BUFR ARCHIVE LIBRARY MISSING VALUE -C BMISS WILL BE RETURNED. -C -C REMARKS: -C THIS ROUTINE CALLS: PARSTR STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*10 TAG,TGS(15) - CHARACTER*3 TYP - - CHARACTER*(*) TAGPV, TAGNB - - REAL*8 VAL - - LOGICAL GOTNODPV - - DATA MAXTG /15/ - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - GETVALNB = BMISS - -C Get LUN from LUNIT. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF (IL.EQ.0) RETURN - IF (INODE(LUN).NE.INV(1,LUN)) RETURN - -C Locate the (NTAGPV)th occurrence of TAGPV. - - CALL PARSTR(TAGPV,TGS,MAXTG,NTG,' ',.TRUE.) - IF (NTG.NE.1) RETURN - - GOTNODPV = .FALSE. - ITAGCT = 0 - N = 1 - DO WHILE ((.NOT.GOTNODPV).AND.(N.LE.NVAL(LUN))) - NOD = INV(N,LUN) - IF(TGS(1).EQ.TAG(NOD)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.NTAGPV) THEN - GOTNODPV = .TRUE. - ELSE - N = N+1 - ENDIF - ELSE - N = N+1 - ENDIF - ENDDO - IF (.NOT.GOTNODPV) RETURN - -C Starting from TAGPV, search nearby for the -C +/-(NTAGNB)th occurrence of TAGNB. - - CALL PARSTR(TAGNB,TGS,MAXTG,NTG,' ',.TRUE.) - IF (NTG.NE.1) RETURN - - ISTEP = ISIGN(1,NTAGNB) - ITAGCT = 0 - N = N+ISTEP - DO WHILE ((N.GE.1).AND.(N.LE.NVAL(LUN))) - NOD = INV(N,LUN) - IF(TGS(1).EQ.TAG(NOD)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IABS(NTAGNB)) THEN - GETVALNB = VAL(N,LUN) - RETURN - ELSE - N = N+ISTEP - ENDIF - ELSE - N = N+ISTEP - ENDIF - ENDDO - - RETURN - END diff --git a/src/bufr/getwin.f b/src/bufr/getwin.f deleted file mode 100644 index 338811627d..0000000000 --- a/src/bufr/getwin.f +++ /dev/null @@ -1,128 +0,0 @@ - SUBROUTINE GETWIN(NODE,LUN,IWIN,JWIN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETWIN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: GIVEN A NODE INDEX WITHIN THE INTERNAL JUMP/LINK TABLE, THIS -C SUBROUTINE LOOKS WITHIN THE CURRENT SUBSET BUFFER FOR A "WINDOW" -C (SEE BELOW REMARKS) WHICH CONTAINS THIS NODE. IF FOUND, IT RETURNS -C THE STARTING AND ENDING INDICES OF THIS WINDOW WITHIN THE CURRENT -C SUBSET BUFFER. FOR EXAMPLE, IF THE NODE IS FOUND WITHIN THE SUBSET -C BUT IS NOT PART OF A DELAYED REPLICATION SEQUENCE, THEN THE RETURNED -C INDICES DEFINE THE START AND END OF THE ENTIRE SUBSET BUFFER. -C OTHERWISE, THE RETURNED INDICES DEFINE THE START AND END OF THE NEXT -C AVAILABLE DELAYED REPLICATION SEQUENCE ITERATION WHICH CONTAINS THE -C NODE. IF NO FURTHER ITERATIONS OF THE SEQUENCE CAN BE FOUND, THEN -C THE STARTING INDEX IS RETURNED WITH A VALUE OF ZERO. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE); OUTPUTS MORE -C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION -C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC -C -C USAGE: CALL GETWIN (NODE, LUN, IWIN, JWIN) -C INPUT ARGUMENT LIST: -C NODE - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C JWIN - INTEGER: ENDING INDEX OF THE PREVIOUS WINDOW ITERATION -C WHICH CONTAINED NODE -C -C OUTPUT ARGUMENT LIST: -C IWIN - INTEGER: STARTING INDEX OF THE CURRENT WINDOW ITERATION -C WHICH CONTAINS NODE -C 0 = NOT FOUND OR NO MORE ITERATIONS AVAILABLE -C JWIN - INTEGER: ENDING INDEX OF THE CURRENT WINDOW ITERATION -C WHICH CONTAINS NODE -C -C REMARKS: -C -C THIS IS ONE OF A NUMBER OF SUBROUTINES WHICH OPERATE ON "WINDOWS" -C (I.E. CONTIGUOUS PORTIONS) OF THE INTERNAL SUBSET BUFFER. THE -C SUBSET BUFFER IS AN ARRAY OF VALUES ARRANGED ACCORDING TO THE -C OVERALL TEMPLATE DEFINITION FOR A SUBSET. A WINDOW CAN BE ANY -C CONTIGUOUS PORTION OF THE SUBSET BUFFER UP TO AND INCLUDING THE -C ENTIRE SUBSET BUFFER ITSELF. FOR THE PURPOSES OF THESE "WINDOW -C OPERATOR" SUBROUTINES, A WINDOW ESSENTIALLY CONSISTS OF ALL OF THE -C ELEMENTS WITHIN A PARTICULAR DELAYED REPLICATION GROUP, SINCE SUCH -C GROUPS EFFECTIVELY DEFINE THE DIMENSIONS WITHIN A BUFR SUBSET FOR -C THE BUFR ARCHIVE LIBRARY SUBROUTINES SUCH AS UFBINT, UFBIN3, ETC. -C WHICH READ/WRITE INDIVIDUAL DATA VALUES. A BUFR SUBSET WITH NO -C DELAYED REPLICATION GROUPS IS CONSIDERED TO HAVE ONLY ONE -C DIMENSION, AND THEREFORE ONLY ONE "WINDOW" WHICH SPANS THE ENTIRE -C SUBSET. ON THE OTHER HAND, EACH DELAYED REPLICATION SEQUENCE -C WITHIN A BUFR SUBSET CONSISTS OF SOME NUMBER OF "WINDOWS", WHICH -C ARE A DE-FACTO SECOND DIMENSION OF THE SUBSET AND WHERE THE NUMBER -C OF WINDOWS IS THE DELAYED DESCRIPTOR REPLICATION FACTOR (I.E. THE -C NUMBER OF ITERATIONS) OF THE SEQUENCE. IF NESTED DELAYED -C REPLICATION IS USED, THEN THERE MAY BE THREE OR MORE DIMENSIONS -C WITHIN THE SUBSET. -C -C THIS ROUTINE CALLS: BORT INVWIN LSTJPB -C THIS ROUTINE IS CALLED BY: CONWIN UFBEVN UFBIN3 UFBRW -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*128 BORT_STR - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRPC = LSTJPB(NODE,LUN,'RPC') - - IF(IRPC.EQ.0) THEN - IWIN = INVWIN(NODE,LUN,JWIN,NVAL(LUN)) - IF(IWIN.EQ.0 .and. JWIN.GT.1) GOTO 100 - IWIN = 1 - JWIN = NVAL(LUN) - GOTO 100 - ELSE - IWIN = INVWIN(IRPC,LUN,JWIN,NVAL(LUN)) - IF(IWIN.EQ.0) THEN - GOTO 100 - ELSEIF(VAL(IWIN,LUN).EQ.0.) THEN - IWIN = 0 - GOTO 100 - ENDIF - ENDIF - - JWIN = INVWIN(IRPC,LUN,IWIN+1,NVAL(LUN)) - IF(JWIN.EQ.0) GOTO 900 - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: GETWIN - SEARCHED BETWEEN",I5," AND"'// - . ',I5,", MISSING BRACKET")') IWIN+1,NVAL(LUN) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/i4dy.f b/src/bufr/i4dy.f deleted file mode 100644 index f86b60c591..0000000000 --- a/src/bufr/i4dy.f +++ /dev/null @@ -1,66 +0,0 @@ - FUNCTION I4DY(IDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: I4DY -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 -C -C ABSTRACT: THIS FUNCTION CONVERTS AN EIGHT DIGIT INTEGER DATE -C (YYMMDDHH) TO TEN DIGITS (YYYYMMDDHH) USING THE Y2K "WINDOWING" -C TECHNIQUE. ALL TWO-DIGIT YEARS GREATER THAN "20" ARE ASSUMED TO -C HAVE A FOUR-DIGIT YEAR BEGINNING WITH "19" (1921-1999) AND ALL TWO- -C DIGIT YEARS LESS THAN OR EQUAL TO "20" ARE ASSUMED TO HAVE A FOUR- -C DIGIT YEAR BEGINNING WITH "20" (2000-2020). IF THE INPUT DATE IS -C ALREADY TEN DIGITS, THIS ROUTINE JUST RETURNS ITS VALUE. -C -C PROGRAM HISTORY LOG: -C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-11-24 J. WOOLLEN -- MODIFIED TO CONFORM TO THE NCEP 2-DIGIT -C YEAR TIME WINDOW OF 1921-2020 (BUT -C INADVERTENTLY SET TO 1911-2010) -C 1998-12-14 J. WOOLLEN -- MODIFIED TO USE 20 AS THE 2-DIGIT YEAR FOR -C WINDOWING TO A 4-DIGIT YEAR (00-20 ==> ADD -C 2000; 21-99 ==> ADD 1900), THIS WINDOWING -C TECHNIQUE WAS INADVERTENTLY CHANGED TO 10 -C IN THE PREVIOUS IMPLEMENTATION OF I4DY -C (1998-11-24) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER USE -C FLOATING POINT ARITHMETIC SINCE THIS CAN -C LEAD TO ROUND OFF ERROR AND AN IMPROPER -C RESULTING DATE ON SOME MACHINES (E.G., -C NCEP IBM FROST/SNOW), INCREASES -C PORTABILITY; UNIFIED/PORTABLE FOR WRF; -C ADDED DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: I4DY (IDATE) -C INPUT ARGUMENT LIST: -C IDATE - INTEGER: DATE (EITHER YYMMDDHH OR YYYYMMDDHH), -C DEPENDING ON DATELEN() VALUE -C -C OUTPUT ARGUMENT LIST: -C I4DY - INTEGER: DATE (YYYYMMDDHH) -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: CKTABA CMSGINI DATEBF DUMPBF -C IUPBS01 OPENMB OPENMG REWNBF -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - IF(IDATE.LT.10**8) THEN - IY = IDATE/10**6 - IF(IY.GT.20) I4DY = IDATE + 19*100000000 - IF(IY.LE.20) I4DY = IDATE + 20*100000000 - ELSE - I4DY = IDATE - ENDIF - - RETURN - END diff --git a/src/bufr/ibfms.f b/src/bufr/ibfms.f deleted file mode 100644 index ef988c1ad5..0000000000 --- a/src/bufr/ibfms.f +++ /dev/null @@ -1,57 +0,0 @@ - INTEGER FUNCTION IBFMS ( R8VAL ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IBFMS -C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS FUNCTION TESTS WHETHER THE INPUT VALUE IS EQUIVALENT -C TO THE BUFR ARCHIVE LIBRARY "MISSING" VALUE. THE USE OF INTEGER -C RETURN CODES ALLOWS THIS FUNCTION TO BE CALLED IN A LOGICAL -C CONTEXT FROM A CALLING PROGRAM WRITTEN IN C. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C 2009-03-23 J. ATOR -- INCREASED VALUE OF BDIFD FOR BETTER -C TEST ACCURACY -C 2012-10-05 J. ATOR -- MODIFIED TO REFLECT THE FACT THAT THE -C "MISSING" VALUE IS NOW CONFIGURABLE BY -C USERS (MAY BE SOMETHING OTHER THAN 10E10) -C -C USAGE: IBFMS ( R8VAL ) -C INPUT ARGUMENT LIST: -C R8VAL - REAL*8: VALUE TO BE TESTED FOR EQUIVALENCE TO -C BUFR ARCHIVE LIBRARY "MISSING" VALUE -C -C OUTPUT ARGUMENT LIST: -C IBFMS - INTEGER: RETURN CODE: -C 0 - R8VAL IS NOT EQUIVALENT TO "MISSING" -C 1 - R8VAL IS EQUIVALENT TO "MISSING" -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: INVMRG UFBDMP UFBRW UFDUMP -C WRTREE -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - REAL*8 R8VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF ( R8VAL .EQ. BMISS ) THEN - IBFMS = 1 - ELSE - IBFMS = 0 - ENDIF - - RETURN - END diff --git a/src/bufr/icbfms.f b/src/bufr/icbfms.f deleted file mode 100644 index 9fef9c658e..0000000000 --- a/src/bufr/icbfms.f +++ /dev/null @@ -1,71 +0,0 @@ - INTEGER FUNCTION ICBFMS ( STR, LSTR ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ICBFMS -C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-06-07 -C -C ABSTRACT: THIS FUNCTION TESTS WHETHER THE INPUT CHARACTER STRING -C IS "MISSING" BY CHECKING IF ALL OF THE EQUIVALENT BITS ARE SET TO 1. -C IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION IBFMS, EXCEPT THAT -C IBFMS TESTS REAL*8 VALUES FOR EQUIVALENCE TO THE PARAMETER BMISS, -C WHEREAS ICBFMS CHECKS THAT ALL EQUIVALENT BITS ARE SET TO 1 AND IS -C THEREFORE A MORE PORTABLE AND RELIABLE TEST FOR USE WITH CHARACTER -C STRINGS. -C -C PROGRAM HISTORY LOG: -C 2012-06-07 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: ICBFMS ( STR, LSTR ) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING TO BE TESTED -C LSTR - INTEGER: NUMBER OF CHARACTERS TO BE TESTED WITHIN STR -C -C OUTPUT ARGUMENT LIST: -C ICBFMS - INTEGER: RETURN CODE: -C 0 - STR IS NOT "MISSING" -C 1 - STR IS "MISSING" -C -C REMARKS: -C THIS ROUTINE CALLS: IUPM -C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE UFDUMP -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - CHARACTER*(*) STR - -C----------------------------------------------------------------------- - - ICBFMS = 0 - - NUMCHR = MIN(LSTR,LEN(STR)) - -C* Beginning with version 10.2.0 of the BUFRLIB, "missing" strings -C* are explicitly encoded with all bits set to 1. However, this -C* wasn't the case for strings encoded with earlier versions of -C* BUFRLIB, so the following block can help identify "missing" -C* strings encoded with these earlier versions. - - IF ( (NUMCHR.GE.4) .AND. ( STR(1:4).EQ.'B7Hv')) THEN - ICBFMS = 1 - RETURN - END IF - -C* Otherwise, the logic below will handle cases encoded using -C* BUFRLIB version 10.2.0 or later. - - DO I=1,NUMCHR - IF ( IUPM(STR(I:I),8).NE.255 ) RETURN - ENDDO - - ICBFMS = 1 - - RETURN - END diff --git a/src/bufr/ichkstr.f b/src/bufr/ichkstr.f deleted file mode 100644 index ea1c5cd04c..0000000000 --- a/src/bufr/ichkstr.f +++ /dev/null @@ -1,65 +0,0 @@ - FUNCTION ICHKSTR(STR,CHR,N) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ICHKSTR -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS FUNCTION COMPARES A SPECIFIED NUMBER OF CHARACTERS -C FROM AN INPUT CHARACTER ARRAY AGAINST THE SAME NUMBER OF CHARACTERS -C FROM AN INPUT CHARACTER STRING AND DETERMINES WHETHER THE TWO ARE -C EQUIVALENT. THE CHARACTER ARRAY IS ASSUMED TO BE IN ASCII, WHEREAS -C THE CHARACTER STRING IS ASSUMED TO BE IN THE NATIVE CHARACTER SET -C (I.E. ASCII OR EBCDIC) OF THE LOCAL MACHINE. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: ICHKSTR (STR, CHR, N) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): N-CHARACTER STRING IN ASCII OR EBCDIC, -C DEPENDING ON THE NATIVE MACHINE -C CHR - CHARACTER*1: ARRAY OF N CHARACTERS IN ASCII -C N - INTEGER: NUMBER OF CHARACTERS TO BE COMPARED -C -C OUTPUT ARGUMENT LIST: -C ICHKSTR - INTEGER: RETURN VALUE: -C 0 = STR(1:N) AND (CHR(I),I=1,N) ARE EQUIVALENT -C 1 = STR(1:N) AND (CHR(I),I=1,N) ARE NOT EQUIVALENT -C -C REMARKS: -C THIS ROUTINE CALLS: CHRTRNA -C THIS ROUTINE IS CALLED BY: CRBMG RDMSGB READERME -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - - CHARACTER*80 CSTR - CHARACTER*1 CHR(N) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Copy CHR into CSTR and, if necessary, convert the latter -C to EBCDIC (i.e. if the local machine uses EBCDIC) so that -C the subsequent comparison will always be valid. - - CALL CHRTRNA(CSTR,CHR,N) - -C Compare CSTR to STR. - - IF(CSTR(1:N).EQ.STR(1:N)) THEN - ICHKSTR = 0 - ELSE - ICHKSTR = 1 - ENDIF - - RETURN - END diff --git a/src/bufr/icmpdx.f b/src/bufr/icmpdx.f deleted file mode 100644 index 351ea0c776..0000000000 --- a/src/bufr/icmpdx.f +++ /dev/null @@ -1,91 +0,0 @@ - INTEGER FUNCTION ICMPDX(LUD,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ICMPDX -C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-06-18 -C -C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) -C HAS THE SAME INTERNAL TABLE INFORMATION AS LOGICAL UNIT IOLUN(LUD). -C NOTE THAT THIS DOES NOT NECESSARILY MEAN THAT IOLUN(LUN) AND -C IOLUN(LUD) ARE SHARING TABLE INFORMATION, SINCE TWO LOGICAL UNITS -C CAN HAVE THE SAME INTERNAL TABLE INFORMATION WITHOUT SHARING IT. -C -C PROGRAM HISTORY LOG: -C 2009-06-18 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: ICMPDX (LUD, LUN) -C INPUT ARGUMENT LIST: -C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR FIRST LOGICAL UNIT -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR SECOND LOGICAL UNIT -C -C OUTPUT ARGUMENT LIST: -C ICMPDX - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN) -C HAS THE SAME INTERNAL TABLE INFORMATION AS IOLUN(LUD): -C 0 - NO -C 1 - YES -C -C REMARKS: -C THIS ROUTINE CALLS: ISHRDX -C THIS ROUTINE IS CALLED BY: IOK2CPY MAKESTAB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C First, check whether the two units are actually sharing tables. -C If so, then they obviously have the same table information. - - ICMPDX = ISHRDX(LUD,LUN) - IF ( ICMPDX .EQ. 1 ) RETURN - -C Otherwise, check whether the internal Table A, B and D entries are -C all identical between the two units. - - IF ( ( NTBA(LUD) .EQ. 0 ) .OR. - . ( NTBA(LUN) .NE. NTBA(LUD) ) ) RETURN - DO I = 1, NTBA(LUD) - IF ( IDNA(I,LUN,1) .NE. IDNA(I,LUD,1) ) RETURN - IF ( IDNA(I,LUN,2) .NE. IDNA(I,LUD,2) ) RETURN - IF ( TABA(I,LUN) .NE. TABA(I,LUD) ) RETURN - ENDDO - - IF ( ( NTBB(LUD) .EQ. 0 ) .OR. - . ( NTBB(LUN) .NE. NTBB(LUD) ) ) RETURN - DO I = 1, NTBB(LUD) - IF ( IDNB(I,LUN) .NE. IDNB(I,LUD) ) RETURN - IF ( TABB(I,LUN) .NE. TABB(I,LUD) ) RETURN - ENDDO - - IF ( ( NTBD(LUD) .EQ. 0 ) .OR. - . ( NTBD(LUN) .NE. NTBD(LUD) ) ) RETURN - DO I = 1, NTBD(LUD) - IF ( IDND(I,LUN) .NE. IDND(I,LUD) ) RETURN - IF ( TABD(I,LUN) .NE. TABD(I,LUD) ) RETURN - ENDDO - - ICMPDX = 1 - - RETURN - END diff --git a/src/bufr/icopysb.f b/src/bufr/icopysb.f deleted file mode 100644 index 51d421863c..0000000000 --- a/src/bufr/icopysb.f +++ /dev/null @@ -1,48 +0,0 @@ - FUNCTION ICOPYSB(LUNIN,LUNOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ICOPYSB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE COPYSB -C AND PASSES BACK ITS RETURN CODE. SEE COPYSB FOR MORE DETAILS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: ICOPYSB (LUNIN, LUNOT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C OUTPUT ARGUMENT LIST: -C ICOPYSB - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the input -C BUFR message -C -C REMARKS: -C THIS ROUTINE CALLS: COPYSB -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CALL COPYSB(LUNIN,LUNOT,IRET) - ICOPYSB = IRET - RETURN - END diff --git a/src/bufr/icvidx.c b/src/bufr/icvidx.c deleted file mode 100644 index 7fe925a1c9..0000000000 --- a/src/bufr/icvidx.c +++ /dev/null @@ -1,40 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ICVIDX -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS ROUTINE COMPUTES A UNIQUE 1-DIMENSIONAL ARRAY -C INDEX FROM 2-DIMENSIONAL INDICES. THIS ALLOWS A 2-DIMENSIONAL -C (ROW-BY-COLUMN) ARRAY TO BE STORED AND ACCESSED AS A -C 1-DIMENSIONAL ARRAY. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL ICVIDX( II, JJ, NUMJJ ) -C INPUT ARGUMENT LIST: -C II - INTEGER: FIRST (ROW) INDEX -C JJ - INTEGER: SECOND (COLUMN) INDEX -C NUMJJ - INTEGER: MAXIMUM NUMBER OF COLUMN INDICES -C -C OUTPUT ARGUMENT LIST: -C ICVIDX - INTEGER: 1-DIMENSIONAL INDEX -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: READMT STSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -f77int icvidx( f77int *ii, f77int *jj, f77int *numjj ) -{ - return ( *numjj * (*ii) ) + *jj; -} diff --git a/src/bufr/idn30.f b/src/bufr/idn30.f deleted file mode 100644 index 8f2579fa1c..0000000000 --- a/src/bufr/idn30.f +++ /dev/null @@ -1,81 +0,0 @@ - FUNCTION IDN30(ADN30,L30) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IDN30 -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CONVERTS A DESCRIPTOR FROM ITS FIVE OR SIX -C CHARACTER ASCII REPRESENTATION TO ITS BIT-WISE (INTEGER) -C REPRESENTATION. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: IDN30 (ADN30, L30) -C INPUT ARGUMENT LIST: -C ADN30 - CHARACTER*(*): CHARACTER FORM OF DESCRIPTOR (FXY -C VALUE) -C L30 - INTEGER: LENGTH OF ADN30 (NUMBER OF CHARACTERS, 5 OR -C 6) -C -C OUTPUT ARGUMENT LIST: -C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) -C VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT IFXY -C THIS ROUTINE IS CALLED BY: STBFDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*(*) ADN30 - CHARACTER*128 BORT_STR - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(LEN(ADN30).LT.L30) GOTO 900 - IF(L30.EQ.5) THEN - READ(ADN30,'(I5)') IDN30 - IF(IDN30.LT.0 .OR. IDN30.GT.65535) GOTO 901 - ELSEIF(L30.EQ.6) THEN - IDN30 = IFXY(ADN30) - ELSE - GOTO 902 - ENDIF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A,'// - . '" CHARACTER LENGTH (",I4,") IS TOO SHORT (< L30,",I5)') - . ADN30,LEN(ADN30),L30 - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: IDN30 - DESCRIPTOR INTEGER '// - . 'REPRESENTATION, IDN30 (",I8,"), IS OUTSIDE 16-BIT RANGE '// - . '(0-65535)")') IDN30 - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A,'// - . '" CHARACTER LENGTH (",I4,") MUST BE EITHER 5 OR 6")') - . ADN30,L30 - CALL BORT(BORT_STR) - END diff --git a/src/bufr/idxmsg.f b/src/bufr/idxmsg.f deleted file mode 100644 index b091c5c378..0000000000 --- a/src/bufr/idxmsg.f +++ /dev/null @@ -1,58 +0,0 @@ - FUNCTION IDXMSG( MESG ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IDXMSG -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS FUNCTION DETERMINES WHETHER THE GIVEN BUFR MESSAGE -C IS A DX DICTIONARY MESSAGE THAT WAS CREATED BY THE BUFR ARCHIVE -C LIBRARY SOFTWARE. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IDXMSG( MESG ) -C INPUT ARGUMENT LIST: -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR MESSAGE -C -C OUTPUT ARGUMENT LIST: -C IDXMSG - INTEGER: RETURN VALUE: -C 0 - MESG IS NOT A DX DICTIONARY MESSAGE -C 1 - MESG IS A DX DICTIONARY MESSAGE -C -C REMARKS: -C THIS ROUTINE CALLS: IUPBS01 -C THIS ROUTINE IS CALLED BY: CPDXMM DATEBF DUMPBF MESGBC -C MESGBF MSGWRT RDBFDX READMG -C POSAPX READERME UFBMEM -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MESG(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Note that the following test relies upon logic within subroutine -C DXMINI which zeroes out the Section 1 date of all DX dictionary -C messages. - - IF ( (IUPBS01(MESG,'MTYP').EQ.11) .AND. - . (IUPBS01(MESG,'MNTH').EQ.0) .AND. - . (IUPBS01(MESG,'DAYS').EQ.0) .AND. - . (IUPBS01(MESG,'HOUR').EQ.0) ) THEN - IDXMSG = 1 - ELSE - IDXMSG = 0 - END IF - - RETURN - END diff --git a/src/bufr/ifbget.f b/src/bufr/ifbget.f deleted file mode 100644 index b75af39331..0000000000 --- a/src/bufr/ifbget.f +++ /dev/null @@ -1,85 +0,0 @@ - FUNCTION IFBGET(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IFBGET -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CHECKS TO SEE IF ANY UNREAD SUBSETS ARE IN -C AN INPUT BUFR MESSAGE PREVIOUSLY OPENED BY BUFR ARCHIVE LIBRARY -C SUBROUTINE OPENMG OR OPENMB. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: IFBGET (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C IFBGET - INTEGER: RETURN CODE: -C 0 = there is at least one more subset in the -C message -C -1 = there are no more subsets in the message -C -C REMARKS: -C THIS ROUTINE CALLS: BORT STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT -C ------------------------------------------ - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE -C --------------------------------------------- - - IF(NSUB(LUN).LT.MSUB(LUN)) THEN - IFBGET = 0 - ELSE - IFBGET = -1 - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: IFBGET - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: IFBGET - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: IFBGET - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') - END diff --git a/src/bufr/ifxy.f b/src/bufr/ifxy.f deleted file mode 100644 index 3bd7620bdf..0000000000 --- a/src/bufr/ifxy.f +++ /dev/null @@ -1,66 +0,0 @@ - FUNCTION IFXY(ADSC) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IFXY -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION RETURNS THE INTEGER CORRESPONDING TO THE -C BIT-WISE REPRESENTATION OF AN INPUT CHARACTER FXY VALUE OF LENGTH -C SIX. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C -C USAGE: IFXY (ADSC) -C INPUT ARGUMENT LIST: -C ADSC - CHARACTER*6: CHARACTER FORM OF DESCRIPTOR (FXY VALUE) -C -C OUTPUT ARGUMENT LIST: -C IFXY - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) -C VALUE -C -C REMARKS: -C -C EXAMPLE: -C -C If ADSC = '063022', then IFXY = 16150 since: -C -C 0 63 22 -C -C F | X | Y -C | | -C 0 0 1 1 1 1 1 1 0 0 0 1 0 1 1 0 = -C -C ( 2**13 + 2**12 + 2**11 + 2**10 + -C 2**9 + 2**8 + 2**4 + 2**2 + 2**1 ) = 16150 -C -C -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: BFRINI DXINIT GETNTBE IDN30 -C NEMTAB NEMTBB NEMTBD NUMTBD -C RESTD SNTBDE STBFDX STNTBI -C STSEQ UFBQCP -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*6 ADSC - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - READ(ADSC,'(I1,I2,I3)') IF,IX,IY - IFXY = IF*2**14 + IX*2**8 + IY - RETURN - END diff --git a/src/bufr/igetdate.f b/src/bufr/igetdate.f deleted file mode 100644 index 2f01b6a5a5..0000000000 --- a/src/bufr/igetdate.f +++ /dev/null @@ -1,60 +0,0 @@ - FUNCTION IGETDATE(MBAY,IYR,IMO,IDY,IHR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IGETDATE -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS THE SECTION 1 DATE-TIME -C FROM THE BUFR MESSAGE STORED IN ARRAY MBAY. IT WILL WORK ON ANY -C MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE START OF THE -C BUFR MESSAGE, (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE FIRST -C FOUR BYTES OF MBAY. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IGETDATE (MBAY, IYR, IMO, IDY, IHR) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR MESSAGE -C -C OUTPUT ARGUMENT LIST: -C IYR - INTEGER: SECTION 1 YEAR (YYYY OR YY, DEPENDING ON -C DATELEN() VALUE) -C IMO - INTEGER: SECTION 1 MONTH (MM) -C IDY - INTEGER: SECTION 1 DAY (DD) -C IHR - INTEGER: SECTION 1 HOUR (HH) -C IGETDATE - INTEGER: SECTION 1 DATE-TIME (YYYYMMDDHH OR YYMMDDHH, -C DEPENDING ON DATELEN() VALUE) -C -C REMARKS: -C THIS ROUTINE CALLS: IUPBS01 -C THIS ROUTINE IS CALLED BY: CKTABA DATEBF DUMPBF -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /DATELN/ LENDAT - - DIMENSION MBAY(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IYR = IUPBS01(MBAY,'YEAR') - IMO = IUPBS01(MBAY,'MNTH') - IDY = IUPBS01(MBAY,'DAYS') - IHR = IUPBS01(MBAY,'HOUR') - IF(LENDAT.NE.10) THEN - IYR = MOD(IYR,100) - ENDIF - IGETDATE = (IYR*1000000) + (IMO*10000) + (IDY*100) + IHR - - RETURN - END diff --git a/src/bufr/igetfxy.f b/src/bufr/igetfxy.f deleted file mode 100644 index 1b810c20e5..0000000000 --- a/src/bufr/igetfxy.f +++ /dev/null @@ -1,79 +0,0 @@ - FUNCTION IGETFXY ( STR, CFXY ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IGETFXY -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS FUNCTION LOOKS FOR AND RETURNS A VALID FXY NUMBER -C FROM WITHIN THE GIVEN INPUT STRING. THE FXY NUMBER MAY BE IN -C FORMAT OF EITHER FXXYYY OR F-XX-YYY WITHIN THE INPUT STRING, BUT -C IT IS ALWAYS RETURNED IN FORMAT FXXYYY UPON OUTPUT. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IGETFXY ( STR, CFXY ) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): INPUT STRING -C -C OUTPUT ARGUMENT LIST: -C CFXY - CHARACTER*6: FXY NUMBER IN FORMAT FXXYYY -C IGETFXY - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = could not find a valid FXY number in STR -C -C REMARKS: -C THIS ROUTINE CALLS: JSTCHR NUMBCK -C THIS ROUTINE IS CALLED BY: GETNTBE SNTBDE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - CHARACTER*6 CFXY - - PARAMETER ( LSTR2 = 120 ) - CHARACTER*(LSTR2) STR2 - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IGETFXY = -1 - - LSTR = LEN ( STR ) - IF ( LSTR .LT. 6 ) RETURN - -C Left-justify a copy of the input string. - - IF ( LSTR .GT. LSTR2 ) THEN - STR2(1:LSTR2) = STR(1:LSTR2) - ELSE - STR2 = STR - ENDIF - CALL JSTCHR ( STR2, IRET ) - IF ( IRET .NE. 0 ) RETURN - -C Look for an FXY number. - - IF ( INDEX ( STR2, '-' ) .NE. 0 ) THEN -C Format of field is F-XX-YYY. - CFXY(1:1) = STR2(1:1) - CFXY(2:3) = STR2(3:4) - CFXY(4:6) = STR2(6:8) - ELSE -C Format of field is FXXYYY. - CFXY = STR2(1:6) - ENDIF - -C Check that the FXY number is valid. - - IF ( NUMBCK ( CFXY ) .EQ. 0 ) IGETFXY = 0 - - RETURN - END diff --git a/src/bufr/igetntbi.f b/src/bufr/igetntbi.f deleted file mode 100644 index 999f8f00ce..0000000000 --- a/src/bufr/igetntbi.f +++ /dev/null @@ -1,66 +0,0 @@ - FUNCTION IGETNTBI ( LUN, CTB ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IGETNTBI -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS FUNCTION RETURNS THE NEXT AVAILABLE INDEX FOR -C STORING AN ENTRY WITHIN INTERNAL BUFR TABLE CTB. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL IGETNTBI ( LUN, CTB ) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C CTB - CHARACTER*1: INTERNAL BUFR TABLE FROM WHICH TO RETURN -C THE NEXT AVAILABLE INDEX ('A','B', OR 'D') -C -C OUTPUT ARGUMENT LIST: -C IGETNTBI - INTEGER: NEXT AVAILABLE INDEX IN TABLE CTB -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: RDUSDX READS3 STBFDX STSEQ -C Not normally called by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABA, TABB, BORT_STR - CHARACTER*1 CTB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF ( CTB .EQ. 'A' ) THEN - IGETNTBI = NTBA(LUN) + 1 - IMAX = NTBA(0) - ELSE IF ( CTB .EQ. 'B' ) THEN - IGETNTBI = NTBB(LUN) + 1 - IMAX = NTBB(0) - ELSE IF ( CTB .EQ. 'D' ) THEN - IGETNTBI = NTBD(LUN) + 1 - IMAX = NTBD(0) - ENDIF - IF ( IGETNTBI .GT. IMAX ) GOTO 900 - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: IGETNTBI - NUMBER OF INTERNAL TABLE' - . //'",A1," ENTRIES EXCEEDS THE LIMIT (",I4,")")') CTB, IMAX - CALL BORT(BORT_STR) - END diff --git a/src/bufr/igetntbl.f b/src/bufr/igetntbl.f deleted file mode 100644 index 1074a3a56e..0000000000 --- a/src/bufr/igetntbl.f +++ /dev/null @@ -1,59 +0,0 @@ - FUNCTION IGETNTBL ( LUNT, LINE ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IGETNTBL -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS FUNCTION GETS THE NEXT LINE FROM THE ASCII MASTER -C TABLE FILE SPECIFIED BY LUNT, IGNORING ANY BLANK LINES OR COMMENT -C LINES IN THE PROCESS. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IGETNTBL ( LUNT, LINE ) -C INPUT ARGUMENT LIST: -C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING MASTER TABLE INFORMATION -C -C OUTPUT ARGUMENT LIST: -C LINE - CHARACTER*(*): NEXT NON-BLANK, NON-COMMENT LINE READ -C FROM LUNT -C IGETNTBL - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = end-of-file encountered while reading -C from LUNT -C -2 = I/O error encountered while reading -C from LUNT -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: GETNTBE GETTBH SNTBDE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) LINE - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - 10 READ ( LUNT, '(A)', END=100, ERR=200 ) LINE - IF ( ( LINE .EQ. ' ' ) .OR. ( LINE(1:1) .EQ. '#' ) ) GOTO 10 - IF ( LINE(1:3) .EQ. 'END' ) GOTO 100 - - IGETNTBL = 0 - RETURN - - 100 IGETNTBL = -1 - RETURN - - 200 IGETNTBL = -2 - RETURN - - END diff --git a/src/bufr/igetsc.f b/src/bufr/igetsc.f deleted file mode 100644 index 38e675b425..0000000000 --- a/src/bufr/igetsc.f +++ /dev/null @@ -1,55 +0,0 @@ - FUNCTION IGETSC(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IGETSC -C PRGMMR: J. ATOR ORG: NP12 DATE: 2010-05-11 -C -C ABSTRACT: THIS FUNCTION RETURNS ANY STATUS CODE THAT WAS INTERNALLY -C SET WITHIN THE BUFR ARCHIVE LIBRARY SOFTWARE FOR A GIVEN LOGICAL -C UNIT NUMBER -C -C PROGRAM HISTORY LOG: -C 2010-05-11 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IGETSC (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C IGETSC - INTEGER: STATUS CODE FOR LUNIT: -C 0 = no problems noted with LUNIT -C -1 = unable to position LUNIT for appending, -C possibly due to an incomplete BUFR message -C at the end of the file -C -C REMARKS: -C THIS ROUTINE CALLS: BORT STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /STCODE/ ISCODES(NFILES) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Make sure the specified logical unit is connected to the library. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - - IGETSC = ISCODES(LUN) - - RETURN - 900 CALL BORT('BUFRLIB: IGETSC - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') - END diff --git a/src/bufr/igettdi.f b/src/bufr/igettdi.f deleted file mode 100644 index fed3282d02..0000000000 --- a/src/bufr/igettdi.f +++ /dev/null @@ -1,69 +0,0 @@ - FUNCTION IGETTDI ( IFLAG ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IGETTDI -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: DEPENDING ON THE VALUE OF THE INPUT FLAG, THIS FUNCTION -C EITHER RETURNS THE NEXT USABLE SCRATCH TABLE D INDEX FOR THE -C CURRENT MASTER TABLE OR ELSE RESETS THE INDEX BACK TO ITS -C MINIMUM VALUE. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL IGETTDI ( IFLAG ) -C INPUT ARGUMENT LIST: -C IFLAG - INTEGER: FLAG: IF SET TO 0, THEN THE FUNCTION WILL -C RESET THE SCRATCH TABLE D INDEX BACK TO ITS MINIMUM -C VALUE; OTHERWISE, IT WILL RETURN THE NEXT USABLE -C SCRATCH TABLE D INDEX FOR THE CURRENT MASTER TABLE -C -C OUTPUT ARGUMENT LIST: -C IGETTDI - INTEGER: NEXT USABLE SCRATCH TABLE D INDEX FOR THE -C CURRENT MASTER TABLE -C -1 = FUNCTION WAS CALLED WITH IFLAG=0 -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: READMT READS3 STSEQ -C Not normally called by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - PARAMETER ( IDXMIN = 62976 ) -C* = IFXY('354000') - - PARAMETER ( IDXMAX = 63231 ) -C* = IFXY('354255') - - CHARACTER*128 BORT_STR - - SAVE IDX - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF ( IFLAG .EQ. 0 ) THEN - -C* Initialize the index to one less than the actual minimum -C* value. That way, the next normal call will return the -C* minimum value. - - IDX = IDXMIN - 1 - IGETTDI = -1 - ELSE - IDX = IDX + 1 - IF ( IDX .GT. IDXMAX ) GOTO 900 - IGETTDI = IDX - ENDIF - - RETURN - 900 CALL BORT('BUFRLIB: IGETTDI - IDXMAX OVERFLOW') - END diff --git a/src/bufr/inctab.f b/src/bufr/inctab.f deleted file mode 100644 index 17c67176ad..0000000000 --- a/src/bufr/inctab.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE INCTAB(ATAG,ATYP,NODE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: INCTAB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE RETURNS THE NEXT AVAILABLE POSITIONAL INDEX -C FOR WRITING INTO THE INTERNAL JUMP/LINK TABLE IN COMMON BLOCK -C /TABLES/, AND IT ALSO USES THAT INDEX TO STORE ATAG AND ATYP -C WITHIN, RESPECTIVELY, THE INTERNAL JUMP/LINK TABLE ARRAYS TAG(*) -C AND TYP(*). IF THERE IS NO MORE ROOM FOR ADDITIONAL ENTRIES WITHIN -C THE INTERNAL JUMP/LINK TABLE, THEN AN APPROPRIATE CALL IS MADE TO -C BUFR ARCHIVE LIBRARY SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: CALL INCTAB (ATAG, ATYP, NODE) -C INPUT ARGUMENT LIST: -C ATAG - CHARACTER*(*): MNEMONIC NAME -C ATYP - CHARACTER*(*): MNEMONIC TYPE -C -C OUTPUT ARGUMENT LIST: -C NODE - INTEGER: NEXT AVAILABLE POSITIONAL INDEX FOR WRITING -C INTO THE INTERNAL JUMP/LINK TABLE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: TABENT TABSUB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*(*) ATAG,ATYP - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - NTAB = NTAB+1 - IF(NTAB.GT.MAXTAB) GOTO 900 - TAG(NTAB) = ATAG - TYP(NTAB) = ATYP - NODE = NTAB - -C EXITS -C ----- - - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: INCTAB - THE NUMBER OF JUMP/LINK '// - . 'TABLE ENTRIES EXCEEDS THE LIMIT, MAXTAB (",I7,")")') MAXTAB - CALL BORT(BORT_STR) - END diff --git a/src/bufr/invcon.f b/src/bufr/invcon.f deleted file mode 100644 index 25a7a59c06..0000000000 --- a/src/bufr/invcon.f +++ /dev/null @@ -1,107 +0,0 @@ - FUNCTION INVCON(NC,LUN,INV1,INV2) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: INVCON -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION SEARCHES A "WINDOW" (SEE BELOW REMARKS) FOR AN -C ELEMENT IDENTIFIED IN THE USER STRING AS A CONDITIONAL NODE (I.E. AN -C ELEMENT WHICH MUST MEET A CONDITION IN ORDER TO BE READ FROM OR WRITTEN TO -C A DATA SUBSET). IF A CONDITIONAL ELEMENT IS FOUND AND IT CONFORMS TO THE -C CONDITION, THEN THE INDEX OF THE ELEMENT WITHIN THE WINDOW IS RETURNED. -C OTHERWISE A VALUE OF ZERO IS RETURNED. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE); OUTPUTS MORE -C COMPLETE DIAGNOSTIC INFO WHEN UNUSUAL -C THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C 2010-04-27 J. WOOLLEN -- ADD DOCUMENTATION -C -C USAGE: INVCON (NC, LUN, INV1, INV2) -C INPUT ARGUMENT LIST: -C NC - INTEGER: CONDITION CODE: -C 1 = '=' (EQUAL) -C 2 = '!' (NOT EQUAL) -C 3 = '<' (LESS THAN) -C 4 = '>' (GREATER THAN) -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INV1 - INTEGER: FIRST INDEX OF WINDOW TO SEARCH -C INV2 - INTEGER: LAST INDEX OF WINDOW TO SEARCH -C -C OUTPUT ARGUMENT LIST: -C INVCON - INTEGER: INDEX WITHIN WINDOW OF CONDITIONAL NODE CONFORMING -C TO SPECIFIED CONDITION -C 0 = NONE FOUND -C -C REMARKS: -C -C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN -C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. -C -C THIS ROUTINE CALLS: ERRWRT -C THIS ROUTINE IS CALLED BY: CONWIN -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /QUIET / IPRT - - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C CHECK THE INVENTORY INTERVAL -C ---------------------------- - - IF(INV1.LE.0 .OR. INV1.GT.NVAL(LUN)) GOTO 99 - IF(INV2.LE.0 .OR. INV2.GT.NVAL(LUN)) GOTO 99 - -C FIND AN OCCURANCE OF NODE IN THE WINDOW MEETING THIS CONDITION -C -------------------------------------------------------------- - - DO INVCON=INV1,INV2 - IF(INV(INVCON,LUN).EQ.NODC(NC)) THEN - IF(KONS(NC).EQ.1 .AND. VAL(INVCON,LUN).EQ.IVLS(NC)) GOTO 100 - IF(KONS(NC).EQ.2 .AND. VAL(INVCON,LUN).NE.IVLS(NC)) GOTO 100 - IF(KONS(NC).EQ.3 .AND. VAL(INVCON,LUN).LT.IVLS(NC)) GOTO 100 - IF(KONS(NC).EQ.4 .AND. VAL(INVCON,LUN).GT.IVLS(NC)) GOTO 100 - ENDIF - ENDDO - -99 INVCON = 0 - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT('BUFRLIB: INVCON - RETURNING WITH A VALUE OF 0') - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/invmrg.f b/src/bufr/invmrg.f deleted file mode 100644 index ebf75a2c6a..0000000000 --- a/src/bufr/invmrg.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE INVMRG(LUBFI,LUBFJ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: INVMRG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 -C -C ABSTRACT: THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE -C DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERENT OR UNIQUE -C OBSERVATIONAL DATA. IT CANNOT MERGE REPLICATED DATA. -C -C PROGRAM HISTORY LOG: -C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-11-25 J. WOOLLEN -- MODIFIED FOR RADIOSONDE CALL SIGNS -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES; -C REMOVED ENTRY POINT MRGINV (IT BECAME A -C SEPARATE ROUTINE IN THE BUFRLIB TO -C INCREASE PORTABILITY TO OTHER PLATFORMS) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS AND SIMPLIFY LOGIC -C -C USAGE: CALL INVMRG (LUBFI, LUBFJ) -C INPUT ARGUMENT LIST: -C LUBFI - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUBFJ - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IBFMS NWORDS STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*3 TYP - LOGICAL HEREI,HEREJ,MISSI,MISSJ,SAMEI - REAL*8 VAL - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IS = 1 - JS = 1 - -C GET THE UNIT POINTERS -C --------------------- - - CALL STATUS(LUBFI,LUNI,IL,IM) - CALL STATUS(LUBFJ,LUNJ,JL,JM) - -C STEP THROUGH THE BUFFERS COMPARING THE INVENTORY AND MERGING DATA -C ----------------------------------------------------------------- - - DO WHILE(IS.LE.NVAL(LUNI)) - -C CHECK TO SEE WE ARE AT THE SAME NODE IN EACH BUFFER -C --------------------------------------------------- - - NODE = INV(IS,LUNI) - NODJ = INV(JS,LUNJ) - IF(NODE.NE.NODJ) GOTO 900 - - ITYP = ITP(NODE) - -C FOR TYPE 1 NODES DO AN ENTIRE SEQUENCE REPLACEMENT -C -------------------------------------------------- - - IF(ITYP.EQ.1) THEN - IF(TYP(NODE).EQ.'DRB') IOFF = 0 - IF(TYP(NODE).NE.'DRB') IOFF = 1 - IWRDS = NWORDS(IS,LUNI)+IOFF - JWRDS = NWORDS(JS,LUNJ)+IOFF - IF(IWRDS.GT.IOFF .AND. JWRDS.EQ.IOFF) THEN - DO N=NVAL(LUNJ),JS+1,-1 - INV(N+IWRDS-JWRDS,LUNJ) = INV(N,LUNJ) - VAL(N+IWRDS-JWRDS,LUNJ) = VAL(N,LUNJ) - ENDDO - DO N=0,IWRDS - INV(JS+N,LUNJ) = INV(IS+N,LUNI) - VAL(JS+N,LUNJ) = VAL(IS+N,LUNI) - ENDDO - NVAL(LUNJ) = NVAL(LUNJ)+IWRDS-JWRDS - JWRDS = IWRDS - NRPL = NRPL+1 - ENDIF - IS = IS+IWRDS - JS = JS+JWRDS - ENDIF - -C FOR TYPES 2 AND 3 FILL MISSINGS -C ------------------------------- - - IF((ITYP.EQ.2).OR.(ITYP.EQ.3)) THEN - HEREI = IBFMS(VAL(IS,LUNI)).EQ.0 - HEREJ = IBFMS(VAL(JS,LUNJ)).EQ.0 - MISSI = .NOT.(HEREI) - MISSJ = .NOT.(HEREJ) - SAMEI = VAL(IS,LUNI).EQ.VAL(JS,LUNJ) - IF(HEREI.AND.MISSJ) THEN - VAL(JS,LUNJ) = VAL(IS,LUNI) - NMRG = NMRG+1 - ELSEIF(HEREI.AND.HEREJ.AND..NOT.SAMEI) THEN - NAMB = NAMB+1 - ENDIF - ENDIF - -C BUMP THE COUNTERS AND GO CHECK THE NEXT PAIR -C -------------------------------------------- - - IS = IS + 1 - JS = JS + 1 - ENDDO - - NTOT = NTOT+1 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '// - . '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), '// - . 'TABULAR MISMATCH")') NODE,NODJ - CALL BORT(BORT_STR) - END diff --git a/src/bufr/invtag.f b/src/bufr/invtag.f deleted file mode 100644 index 32a063a4fc..0000000000 --- a/src/bufr/invtag.f +++ /dev/null @@ -1,99 +0,0 @@ - FUNCTION INVTAG(NODE,LUN,INV1,INV2) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: INVTAG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION LOOKS FOR A SPECIFIED MNEMONIC WITHIN THE -C PORTION OF THE CURRENT SUBSET BUFFER BOUNDED BY THE INDICES INV1 -C AND INV2. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION INVWIN, -C EXCEPT THAT INVWIN SEARCHES BASED ON THE ACTUAL NODE WITHIN THE -C INTERNAL JUMP/LINK TABLE, RATHER THAN ON THE MNEMONIC CORRESPONDING -C TO THAT NODE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN UNUSUAL THINGS HAPPEN -C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: INVTAG (NODE, LUN, INV1, INV2) -C INPUT ARGUMENT LIST: -C NODE - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK -C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK -C -C OUTPUT ARGUMENT LIST: -C INVTAG - INTEGER: LOCATION INDEX OF NODE WITHIN SPECIFIED -C PORTION OF SUBSET BUFFER -C 0 = NOT FOUND -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT -C THIS ROUTINE IS CALLED BY: UFBRP UFBSEQ UFBSP -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET/ IPRT - - CHARACTER*10 TAG,TAGN - CHARACTER*3 TYP - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - INVTAG = 0 - IF(NODE.EQ.0) GOTO 200 - TAGN = TAG(NODE) - -C SEARCH BETWEEN INV1 AND INV2 -C ---------------------------- - -10 DO INVTAG=INV1,INV2 - IF(TAG(INV(INVTAG,LUN)).EQ.TAGN) GOTO 100 - ENDDO - - INVTAG = 0 - -200 IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT('BUFRLIB: INVTAG - RETURNING WITH A VALUE OF 0') - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/invwin.f b/src/bufr/invwin.f deleted file mode 100644 index 48f5217255..0000000000 --- a/src/bufr/invwin.f +++ /dev/null @@ -1,90 +0,0 @@ - FUNCTION INVWIN(NODE,LUN,INV1,INV2) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: INVWIN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION LOOKS FOR A SPECIFIED NODE WITHIN THE PORTION -C OF THE CURRENT SUBSET BUFFER BOUNDED BY THE INDICES INV1 AND INV2. -C IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION INVTAG, EXCEPT THAT -C INVTAG SEARCHES BASED ON THE MNEMONIC CORRESPONDING TO THE NODE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN UNUSUAL THINGS HAPPEN -C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: INVWIN (NODE, LUN, INV1, INV2) -C INPUT ARGUMENT LIST: -C NODE - INTEGER: JUMP/LINK TABLE INDEX TO LOOK FOR -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK -C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK -C -C OUTPUT ARGUMENT LIST: -C INVWIN - INTEGER: LOCATION INDEX OF NODE WITHIN SPECIFIED -C PORTION OF SUBSET BUFFER -C 0 = NOT FOUND -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT -C THIS ROUTINE IS CALLED BY: DRSTPL GETWIN NEVN TRYBUMP -C UFBGET UFBRW UFBSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET/ IPRT - - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - INVWIN = 0 - IF(NODE.EQ.0) GOTO 200 - -C SEARCH BETWEEN INV1 AND INV2 -C ---------------------------- - -10 DO INVWIN=INV1,INV2 - IF(INV(INVWIN,LUN).EQ.NODE) GOTO 100 - ENDDO - - INVWIN = 0 - - 200 IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT('BUFRLIB: INVWIN - RETURNING WITH A VALUE OF 0') - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/iok2cpy.f b/src/bufr/iok2cpy.f deleted file mode 100644 index ec2d000240..0000000000 --- a/src/bufr/iok2cpy.f +++ /dev/null @@ -1,97 +0,0 @@ - INTEGER FUNCTION IOK2CPY(LUI,LUO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IOK2CPY -C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-06-26 -C -C ABSTRACT: THIS FUNCTION DETERMINES WHETHER A MESSAGE, OR A SUBSET -C FROM A MESSAGE, CAN BE COPIED FROM LOGICAL UNIT IOLUN(LUI) TO -C LOGICAL UNIT IOLUN(LUO). THE DECISION IS BASED ON WHETHER THE -C EXACT SAME DEFINITION FOR THE GIVEN MESSAGE TYPE APPEARS WITHIN -C THE DICTIONARY TABLE INFORMATION FOR BOTH LOGICAL UNITS. NOTE THAT -C IT IS POSSIBLE FOR A MESSAGE TYPE TO BE IDENTICALLY DEFINED FOR TWO -C DIFFERENT LOGICAL UNITS EVEN IF THE UNITS THEMSELVES DON'T SHARE -C THE EXACT SAME FULL SET OF DICTIONARY TABLES. -C -C PROGRAM HISTORY LOG: -C 2009-06-26 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IOK2CPY (LUI, LUO) -C INPUT ARGUMENT LIST: -C LUI - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR LOGICAL UNIT TO COPY FROM -C LUO - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR LOGICAL UNIT TO COPY TO -C -C OUTPUT ARGUMENT LIST: -C IOK2CPY - INTEGER: RETURN CODE INDICATING WHETHER IT IS OKAY TO -C COPY FROM IOLUN(LUI) TO IOLUN(LUO) -C 0 - NO -C 1 - YES -C -C REMARKS: -C THIS ROUTINE CALLS: ICMPDX NEMTBAX -C THIS ROUTINE IS CALLED BY: COPYSB COPYMG CPYMEM UFBCPY -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*8 SUBSET - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IOK2CPY = 0 - -C Do both logical units have the same internal table information? - - IF ( ICMPDX(LUI,LUO) .EQ. 1 ) THEN - IOK2CPY = 1 - RETURN - ENDIF - -C No, so get the Table A mnemonic from the message to be copied, -C then check whether that mnemonic is defined within the dictionary -C tables for the logical unit to be copied to. - - SUBSET = TAG(INODE(LUI)) - CALL NEMTBAX(LUO,SUBSET,MTYP,MSBT,INOD) - IF ( INOD .EQ. 0 ) RETURN - -C The Table A mnemonic is defined within the dictionary tables for -C both units, so now make sure the definitions are identical. - - NTEI = ISC(INODE(LUI))-INODE(LUI) - NTEO = ISC(INOD)-INOD - IF ( NTEI .NE. NTEO ) RETURN - - DO I = 1, NTEI - IF ( TAG(INODE(LUI)+I) .NE. TAG(INOD+I) ) RETURN - IF ( TYP(INODE(LUI)+I) .NE. TYP(INOD+I) ) RETURN - IF ( ISC(INODE(LUI)+I) .NE. ISC(INOD+I) ) RETURN - IF ( IRF(INODE(LUI)+I) .NE. IRF(INOD+I) ) RETURN - IF ( IBT(INODE(LUI)+I) .NE. IBT(INOD+I) ) RETURN - ENDDO - - IOK2CPY = 1 - - RETURN - END diff --git a/src/bufr/ipkm.f b/src/bufr/ipkm.f deleted file mode 100644 index c3c24d03bc..0000000000 --- a/src/bufr/ipkm.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE IPKM(CBAY,NBYT,N) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IPKM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER N INTO A CHARACTER STRING -C CBAY OF LENGTH NBYT BYTES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS -C IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL IPKM (CBAY, NBYT, N) -C INPUT ARGUMENT LIST: -C NBYT - INTEGER: NUMBER OF BYTES INTO WHICH TO PACK N (LENGTH -C OF STRING) -C N - INTEGER: INTEGER TO BE PACKED -C -C OUTPUT ARGUMENT LIST: -C CBAY - CHARACTER*8: STRING OF LENGTH NBYT BYTES CONTAINING -C PACKED INTEGER N -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IREV -C THIS ROUTINE IS CALLED BY: BFRINI CHRTRNA CRBMG PKC -C PKTDD UPC WRDXTB WRTREE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*128 BORT_STR - CHARACTER*8 CBAY,CINT - EQUIVALENCE (CINT,INT) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(NBYT.GT.NBYTW) GOTO 900 - -C Note that the widths of input variable N and local variable INT -C will both be equal to the default size of an integer (= NBYTW), -C since they aren't specifically declared otherwise. - - INT = IREV(ISHFT(N,(NBYTW-NBYT)*8)) - DO I=1,NBYT - CBAY(I:I) = CINT(I:I) - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: IPKM - NUMBER OF BYTES BEING PACKED '// - . ', NBYT (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// - . 'MACHINE, NBYTW (",I3,")")') NBYT,NBYTW - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ipks.f b/src/bufr/ipks.f deleted file mode 100644 index b0698a44ce..0000000000 --- a/src/bufr/ipks.f +++ /dev/null @@ -1,96 +0,0 @@ - INTEGER FUNCTION IPKS(VAL,NODE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IPKS -C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-03-02 -C -C ABSTRACT: THIS FUNCTION PACKS A REAL*8 USER VALUE INTO A BUFR -C INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES. -C NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX -C NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*); -C HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A -C 2-03 OPERATOR IS IN EFFECT FOR THIS NODE. -C -C PROGRAM HISTORY LOG: -C 2012-03-02 J. ATOR -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL -C STATEMENT FUNCTION IN WRTREE -C -C USAGE: IPKS (VAL,NODE) -C INPUT ARGUMENT LIST: -C VAL - REAL*8: USER VALUE -C NODE - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES -C -C OUTPUT ARGUMENT LIST: -C IPKS - INTEGER: PACKED BUFR VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: WRTREE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), - . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV - - CHARACTER*10 TAG - CHARACTER*8 TAGNRV - CHARACTER*3 TYP - - REAL*8 TEN,VAL - - DATA TEN /10./ - -C----------------------------------------------------------------------- - - IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - IRF(NODE) - - IF ( NNRV .GT. 0 ) THEN - -C There are redefined reference values in the jump/link table, -C so we need to check if this node is affected by any of them. - - DO JJ = 1, NNRV - IF ( NODE .EQ. INODNRV(JJ) ) THEN - -C This node contains a redefined reference value. -C Per the rules of BUFR, negative values should be encoded -C as positive integers with the left-most bit set to 1. - - NRV(JJ) = NINT(VAL) - IF ( NRV(JJ) .LT. 0 ) THEN - IMASK = 2**(IBT(NODE)-1) - IPKS = IOR(IABS(NRV(JJ)),IMASK) - ELSE - IPKS = NRV(JJ) - END IF - RETURN - ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND. - . ( NODE .GE. ISNRV(JJ) ) .AND. - . ( NODE .LE. IENRV(JJ) ) ) THEN - -C The corresponding redefinded reference value needs to -C be used when encoding this value. - - IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - NRV(JJ) - RETURN - END IF - END DO - - END IF - - RETURN - END diff --git a/src/bufr/ireadmg.f b/src/bufr/ireadmg.f deleted file mode 100644 index 98743b2cb9..0000000000 --- a/src/bufr/ireadmg.f +++ /dev/null @@ -1,54 +0,0 @@ - FUNCTION IREADMG(LUNIT,SUBSET,IDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IREADMG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READMG -C AND PASSES BACK ITS RETURN CODE. SEE READMG FOR MORE DETAILS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1999-11-18 J. WOOLLEN -- ADDED NEW FUNCTION ENTRY POINTS IREADMM AND -C IREADIBM -C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINTS ICOPYSB, IREADFT, -C IREADIBM, IREADMM, IREADNS AND IREADSB -C (THEY BECAME SEPARATE ROUTINES IN THE -C BUFRLIB TO INCREASE PORTABILITY TO OTHER -C PLATFORMS) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: IREADMG (LUNIT, SUBSET, IDATE) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IREADMG - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more BUFR messages in LUNIT -C -C REMARKS: -C THIS ROUTINE CALLS: READMG -C THIS ROUTINE IS CALLED BY: UFBTAB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*8 SUBSET - CALL READMG(LUNIT,SUBSET,IDATE,IRET) - IREADMG = IRET - RETURN - END diff --git a/src/bufr/ireadmm.f b/src/bufr/ireadmm.f deleted file mode 100644 index 1f10ee2e9e..0000000000 --- a/src/bufr/ireadmm.f +++ /dev/null @@ -1,56 +0,0 @@ - FUNCTION IREADMM(IMSG,SUBSET,IDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IREADMM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 -C -C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READMM -C AND PASSES BACK ITS RETURN CODE. SEE READMM FOR MORE DETAILS. -C -C PROGRAM HISTORY LOG: -C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: IREADMM (IMSG, SUBSET, IDATE) -C INPUT ARGUMENT LIST: -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C STORAGE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IREADMM - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = IMSG is either 0 or greater than the -C number of messages in memory -C -C REMARKS: -C THIS ROUTINE CALLS: READMM -C THIS ROUTINE IS CALLED BY: UFBMNS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*8 SUBSET - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL READMM(IMSG,SUBSET,IDATE,IRET) - IREADMM = IRET - - RETURN - END diff --git a/src/bufr/ireadns.f b/src/bufr/ireadns.f deleted file mode 100644 index fcf2f1407f..0000000000 --- a/src/bufr/ireadns.f +++ /dev/null @@ -1,51 +0,0 @@ - FUNCTION IREADNS(LUNIT,SUBSET,IDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IREADNS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READNS -C AND PASSES BACK ITS RETURN CODE. SEE READNS FOR MORE DETAILS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: IREADNS (LUNIT, SUBSET, IDATE) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE -C CONTAINING SUBSET BEING READ -C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE CONTAINING SUBSET BEING READ, IN FORMAT OF -C EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON DATELEN() -C VALUE -C IREADNS - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the BUFR file -C -C REMARKS: -C THIS ROUTINE CALLS: READNS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*8 SUBSET - CALL READNS(LUNIT,SUBSET,IDATE,IRET) - IREADNS = IRET - RETURN - END diff --git a/src/bufr/ireadsb.f b/src/bufr/ireadsb.f deleted file mode 100644 index c68aa539d2..0000000000 --- a/src/bufr/ireadsb.f +++ /dev/null @@ -1,44 +0,0 @@ - FUNCTION IREADSB(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IREADSB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READSB -C AND PASSES BACK ITS RETURN CODE. SEE READSB FOR MORE DETAILS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: IREADSB (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C IREADSB - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the BUFR -C message -C -C REMARKS: -C THIS ROUTINE CALLS: READSB -C THIS ROUTINE IS CALLED BY: UFBTAB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CALL READSB(LUNIT,IRET) - IREADSB = IRET - RETURN - END diff --git a/src/bufr/irev.F b/src/bufr/irev.F deleted file mode 100755 index fd0ab62208..0000000000 --- a/src/bufr/irev.F +++ /dev/null @@ -1,80 +0,0 @@ - FUNCTION IREV(N) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IREV -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION WILL, WHEN THE LOCAL MACHINE IS "LITTLE- -C ENDIAN" (I.E., USES A RIGHT TO LEFT SCHEME FOR NUMBERING THE BYTES -C WITHIN A MACHINE WORD), RETURN A COPY OF AN INPUT INTEGER WORD WITH -C THE BYTES REVERSED. ALTHOUGH, BY DEFINITION (WITHIN WMO MANUAL -C 306), A BUFR MESSAGE IS A STREAM OF INDIVIDUAL OCTETS (I.E., BYTES) -C THAT IS INDEPENDENT OF ANY PARTICULAR MACHINE REPRESENTATION, THE -C BUFR ARCHIVE LIBRARY SOFTWARE OFTEN NEEDS TO INTERPRET ALL OR PARTS -C OF TWO OR MORE ADJACENT BYTES IN ORDER TO CONSTRUCT AN INTEGER -C WORD. BY DEFAULT, THE SOFTWARE USES THE "BIG-ENDIAN" (LEFT TO -C RIGHT) SCHEME FOR NUMBERING BYTES. BY REVERSING THE BYTES, IREV -C ALLOWS THE INTEGER WORD TO BE PROPERLY READ OR WRITTEN (DEPENDING -C ON WHETHER INPUT OR OUTPUT OPERATIONS, RESPECTIVELY, ARE BEING -C PERFORMED) ON LITTLE-ENDIAN MACHINES. IF THE LOCAL MACHINE IS -C BIG-ENDIAN, IREV SIMPLY RETURNS A COPY OF THE SAME INTEGER THAT WAS -C INPUT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2007-01-19 J. ATOR -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW -C DETERMINED AT COMPILE TIME AND CONFIGURED -C WITHIN BUFRLIB VIA CONDITIONAL COMPILATION -C DIRECTIVES -C -C USAGE: IREV (N) -C INPUT ARGUMENT LIST: -C N - INTEGER: INTEGER WORD WITH BYTES ORDERED ACCORDING TO -C THE "BIG-ENDIAN" NUMBERING SCHEME -C -C OUTPUT ARGUMENT LIST: -C IREV - INTEGER: INTEGER WORD WITH BYTES ORDERED ACCORDING TO -C THE NUMBERING SCHEME OF THE LOCAL MACHINE (EITHER -C "BIG-ENDIAN" OR "LITTLE-ENDIAN", IF "BIG-ENDIAN THEN -C THIS IS JUST A DIRECT COPY OF N) -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: IPKM IUPM PKB PKC -C UPBB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*8 CINT,DINT - EQUIVALENCE(CINT,INT) - EQUIVALENCE(DINT,JNT) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -#ifdef BIG_ENDIAN - IREV = N -#else - INT = N - DO I=1,NBYTW - DINT(I:I) = CINT(IORD(I):IORD(I)) - ENDDO - IREV = JNT -#endif - - RETURN - END diff --git a/src/bufr/ishrdx.f b/src/bufr/ishrdx.f deleted file mode 100644 index 40ede2ce67..0000000000 --- a/src/bufr/ishrdx.f +++ /dev/null @@ -1,80 +0,0 @@ - INTEGER FUNCTION ISHRDX(LUD,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ISHRDX -C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-11-30 -C -C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) IS -C SHARING INTERNAL TABLE INFORMATION WITH LOGICAL UNIT IOLUN(LUD). -C NOTE THAT TWO LOGICAL UNITS CAN HAVE THE SAME INTERNAL TABLE -C INFORMATION WITHOUT ACTUALLY SHARING IT. -C -C PROGRAM HISTORY LOG: -C 2009-11-30 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: ISHRDX (LUD, LUN) -C INPUT ARGUMENT LIST: -C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR FIRST LOGICAL UNIT -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C FOR SECOND LOGICAL UNIT -C -C OUTPUT ARGUMENT LIST: -C ISHRDX - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN) -C IS SHARING TABLE INFORMATION WITH IOLUN(LUD): -C 0 - NO -C 1 - YES -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: ICMPDX MAKESTAB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Note that, for any I/O stream index value LUx, the MTAB(*,LUx) -C array contains pointer indices into the internal jump/link table -C for each of the Table A mnemonics that is currently defined for -C that LUx value. Thus, if all of these indices are identical for -C two different LUx values, then the associated logical units are -C sharing table information. - - IF ( ( NTBA(LUD) .GE. 1 ) .AND. - + ( NTBA(LUD) .EQ. NTBA(LUN) ) ) THEN - II = 1 - ISHRDX = 1 - DO WHILE ( ( II .LE. NTBA(LUD) ) .AND. ( ISHRDX .EQ. 1 ) ) - IF ( ( MTAB(II,LUD) .NE. 0 ) .AND. - + ( MTAB(II,LUD) .EQ. MTAB(II,LUN) ) ) THEN - II = II + 1 - ELSE - ISHRDX = 0 - ENDIF - ENDDO - ELSE - ISHRDX = 0 - ENDIF - - RETURN - END diff --git a/src/bufr/isize.f b/src/bufr/isize.f deleted file mode 100644 index fe4b44b27c..0000000000 --- a/src/bufr/isize.f +++ /dev/null @@ -1,51 +0,0 @@ - INTEGER FUNCTION ISIZE (NUM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ISIZE -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS FUNCTION COMPUTES AND RETURNS THE NUMBER OF CHARACTERS -C NEEDED TO ENCODE THE INPUT INTEGER NUM AS A STRING. IT DOES NOT -C ACTUALLY ENCODE THE STRING BUT RATHER ONLY FIGURES OUT THE REQUIRED -C SIZE. NUM MUST BE AN INTEGER IN THE RANGE OF 0 TO 99999. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL ISIZE ( NUM ) -C INPUT ARGUMENT LIST: -C NUM - INTEGER: NUMBER TO BE ENCODED -C -C OUTPUT ARGUMENT LIST: -C ISIZE - INTEGER: NUMBER OF CHARACTERS NECESSARY TO ENCODE NUM -C AS A STRING -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: READMT UFBDMP UFDUMP -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF ( NUM .LT. 0 ) GOTO 900 - DO ISIZE = 1, 5 - IF ( NUM .LT. 10**ISIZE ) RETURN - ENDDO - GOTO 900 - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: ISIZE - INPUT NUMBER (",I7,'// - . '") IS OUT OF RANGE")') NUM - CALL BORT(BORT_STR) - END diff --git a/src/bufr/istdesc.f b/src/bufr/istdesc.f deleted file mode 100644 index def330bd11..0000000000 --- a/src/bufr/istdesc.f +++ /dev/null @@ -1,56 +0,0 @@ - FUNCTION ISTDESC( IDN ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ISTDESC -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF THE FXY VALUE -C FOR A DESCRIPTOR, THIS FUNCTION DETERMINES WHETHER THE DESCRIPTOR -C IS A WMO-STANDARD DESCRIPTOR OR A LOCAL DESCRIPTOR. -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: ISTDESC( IDN ) -C INPUT ARGUMENT LIST: -C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE -C FOR DESCRIPTOR TO BE CHECKED -C -C OUTPUT ARGUMENT LIST: -C ISTDESC - INTEGER: RETURN VALUE: -C 0 - IDN IS A LOCAL DESCRIPTOR -C 1 - IDN IS A WMO-STANDARD DESCRIPTOR -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 -C THIS ROUTINE IS CALLED BY: READS3 RESTD STNDRD -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*6 ADSC, ADN30 - - ADSC = ADN30( IDN, 6 ) - - READ(ADSC,'(I1,I2,I3)') IF,IX,IY - IF ( ( IF .EQ. 1 ) .OR. ( IF .EQ. 2 ) ) THEN - -C ADSC IS EITHER A REPLICATOR OR TABLE C OPERATOR DESCRIPTOR. -C SINCE LOCAL VERSIONS OF SUCH DESCRIPTORS ARE NOT ALLOWED, -C THEN ADSC IS STANDARD BY DEFAULT. - - ISTDESC = 1 - ELSE IF ( ( IX .LT. 48 ) .AND. ( IY .LT. 192 ) ) THEN - ISTDESC = 1 - ELSE - ISTDESC = 0 - END IF - - RETURN - END diff --git a/src/bufr/iupb.f b/src/bufr/iupb.f deleted file mode 100644 index 1a98765b63..0000000000 --- a/src/bufr/iupb.f +++ /dev/null @@ -1,55 +0,0 @@ - FUNCTION IUPB(MBAY,NBYT,NBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IUPB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD -C CONTAINED WITHIN NBIT BITS OF A BUFR MESSAGE PACKED INTO THE -C INTEGER ARRAY MBAY, STARTING WITH THE FIRST BIT OF BYTE NBYT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C -C USAGE: IUPB (MBAY, NBYT, NBIT) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE -C NBYT - INTEGER: BYTE WITHIN MBAY AT WHOSE FIRST BIT TO BEGIN -C UNPACKING -C NBIT - INTEGER: NUMBER OF BITS WITHIN MBAY TO BE UNPACKED -C -C OUTPUT ARGUMENT LIST: -C IUPB - INTEGER: UNPACKED INTEGER WORD -C -C REMARKS: -C THIS ROUTINE CALLS: UPB -C THIS ROUTINE IS CALLED BY: CKTABA CPYUPD GETLENS IUPBS01 -C IUPBS3 MSGUPD MSGWRT RDMEMS -C STNDRD STRCPT SUBUPD UPDS3 -C WRITLC -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MBAY(*) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - MBIT = (NBYT-1)*8 - CALL UPB(IRET,NBIT,MBAY,MBIT) - IUPB = IRET - RETURN - END diff --git a/src/bufr/iupbs01.f b/src/bufr/iupbs01.f deleted file mode 100644 index e02dd1230f..0000000000 --- a/src/bufr/iupbs01.f +++ /dev/null @@ -1,179 +0,0 @@ - FUNCTION IUPBS01(MBAY,S01MNEM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IUPBS01 -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE -C FROM SECTION 0 OR SECTION 1 OF THE BUFR MESSAGE STORED IN ARRAY -C MBAY. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 -C OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST -C BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE -C UNPACKED IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS EXPLAINED IN -C FURTHER DETAIL BELOW. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2006-04-14 J. ATOR -- ADDED OPTIONS FOR 'YCEN' AND 'CENT'; -C RESTRUCTURED LOGIC -C -C USAGE: IUPBS01 (MBAY, S01MNEM) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR MESSAGE -C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE -C UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE: -C 'LENM' = LENGTH (IN BYTES) OF BUFR MESSAGE -C 'LEN0' = LENGTH (IN BYTES) OF SECTION 0 -C 'BEN' = BUFR EDITION NUMBER -C 'LEN1' = LENGTH (IN BYTES) OF SECTION 1 -C 'BMT' = BUFR MASTER TABLE -C 'OGCE' = ORIGINATING CENTER -C 'GSES' = ORIGINATING SUBCENTER -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 3 OR 4 MESSAGES!) -C 'USN' = UPDATE SEQUENCE NUMBER -C 'ISC2' = FLAG INDICATING ABSENCE/PRESENCE OF -C (OPTIONAL) SECTION 2 IN BUFR MESSAGE: -C 0 = SECTION 2 ABSENT -C 1 = SECTION 2 PRESENT -C 'MTYP' = DATA CATEGORY -C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MSBT' = DATA SUBCATEGORY (LOCAL) -C 'MTV' = VERSION NUMBER OF MASTER TABLE -C 'MTVL' = VERSION NUMBER OF LOCAL TABLES -C 'YCEN' = YEAR OF CENTURY (1-100) -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 2 AND 3 MESSAGES!) -C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, -C 21 FOR YEARS 2001-2100) -C (NOTE: THIS VALUE *MAY* BE PRESENT IN -C BUFR EDITION 2 AND 3 MESSAGES, -C BUT IT IS NEVER PRESENT IN ANY -C BUFR EDITION 4 MESSAGES!) -C 'YEAR' = YEAR (4-DIGIT) -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 4 MESSAGES. FOR -C BUFR EDITION 2 AND 3 MESSAGES -C IT WILL BE CALCULATED USING THE -C VALUES FOR 'YCEN' AND 'CENT', -C EXCEPT WHEN THE LATTER IS NOT -C PRESENT AND IN WHICH CASE A -C "WINDOWING" TECHNIQUE WILL BE -C USED INSTEAD!) -C 'MNTH' = MONTH -C 'DAYS' = DAY -C 'HOUR' = HOUR -C 'MINU' = MINUTE -C 'SECO' = SECOND -C (NOTE: THIS VALUE IS PRESENT ONLY IN -C BUFR EDITION 4 MESSAGES!) -C -C OUTPUT ARGUMENT LIST: -C IUPBS01 - INTEGER: UNPACKED INTEGER VALUE -C -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID FOR -C THE EDITION OF BUFR MESSAGE IN MBAY -C -C REMARKS: -C THIS ROUTINE CALLS: GETS1LOC I4DY IUPB WRDLEN -C THIS ROUTINE IS CALLED BY: ATRCPT CKTABA CNVED4 COPYBF -C COPYMG CPYMEM CRBMG CRDBUFR -C DUMPBF GETLENS IDXMSG IGETDATE -C IUPVS01 MESGBC MESGBF MSGWRT -C NMWRD PADMSG PKBS1 RDMSGB -C READS3 RTRCPT STBFDX STNDRD -C UFBMEX WRCMPS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MBAY(*) - - CHARACTER*(*) S01MNEM - - LOGICAL OK4CENT - -C----------------------------------------------------------------------- -C This statement function checks whether its input value contains -C a valid century value. - - OK4CENT(IVAL) = ((IVAL.GE.19).AND.(IVAL.LE.21)) -C----------------------------------------------------------------------- - -C Call subroutine WRDLEN to initialize some important information -C about the local machine, just in case subroutine OPENBF hasn't -C been called yet. - - CALL WRDLEN - -C Handle some simple requests that do not depend on the BUFR -C edition number. - - IF(S01MNEM.EQ.'LENM') THEN - IUPBS01 = IUPB(MBAY,5,24) - RETURN - ENDIF - - LEN0 = 8 - IF(S01MNEM.EQ.'LEN0') THEN - IUPBS01 = LEN0 - RETURN - ENDIF - -C Get the BUFR edition number. - - IBEN = IUPB(MBAY,8,8) - IF(S01MNEM.EQ.'BEN') THEN - IUPBS01 = IBEN - RETURN - ENDIF - -C Use the BUFR edition number to handle any other requests. - - CALL GETS1LOC(S01MNEM,IBEN,ISBYT,IWID,IRET) - IF(IRET.EQ.0) THEN - IUPBS01 = IUPB(MBAY,LEN0+ISBYT,IWID) - IF(S01MNEM.EQ.'CENT') THEN - -C Test whether the returned value was a valid -C century value. - - IF(.NOT.OK4CENT(IUPBS01)) IUPBS01 = -1 - ENDIF - ELSE IF( (S01MNEM.EQ.'YEAR') .AND. (IBEN.LT.4) ) THEN - -C Calculate the 4-digit year. - - IYOC = IUPB(MBAY,21,8) - ICEN = IUPB(MBAY,26,8) - -C Does ICEN contain a valid century value? - - IF(OK4CENT(ICEN)) THEN - -C YES, so use it to calculate the 4-digit year. Note that, -C by international convention, the year 2000 was the 100th -C year of the 20th century, and the year 2001 was the 1st -C year of the 21st century - - IUPBS01 = (ICEN-1)*100 + IYOC - ELSE - -C NO, so use a windowing technique to determine the -C 4-digit year from the year of the century. - - IUPBS01 = I4DY(MOD(IYOC,100)*1000000)/10**6 - ENDIF - ELSE - IUPBS01 = -1 - ENDIF - - RETURN - END diff --git a/src/bufr/iupbs3.f b/src/bufr/iupbs3.f deleted file mode 100644 index 0bf11729e7..0000000000 --- a/src/bufr/iupbs3.f +++ /dev/null @@ -1,85 +0,0 @@ - FUNCTION IUPBS3(MBAY,S3MNEM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IUPBS3 -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE -C FROM SECTION 3 OF THE BUFR MESSAGE STORED IN ARRAY MBAY. IT WILL -C WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE START -C OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE -C FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE UNPACKED IS SPECIFIED -C VIA THE MNEMONIC S3MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IUPBS3 (MBAY, S3MNEM) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR MESSAGE -C S3MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE -C UNPACKED FROM SECTION 3 OF BUFR MESSAGE: -C 'NSUB' = NUMBER OF DATA SUBSETS -C 'IOBS' = FLAG INDICATING WHETHER THE MESSAGE -C CONTAINS OBSERVED DATA: -C 0 = NO -C 1 = YES -C 'ICMP' = FLAG INDICATING WHETHER THE MESSAGE -C CONTAINS COMPRESSED DATA: -C 0 = NO -C 1 = YES -C -C OUTPUT ARGUMENT LIST: -C IUPBS3 - INTEGER: UNPACKED INTEGER VALUE -C -1 = THE INPUT S3MNEM MNEMONIC WAS INVALID -C -C REMARKS: -C THIS ROUTINE CALLS: GETLENS IUPB -C THIS ROUTINE IS CALLED BY: CKTABA CPDXMM DUMPBF MESGBC -C RDBFDX READERME STNDRD WRITLC -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MBAY(*) - - CHARACTER*(*) S3MNEM - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Call subroutine WRDLEN to initialize some important information -C about the local machine, just in case subroutine OPENBF hasn't -C been called yet. - - CALL WRDLEN - -C Skip to the beginning of Section 3. - - CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) - IPT = LEN0 + LEN1 + LEN2 - -C Unpack the requested value. - - IF(S3MNEM.EQ.'NSUB') THEN - IUPBS3 = IUPB(MBAY,IPT+5,16) - ELSE IF( (S3MNEM.EQ.'IOBS') .OR. (S3MNEM.EQ.'ICMP') ) THEN - IVAL = IUPB(MBAY,IPT+7,8) - IF(S3MNEM.EQ.'IOBS') THEN - IMASK = 128 - ELSE - IMASK = 64 - ENDIF - IUPBS3 = MIN(1,IAND(IVAL,IMASK)) - ELSE - IUPBS3 = -1 - ENDIF - - RETURN - END diff --git a/src/bufr/iupm.f b/src/bufr/iupm.f deleted file mode 100644 index e6070c225e..0000000000 --- a/src/bufr/iupm.f +++ /dev/null @@ -1,74 +0,0 @@ - FUNCTION IUPM(CBAY,NBITS) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IUPM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD -C CONTAINED WITHIN NBITS BITS OF A CHARACTER STRING CBAY, STARTING -C WITH THE FIRST BIT OF THE FIRST BYTE OF CBAY. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS -C IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: IUPM (CBAY, NBITS) -C INPUT ARGUMENT LIST: -C CBAY - CHARACTER*8: CHARACTER STRING CONTAINING PACKED -C INTEGER -C NBITS - INTEGER: NUMBER OF BITS WITHIN CBAY TO BE UNPACKED -C -C OUTPUT ARGUMENT LIST: -C IUPM - INTEGER: UNPACKED INTEGER WORD -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IREV -C THIS ROUTINE IS CALLED BY: CHRTRNA CRBMG DXMINI ICBFMS -C PKC PKTDD STBFDX UPC -C UPTDD WRDLEN WRDXTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*128 BORT_STR - CHARACTER*8 CBAY - CHARACTER*8 CINT - DIMENSION INT(2) - EQUIVALENCE (CINT,INT) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(NBITS.GT.NBITW) GOTO 900 - CINT = CBAY - INT(1) = IREV(INT(1)) - IUPM = ISHFT(INT(1),NBITS-NBITW) - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: IUPM - NUMBER OF BITS BEING UNPACKED'// - . ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// - . 'MACHINE, NBITW (",I3,")")') NBITS,NBITW - CALL BORT(BORT_STR) - END diff --git a/src/bufr/iupvs01.f b/src/bufr/iupvs01.f deleted file mode 100644 index eaf4be7b0d..0000000000 --- a/src/bufr/iupvs01.f +++ /dev/null @@ -1,82 +0,0 @@ - FUNCTION IUPVS01(LUNIT,S01MNEM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IUPVS01 -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE -C FROM SECTION 0 OR SECTION 1 OF THE LAST BUFR MESSAGE THAT WAS READ -C FROM LOGICAL UNIT NUMBER LUNIT VIA BUFR ARCHIVE LIBRARY SUBROUTINE -C READMG, READERME OR EQUIVALENT. IT WILL WORK ON ANY MESSAGE ENCODED -C USING BUFR EDITION 2, 3 OR 4, AND THE VALUE TO BE UNPACKED IS -C SPECIFIED VIA THE MNEMONIC S01MNEM (SEE THE DOCBLOCK OF BUFR ARCHIVE -C LIBRARY FUNCTION IUPBS01 FOR A LISTING OF POSSIBLE VALUES FOR -C S01MNEM). NOTE THAT THIS FUNCTION IS SIMILAR TO BUFR ARCHIVE -C LIBRARY FUNCTION IUPBS01 EXCEPT THAT IT OPERATES ON A BUFR MESSAGE -C THAT HAS ALREADY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY -C ARRAYS (VIA A PREVIOUS CALL TO READMG, READERME, ETC.) RATHER THAN -C ON A BUFR MESSAGE PASSED DIRECTLY INTO THE FUNCTION VIA A MEMORY -C ARRAY. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: IUPVS01 (LUNIT, S01MNEM) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE -C UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE -C (SEE DOCBLOCK OF FUNCTION IUPBS01 FOR LISTING OF -C POSSIBLE VALUES) -C -C OUTPUT ARGUMENT LIST: -C IUPVS01 - INTEGER: UNPACKED INTEGER VALUE -C -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IUPBS01 STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - CHARACTER*(*) S01MNEM - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,ILST,IMST) - IF(ILST.EQ.0) GOTO 900 - IF(ILST.GT.0) GOTO 901 - IF(IMST.EQ.0) GOTO 902 - -C UNPACK THE REQUESTED VALUE -C -------------------------- - - IUPVS01 = IUPBS01(MBAY(1,LUN),S01MNEM) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: IUPVS01 - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') - END diff --git a/src/bufr/jstchr.f b/src/bufr/jstchr.f deleted file mode 100644 index 79a448e8a4..0000000000 --- a/src/bufr/jstchr.f +++ /dev/null @@ -1,68 +0,0 @@ - SUBROUTINE JSTCHR(STR,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: JSTCHR -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE LEFT-JUSTIFIES (I.E. REMOVES ALL LEADING -C BLANKS FROM) A CHARACTER STRING. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY) -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS -C THEN REMOVED BECAUSE IT WAS JUST A DUMMY -C ROUTINE WITH ENTRIES) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2007-01-19 J. ATOR -- RESTRUCTURED AND ADDED IRET ARGUMENT -C -C USAGE: CALL JSTCHR (STR, IRET) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING -C -C OUTPUT ARGUMENT LIST: -C STR - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS -C REMOVED -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = input string was empty (i.e. all blanks) -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: ELEMDX IGETFXY SNTBBE -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(STR.EQ.' ') THEN - IRET = -1 - ELSE - IRET = 0 - LSTR = LEN(STR) - DO WHILE(STR(1:1).EQ.' ') - STR = STR(2:LSTR) - ENDDO - ENDIF - - RETURN - END diff --git a/src/bufr/jstnum.f b/src/bufr/jstnum.f deleted file mode 100644 index adeaff3834..0000000000 --- a/src/bufr/jstnum.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE JSTNUM(STR,SIGN,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: JSTNUM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE REMOVES ALL LEADING BLANKS FROM A CHARACTER -C STRING CONTAINING AN ENCODED INTEGER VALUE. IF THE VALUE HAS A -C LEADING SIGN CHARACTER ('+' OR '-'), THEN THIS CHARACTER IS ALSO -C REMOVED AND IS RETURNED SEPARATELY WITHIN SIGN. IF THE RESULTANT -C STRING CONTAINS ANY NON-NUMERIC CHARACTERS, THAN AN APPROPRIATE -C CALL IS MADE TO TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY) -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS -C THEN REMOVED BECAUSE IT WAS JUST A DUMMY -C ROUTINE WITH ENTRIES) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY OR UNUSUAL THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL JSTNUM (STR, SIGN, IRET) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE -C -C OUTPUT ARGUMENT LIST: -C STR - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS -C AND SIGN CHARACTER REMOVED -C SIGN - CHARACTER*1: SIGN OF ENCODED INTEGER VALUE: -C '+' = positive value -C '-' = negative value -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = encoded value within STR was not an integer -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT STRNUM -C THIS ROUTINE IS CALLED BY: ELEMDX -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - - CHARACTER*128 ERRSTR - CHARACTER*1 SIGN - - COMMON /QUIET / IPRT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - - IF(STR.EQ.' ') GOTO 900 - - LSTR = LEN(STR) -2 IF(STR(1:1).EQ.' ') THEN - STR = STR(2:LSTR) - GOTO 2 - ENDIF - IF(STR(1:1).EQ.'+') THEN - STR = STR(2:LSTR) - SIGN = '+' - ELSEIF(STR(1:1).EQ.'-') THEN - STR = STR(2:LSTR) - SIGN = '-' - ELSE - SIGN = '+' - ENDIF - - CALL STRNUM(STR,NUM) - IF(NUM.LT.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: JSTNUM: ENCODED VALUE WITHIN RESULTANT '// - . 'CHARACTER STRING (' // STR // ') IS NOT AN INTEGER - '// - . 'RETURN WITH IRET = -1' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IRET = -1 - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT '// - . 'ALLOWED') - END diff --git a/src/bufr/lcmgdf.f b/src/bufr/lcmgdf.f deleted file mode 100644 index c52470255e..0000000000 --- a/src/bufr/lcmgdf.f +++ /dev/null @@ -1,79 +0,0 @@ - INTEGER FUNCTION LCMGDF(LUNIT,SUBSET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LCMGDF -C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-07-09 -C -C ABSTRACT: THIS FUNCTION CHECKS WHETHER AT LEAST ONE "LONG" (I.E. -C GREATER THAN 8 BYTES) CHARACTER STRING EXISTS WITHIN THE INTERNAL -C DICTIONARY DEFINITION FOR THE TABLE A MESSAGE TYPE GIVEN BY SUBSET. -C -C PROGRAM HISTORY LOG: -C 2009-07-09 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: LCMGDF (LUNIT, SUBSET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED WITH -C SUBSET DEFINITION -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR MESSAGE TYPE -C -C OUTPUT ARGUMENT LIST: -C LCMGDF - INTEGER: RETURN CODE INDICATING WHETHER SUBSET CONTAINS -C AT LEAST ONE "LONG" CHARACTER STRING IN ITS DEFINITION -C 0 - NO -C 1 - YES -C -C REMARKS: -C THIS ROUTINE CALLS: BORT NEMTBA STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*8 SUBSET - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Get LUN from LUNIT. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF (IL.EQ.0) GOTO 900 - -C Confirm that SUBSET is defined for this logical unit. - - CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD) - -C Check if there's a long character string in the definition. - - NTE = ISC(INOD)-INOD - - DO I = 1, NTE - IF ( (TYP(INOD+I).EQ.'CHR') .AND. (IBT(INOD+I).GT.64) ) THEN - LCMGDF = 1 - RETURN - ENDIF - ENDDO - - LCMGDF = 0 - - RETURN -900 CALL BORT('BUFRLIB: LCMGDF - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN') - END diff --git a/src/bufr/lmsg.f b/src/bufr/lmsg.f deleted file mode 100644 index 4ebccfa544..0000000000 --- a/src/bufr/lmsg.f +++ /dev/null @@ -1,56 +0,0 @@ - FUNCTION LMSG(SEC0) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LMSG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: GIVEN A CHARACTER STRING CONTAINING SECTION ZERO FROM A -C BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT OF MACHINE WORDS -C (I.E. INTEGER ARRAY MEMBERS) THAT WILL HOLD THE ENTIRE MESSAGE. -C NOTE THAT THIS COUNT MAY BE GREATER THAN THE MINIMUM NUMBER -C OF WORDS REQUIRED TO HOLD THE MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION -C 2005-11-29 J. ATOR -- USE NMWRD -C -C USAGE: LMSG (SEC0) -C INPUT ARGUMENT LIST: -C SEC0 - CHARACTER*8: PACKED BUFR MESSAGE SECTION ZERO -C -C OUTPUT ARGUMENT LIST: -C LMSG - INTEGER: BUFR MESSAGE LENGTH (IN MACHINE WORDS) -C -C REMARKS: -C THIS ROUTINE CALLS: NMWRD -C THIS ROUTINE IS CALLED BY: RDMSGB RDMSGW READERME -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*8 SEC0,CSEC0 - DIMENSION MSEC0(2) - - EQUIVALENCE(MSEC0,CSEC0) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CSEC0 = SEC0 - LMSG = NMWRD(MSEC0) - -C EXIT -C ---- - - RETURN - END diff --git a/src/bufr/lstjpb.f b/src/bufr/lstjpb.f deleted file mode 100644 index 46e30a3e2b..0000000000 --- a/src/bufr/lstjpb.f +++ /dev/null @@ -1,110 +0,0 @@ - FUNCTION LSTJPB(NODE,LUN,JBTYP) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LSTJPB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION SEARCHES BACKWARDS, BEGINNING FROM A GIVEN -C NODE WITHIN THE JUMP/LINK TABLE, UNTIL IT FINDS THE MOST RECENT -C NODE OF TYPE JBTYP. THE INTERNAL JMPB ARRAY IS USED TO JUMP -C BACKWARDS WITHIN THE JUMP/LINK TABLE, AND THE FUNCTION RETURNS -C THE TABLE INDEX OF THE FOUND NODE. IF THE INPUT NODE ITSELF IS -C OF TYPE JBTYP, THEN THE FUNCTION SIMPLY RETURNS THE INDEX OF THAT -C SAME NODE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION -C -C USAGE: LSTJPB (NODE, LUN, JBTYP) -C INPUT ARGUMENT LIST: -C NODE - INTEGER: JUMP/LINK TABLE INDEX OF ENTRY TO BEGIN -C SEARCHING BACKWARDS FROM -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C JBTYP - CHARACTER*(*): TYPE OF NODE FOR WHICH TO SEARCH -C -C OUTPUT ARGUMENT LIST: -C LSTJPB - INTEGER: INDEX OF FIRST NODE OF TYPE JBTYP FOUND BY -C JUMPING BACKWARDS FROM INPUT NODE -C 0 = NO SUCH NODE FOUND -C -C REMARKS: -C -C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE TABSUB FOR AN -C EXPLANATION OF THE VARIOUS NODE TYPES PRESENT WITHIN AN INTERNAL -C JUMP/LINK TABLE -C -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: GETWIN NEVN NEWWIN NXTWIN -C PARUSR TRYBUMP UFBRW -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*(*) JBTYP - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*3 TYP - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(NODE.LT.INODE(LUN)) GOTO 900 - IF(NODE.GT.ISC(INODE(LUN))) GOTO 901 - - NOD = NODE - -C FIND THIS OR THE PREVIOUS "JBTYP" NODE -C -------------------------------------- - -10 IF(TYP(NOD).NE.JBTYP) THEN - NOD = JMPB(NOD) - IF(NOD.NE.0) GOTO 10 - ENDIF - - LSTJPB = NOD - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT '// - . 'OF BOUNDS, < LOWER BOUNDS (",I7,"); TAG IS ",A10)') - . NODE,INODE(LUN),TAG(NODE) - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT '// - . 'OF BOUNDS, > UPPER BOUNDS (",I7,"); TAG IS ",A10)') - . NODE,ISC(INODE(LUN)),TAG(NODE) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/makebufrlib.sh b/src/bufr/makebufrlib.sh deleted file mode 100755 index 5e8f5fe21c..0000000000 --- a/src/bufr/makebufrlib.sh +++ /dev/null @@ -1,289 +0,0 @@ -#!/bin/sh -############################################################### -# -# PURPOSE: This script uses the make utility to update the BUFR -# archive libraries (libbufr*.a). -# It first reads a list of source files in the library and -# then generates a makefile used to update the archive -# libraries. The make command is then executed for each -# archive library, where the archive library name and -# compilation flags are passed to the makefile through -# environment variables. -# -# REMARKS: Only source files that have been modified since the last -# library update are recompiled and replaced in the object -# archive libraries. The make utility determines this -# from the file modification times. -# -# New source files are also compiled and added to the object -# archive libraries. -# -############################################################### - -#------------------------------------------------------------------------------- -# Determine the OS of the local machine. - -OS=`uname` -if [ $OS = "AIX" ] -then - export FC=ncepxlf - export CC=ncepxlc - CPPFLAGS=" -P" -elif [ $OS = "Linux" ] -then - export FC=ifort - export CC=icc - CPPFLAGS=" -P -traditional-cpp -C" -fi - -#------------------------------------------------------------------------------- -# Determine the byte-ordering scheme used by the local machine. - -cat > endiantest.c << ENDIANTEST - -void fill(p, size) char *p; int size; { - char *ab= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; - int i; - - for (i=0; i>(byte_size*(sizeof(j)-i)))&mask); - putchar(c==0 ? '?' : (char)c); - } - printf("\n"); -} - -int cprop() { - /* Properties of type char */ - char c; - int byte_size; - - c=1; byte_size=0; - do { c<<=1; byte_size++; } while(c!=0); - - return byte_size; -} - -main() -{ - int byte_size; - - byte_size= cprop(); - endian(byte_size); -} -ENDIANTEST - -$CC -o endiantest endiantest.c - -if [ `./endiantest | cut -c1` = "A" ] -then - byte_order=BIG_ENDIAN -else - byte_order=LITTLE_ENDIAN -fi -echo -echo "byte_order is $byte_order" -echo - -rm -f endiantest.c endiantest - - -#------------------------------------------------------------------------------- -# Preprocess any Fortran *.F files into corresponding *.f files. - -BNFS="" - -for i in `ls *.F` -do - bn=`basename $i .F` - bnf=${bn}.f - BNFS="$BNFS $bnf" - cpp $CPPFLAGS -D$byte_order $i $bnf -done - -#------------------------------------------------------------------------------- -# Generate a list of object files that correspond to the -# list of Fortran ( *.f ) files in the current directory. - -OBJS="" - -for i in `ls *.f` -do - obj=`basename $i .f` - OBJS="$OBJS ${obj}.o" -done - -#------------------------------------------------------------------------------- -# Generate a list of object files that corresponds to the -# list of C ( .c ) files in the current directory. - -for i in `ls *.c` -do - obj=`basename $i .c` - OBJS="$OBJS ${obj}.o" -done - -#------------------------------------------------------------------------------- -# Remove make file, if it exists. May need a new make file -# with an updated object file list. - -if [ -f make.libbufr ] -then - rm -f make.libbufr -fi - -#------------------------------------------------------------------------------- -# Generate a new make file ( make.libbufr), with the updated object list, -# from this HERE file. - -cat > make.libbufr << EOF -SHELL=/bin/sh - -\$(LIB): \$(LIB)( ${OBJS} ) - -.f.a: - \$(FC) -c \$(FFLAGS) \$< - ar -ruv \$(AFLAGS) \$@ \$*.o - rm -f \$*.o - -.c.a: - \$(CC) -c \$(CFLAGS) \$< - ar -ruv \$(AFLAGS) \$@ \$*.o - rm -f \$*.o -EOF - -#------------------------------------------------------------------------------- -# Generate the bufrlib.prm header file. - -cpp $CPPFLAGS -DBUILD=NORMAL bufrlib.PRM bufrlib.prm - -#------------------------------------------------------------------------------- -# Update libbufr_4_64.a (4-byte REAL, 4-byte INT, 64-bit compilation, -# Fortran optimization level 3, C optimization level 3) - -export LIB="../../libbufr_v10.2.5_4_64.a" -if [ $OS = "AIX" ] -then - export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=4 -qrealsize=4 -qxlf77=leadzero" - export CFLAGS=" -O3 -q64" - export AFLAGS=" -X64" -elif [ $OS = "Linux" ] -then - export FFLAGS=" -O3" - export CFLAGS=" -O3 -DUNDERSCORE" - export AFLAGS=" " -fi -make -f make.libbufr -err_make=$? -[ $err_make -ne 0 ] && exit 99 - -#------------------------------------------------------------------------------- -# Update libbufr_8_64.a (8-byte REAL, 8-byte INT, 64-bit compilation, -# Fortran optimization level 3, C optimization level 3) - -export LIB="../../libbufr_v10.2.5_8_64.a" -if [ $OS = "AIX" ] -then - export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=8 -qrealsize=8 -qxlf77=leadzero" - export CFLAGS=" -O3 -q64 -DF77_INTSIZE_8" - export AFLAGS=" -X64" -elif [ $OS = "Linux" ] -then - export FFLAGS=" -O3 -r8 -i8" - export CFLAGS=" -O3 -DUNDERSCORE -DF77_INTSIZE_8" - export AFLAGS=" " -fi -make -f make.libbufr -err_make=$? -[ $err_make -ne 0 ] && exit 99 - -#------------------------------------------------------------------------------- -# Update libbufr_d_64.a (8-byte REAL, 4-byte INT, 64-bit compilation, -# Fortran optimization level 3, C optimization level 3) - -export LIB="../../libbufr_v10.2.5_d_64.a" -if [ $OS = "AIX" ] -then - export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=4 -qrealsize=8 -qxlf77=leadzero" - export CFLAGS=" -O3 -q64" - export AFLAGS=" -X64" -elif [ $OS = "Linux" ] -then - export FFLAGS=" -O3 -r8" - export CFLAGS=" -O3 -DUNDERSCORE" - export AFLAGS=" " -fi -make -f make.libbufr -err_make=$? -[ $err_make -ne 0 ] && exit 99 - -if [ $OS = "AIX" ] -then - #------------------------------------------------------------------------------- - # Generate a new bufrlib.prm header file. - - /usr/lib/cpp -P -DBUILD=C32BITS bufrlib.PRM bufrlib.prm - - #------------------------------------------------------------------------------- - # Update libbufr_4_32.a (4-byte REAL, 4-byte INT, 32-bit compilation, - # Fortran optimization level 3, C optimization level 3) - - export LIB="../../libbufr_v10.2.5_4_32.a" - export FFLAGS=" -O3 -q32 -qsource -qnosave -qintsize=4 -qrealsize=4 -qxlf77=leadzero" - export CFLAGS=" -O3 -q32" - export AFLAGS=" -X32" - make -f make.libbufr - err_make=$? - [ $err_make -ne 0 ] && exit 99 -fi - -#------------------------------------------------------------------------------- -# Generate a new bufrlib.prm header file. - -cpp $CPPFLAGS -DBUILD=SUPERSIZE bufrlib.PRM bufrlib.prm - -#------------------------------------------------------------------------------- -# Update libbufr_s_64.a (4-byte REAL, 4-byte INT, 64-bit compilation, extra-large array sizes, -# Fortran optimization level 3, C optimization level 3) - -export LIB="../../libbufr_v10.2.5_s_64.a" -if [ $OS = "AIX" ] -then - export FFLAGS=" -O4 -q64 -qsource -qstrict -qnosave -qintsize=4 -qrealsize=4 -qxlf77=leadzero" - export CFLAGS=" -O3 -q64" - export AFLAGS=" -X64" -elif [ $OS = "Linux" ] -then - export FFLAGS=" -O3 -mcmodel=medium -shared-intel" - export CFLAGS=" -O3 -mcmodel=medium -shared-intel -DUNDERSCORE" - export AFLAGS=" " -fi -make -f make.libbufr -err_make=$? -[ $err_make -ne 0 ] && exit 99 - -#------------------------------------------------------------------------------- - -# Clean up and check how we did. - -rm -f make.libbufr bufrlib.prm $BNFS - -if [ -s ../../libbufr_v10.2.5_s_64.a ] ; then - echo - echo "SUCCESS: The script updated all BUFR archive libraries" - echo - [ $OS = "AIX" ] && rm *.lst -else - echo - echo "FAILURE: The script did NOT update all BUFR archive libraries" - echo -fi diff --git a/src/bufr/makestab.f b/src/bufr/makestab.f deleted file mode 100644 index 1b298a3b3d..0000000000 --- a/src/bufr/makestab.f +++ /dev/null @@ -1,400 +0,0 @@ - SUBROUTINE MAKESTAB - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MAKESTAB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE -C WITHIN COMMON BLOCK /TABLES/, USING THE INFORMATION WITHIN THE -C INTERNAL BUFR TABLE ARRAYS (WITHIN COMMON BLOCK /TABABD/) FOR ALL OF -C THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO -C THE BUFR ARCHIVE LIBRARY SOFTWARE. NOTE THAT THE ENTIRE JUMP/LINK -C TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF -C SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS -C ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS -C SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN -C PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET -C BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G. -C THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE -C VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY; NOW ALLOWS FOR THE -C POSSIBILITY THAT A CONNECTED FILE MAY NOT -C CONTAIN ANY DICTIONARY TABLE INFO (E.G., -C AN EMPTY FILE), SUBSEQUENT CONNECTED FILES -C WHICH ARE NOT EMPTY WILL NO LONGER GET -C TRIPPED UP BY THIS (THIS AVOIDS THE NEED -C FOR AN APPLICATION PROGRAM TO DISCONNECT -C ANY EMPTY FILES VIA A CALL TO CLOSBF) -C 2009-03-18 J. WOOLLEN -- ADDED LOGIC TO RESPOND TO THE CASES WHERE -C AN INPUT FILE'S TABLES CHANGE IN MIDSTREAM. -C THE NEW LOGIC MOSTLY ADDRESSES CASES WHERE -C OTHER FILES ARE CONNECTED TO THE TABLES OF -C THE FILE WHOSE TABLES HAVE CHANGED. -C 2009-06-25 J. ATOR -- TWEAK WOOLLEN LOGIC TO HANDLE SPECIAL CASE -C WHERE TABLE WAS RE-READ FOR A PARTICULAR -C LOGICAL UNIT BUT IS STILL THE SAME ACTUAL -C TABLE AS BEFORE AND IS STILL SHARING THAT -C TABLE WITH A DIFFERENT LOGICAL UNIT -C 2009-11-17 J. ATOR -- ADDED CHECK TO PREVENT WRITING OUT OF TABLE -C INFORMATION WHEN A TABLE HAS BEEN RE-READ -C WITHIN A SHARED LOGICAL UNIT BUT HASN'T -C REALLY CHANGED -C -C USAGE: CALL MAKESTAB -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CHEKSTAB CLOSMG CPBFDX -C ERRWRT ICMPDX ISHRDX STRCLN -C TABSUB WRDXTB -C THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM RDUSDX READDX -C READERME READS3 -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET/ IPRT - COMMON /STBFR/ IOLUN(NFILES),IOMSG(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), - . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV - COMMON /LUSHR/ LUS(NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*10 TAG - CHARACTER*8 NEMO,TAGNRV - CHARACTER*3 TYP - LOGICAL EXPAND,XTAB(NFILES) - REAL*8 VAL - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C RESET POINTER TABLE AND STRING CACHE -C ------------------------------------ - - NTAB = 0 - NNRV = 0 - CALL STRCLN - -C FIGURE OUT WHICH UNITS SHARE TABLES -C ----------------------------------- - -C The LUS array is static between calls to this subroutine, and it -C keeps track of which logical units share dictionary table -C information: -C if LUS(I) = 0, then IOLUN(I) does not share dictionary table -C information with any other logical unit -C if LUS(I) > 0, then IOLUN(I) shares dictionary table -C information with logical unit IOLUN(LUS(I)) -C if LUS(I) < 0, then IOLUN(I) does not now, but at one point in -C the past, shared dictionary table information -C with logical unit IOLUN(ABS(LUS(I))) - -C The XTAB array is non-static and is recomputed within the below -C loop during each call to this subroutine: -C if XTAB(I) = .TRUE., then the dictionary table information -C has changed for IOLUN(I) since the last -C call to this subroutine -C if XTAB(I) = .FALSE., then the dictionary table information -C has not changed for IOLUN(I) since the -C last call to this subroutine - - DO LUN=1,NFILES - XTAB(LUN) = .FALSE. - IF(IOLUN(LUN).EQ.0) THEN - -C Logical unit IOLUN(LUN) is not defined to the BUFRLIB. - - LUS(LUN) = 0 - ELSE IF(MTAB(1,LUN).EQ.0) THEN - -C New dictionary table information has been read for logical -C unit IOLUN(LUN) since the last call to this subroutine. - - XTAB(LUN) = .TRUE. - IF(LUS(LUN).NE.0) THEN - IF(IOLUN(ABS(LUS(LUN))).EQ.0) THEN - LUS(LUN) = 0 - ELSE IF(LUS(LUN).GT.0) THEN - -C IOLUN(LUN) was sharing table information with logical -C unit IOLUN(LUS(LUN)), so check whether the table -C information has really changed. If not, then IOLUN(LUN) -C just re-read a copy of the exact same table information -C as before, and therefore it can continue to share with -C logical unit IOLUN(LUS(LUN)). - - IF(ICMPDX(LUS(LUN),LUN).EQ.1) THEN - XTAB(LUN) = .FALSE. - CALL CPBFDX(LUS(LUN),LUN) - ELSE - LUS(LUN) = (-1)*LUS(LUN) - ENDIF - ELSE IF(ICMPDX(ABS(LUS(LUN)),LUN).EQ.1) THEN - -C IOLUN(LUN) was not sharing table information with logical -C unit IOLUN(LUS(LUN)), but it did at one point in the past -C and now once again has the same table information as that -C logical unit. Since the two units shared table -C information at one point in the past, allow them to do -C so again. - - XTAB(LUN) = .FALSE. - LUS(LUN) = ABS(LUS(LUN)) - CALL CPBFDX(LUS(LUN),LUN) - ENDIF - ENDIF - ELSE IF(LUS(LUN).GT.0) THEN - -C Logical unit IOLUN(LUN) is sharing table information with -C logical unit IOLUN(LUS(LUN)), so make sure that the latter -C unit is still defined to the BUFRLIB. - - IF(IOLUN(LUS(LUN)).EQ.0) THEN - LUS(LUN) = 0 - ELSE IF( XTAB(LUS(LUN)) .AND. - + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN - -C The table information for logical unit IOLUN(LUS(LUN)) -C just changed (in midstream). If IOLUN(LUN) is an output -C file, then we will have to update it with the new table -C information later on in this subroutine. Otherwise, -C IOLUN(LUN) is an input file and is no longer sharing -C tables with IOLUN(LUS(LUN)). - - IF(IOLUN(LUN).LT.0) LUS(LUN) = (-1)*LUS(LUN) - ENDIF - ELSE - -C Determine whether logical unit IOLUN(LUN) is sharing table -C information with any other logical units. - - LUM = 1 - DO WHILE ((LUM.LT.LUN).AND.(LUS(LUN).EQ.0)) - IF(ISHRDX(LUM,LUN).EQ.1) THEN - LUS(LUN) = LUM - ELSE - LUM = LUM+1 - ENDIF - ENDDO - ENDIF - ENDDO - -C INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS -C ----------------------------------------------------------- - - DO LUN=1,NFILES - - IF(IOLUN(LUN).NE.0 .AND. NTBA(LUN).GT.0) THEN - -C Reset any existing inventory pointers. - - IF(IOMSG(LUN).NE.0) THEN - IF(LUS(LUN).EQ.0) THEN - INC = (NTAB+1)-MTAB(1,LUN) - ELSE - INC = MTAB(1,LUS(LUN))-MTAB(1,LUN) - ENDIF - DO N=1,NVAL(LUN) - INV(N,LUN) = INV(N,LUN)+INC - ENDDO - ENDIF - - IF(LUS(LUN).LE.0) THEN - -C The dictionary table information corresponding to logical -C unit IOLUN(LUN) has not yet been written into the internal -C jump/link table, so add it in now. - - CALL CHEKSTAB(LUN) - DO ITBA=1,NTBA(LUN) - INOD = NTAB+1 - NEMO = TABA(ITBA,LUN)(4:11) - CALL TABSUB(LUN,NEMO) - MTAB(ITBA,LUN) = INOD - ISC(INOD) = NTAB - ENDDO - ELSE IF( XTAB(LUS(LUN)) .AND. - + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN - -C Logical unit IOLUN(LUN) is an output file that is sharing -C table information with logical unit IOLUN(LUS(LUN)) whose -C table just changed (in midstream). Flush any existing data -C messages from IOLUN(LUN), then update the table information -C for this logical unit with the corresponding new table -C information from IOLUN(LUS(LUN)), then update IOLUN(LUN) -C itself with a copy of the new table information. - - LUNIT = ABS(IOLUN(LUN)) - IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT) - CALL CPBFDX(LUS(LUN),LUN) - LUNDX = ABS(IOLUN(LUS(LUN))) - CALL WRDXTB(LUNDX,LUNIT) - ENDIF - - ENDIF - - ENDDO - -C STORE TYPES AND INITIAL VALUES AND COUNTS -C ----------------------------------------- - - DO NODE=1,NTAB - IF(TYP(NODE).EQ.'SUB') THEN - VALI(NODE) = 0 - KNTI(NODE) = 1 - ITP (NODE) = 0 - ELSEIF(TYP(NODE).EQ.'SEQ') THEN - VALI(NODE) = 0 - KNTI(NODE) = 1 - ITP (NODE) = 0 - ELSEIF(TYP(NODE).EQ.'RPC') THEN - VALI(NODE) = 0 - KNTI(NODE) = 0 - ITP (NODE) = 0 - ELSEIF(TYP(NODE).EQ.'RPS') THEN - VALI(NODE) = 0 - KNTI(NODE) = 0 - ITP (NODE) = 0 - ELSEIF(TYP(NODE).EQ.'REP') THEN - VALI(NODE) = BMISS - KNTI(NODE) = IRF(NODE) - ITP (NODE) = 0 - ELSEIF(TYP(NODE).EQ.'DRS') THEN - VALI(NODE) = 0 - KNTI(NODE) = 1 - ITP (NODE) = 1 - ELSEIF(TYP(NODE).EQ.'DRP') THEN - VALI(NODE) = 0 - KNTI(NODE) = 1 - ITP (NODE) = 1 - ELSEIF(TYP(NODE).EQ.'DRB') THEN - VALI(NODE) = 0 - KNTI(NODE) = 0 - ITP (NODE) = 1 - ELSEIF(TYP(NODE).EQ.'NUM') THEN - VALI(NODE) = BMISS - KNTI(NODE) = 1 - ITP (NODE) = 2 - ELSEIF(TYP(NODE).EQ.'CHR') THEN - VALI(NODE) = BMISS - KNTI(NODE) = 1 - ITP (NODE) = 3 - ELSE - GOTO 901 - ENDIF - ENDDO - -C SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES -C ---------------------------------------------------------------- - - NEWN = 0 - - DO N=1,NTAB - ISEQ(N,1) = 0 - ISEQ(N,2) = 0 - EXPAND = TYP(N).EQ.'SUB' .OR. TYP(N).EQ.'DRP' .OR. TYP(N).EQ.'DRS' - . .OR. TYP(N).EQ.'REP' .OR. TYP(N).EQ.'DRB' - IF(EXPAND) THEN - ISEQ(N,1) = NEWN+1 - NODA = N - NODE = N+1 - DO K=1,MAXJL - KNT(K) = 0 - ENDDO - IF(TYP(NODA).EQ.'REP') KNT(NODE) = KNTI(NODA) - IF(TYP(NODA).NE.'REP') KNT(NODE) = 1 - -1 NEWN = NEWN+1 - IF(NEWN.GT.MAXJL) GOTO 902 - JSEQ(NEWN) = NODE - KNT(NODE) = MAX(KNTI(NODE),KNT(NODE)) -2 IF(JUMP(NODE)*KNT(NODE).GT.0) THEN - NODE = JUMP(NODE) - GOTO 1 - ELSE IF(LINK(NODE).GT.0) THEN - NODE = LINK(NODE) - GOTO 1 - ELSE - NODE = JMPB(NODE) - IF(NODE.EQ.NODA) GOTO 3 - IF(NODE.EQ.0 ) GOTO 903 - KNT(NODE) = MAX(KNT(NODE)-1,0) - GOTO 2 - ENDIF -3 ISEQ(N,2) = NEWN - ENDIF - ENDDO - -C PRINT THE SEQUENCE TABLES -C ------------------------ - - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - DO I=1,NTAB - WRITE ( UNIT=ERRSTR, FMT='(A,I5,2X,A10,A5,6I8)' ) - . 'BUFRLIB: MAKESTAB ', I, TAG(I), TYP(I), JMPB(I), JUMP(I), - . LINK(I), IBT(I), IRF(I), ISC(I) - CALL ERRWRT(ERRSTR) - ENDDO - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '// - . 'DUPLICATED IN SUBSET: ",A)') NEMO,TAG(N1) - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)')TYP(NODE) - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'// - . ' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') MAXJL - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '// - . 'CIRCULATE (TAG IS ",A,")")') TAG(N) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/maxout.f b/src/bufr/maxout.f deleted file mode 100644 index 90eda54681..0000000000 --- a/src/bufr/maxout.f +++ /dev/null @@ -1,88 +0,0 @@ - SUBROUTINE MAXOUT(MAXO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MAXOUT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE ALLOWS AN APPLICATION PROGRAM TO SET THE -C RECORD LENGTH OF NEWLY CREATED BUFR MESSAGES, OVERRIDING THE VALUE -C SET IN BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI. THIS MUST BE CALLED -C AFTER THE INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF -C SINCE OPENBF CALLS BFRINI. THE RECORD LENGTH WILL REMAIN MAX0 -C UNLESS THIS SUBROUTINE IS CALLED AGAIN WITH A NEW MAX0. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO FOR -C INFORMATIONAL PURPOSES -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2006-04-14 J. ATOR -- ADDED MAX0=0 OPTION AND OVERFLOW CHECK -C 2009-03-23 D. KEYSER -- NO LONGER PRINTS THE RECORD LENGTH CHANGE -C DIAGNOSTIC IF THE REQUESTED RECORD LENGTH -C PASSED IN AS MAX0 IS ACTUALLY THE SAME AS -C THE PREVIOUS RECORD LENGTH -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL MAXOUT (MAXO) -C INPUT ARGUMENT LIST: -C MAXO - INTEGER: DESIRED MESSAGE LENGTH (BYTES): -C 0 = SET RECORD LENGTH TO THE MAXIMUM ALLOWABLE -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - COMMON /QUIET / IPRT - - CHARACTER*128 ERRSTR - CHARACTER*56 DXSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF((MAXO.EQ.0).OR.(MAXO.GT.MXMSGL)) THEN - NEWSIZ = MXMSGL - ELSE - NEWSIZ = MAXO - ENDIF - - IF(IPRT.GE.0) THEN - IF(MAXBYT.NE.NEWSIZ) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A,I7)' ) - . 'BUFRLIB: MAXOUT - THE RECORD LENGTH OF ALL BUFR MESSAGES ', - . 'CREATED FROM THIS POINT ON IS BEING CHANGED FROM ', MAXBYT, - . ' TO ', NEWSIZ - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ENDIF - - MAXBYT = NEWSIZ - MAXCMB = NEWSIZ - MAXDX = NEWSIZ - - RETURN - END diff --git a/src/bufr/mesgbc.f b/src/bufr/mesgbc.f deleted file mode 100644 index 9602acd96b..0000000000 --- a/src/bufr/mesgbc.f +++ /dev/null @@ -1,192 +0,0 @@ - SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MESGBC -C PRGMMR: KEYSER ORG: NP22 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH -C THE MESSAGE TYPE FROM SECTION 1 AND A MESSAGE COMPRESSION INDICATOR -C UNPACKED FROM SECTION 3. IT OBTAINS THE BUFR MESSAGE VIA TWO -C DIFFERENT METHODS, BASED UPON THE SIGN OF LUNIN. -C IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE READS AND EXAMINES -C SECTION 1 OF MESSAGES IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE -C FIRST MESSAGE THAT ACTUALLY CONTAINS REPORT DATA {I.E., BEYOND THE -C BUFR TABLE (DICTIONARY) MESSAGES AT THE TOP AND, FOR DUMP FILES, -C BEYOND THE TWO DUMMY MESSAGES CONTAINING THE CENTER TIME AND THE -C DUMP TIME}. IT THEN RETURNS THE MESSAGE TYPE AND COMPRESSION -C INDICATOR FOR THIS FIRST DATA MESSAGE. IN THIS CASE, THE BUFR FILE -C SHOULD NOT BE OPENED VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF -C PRIOR TO CALLING THIS SUBROUTINE. HOWEVER, THE BUFR FILE MUST BE -C CONNECTED TO UNIT ABS(LUNIN). WHEN USED THIS WAY, THIS SUBROUTINE -C IS IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE MESGBF EXCEPT MESGBF -C DOES NOT RETURN ANY INFORMATION ABOUT COMPRESSION AND MESGBF READS -C UNTIL IT FINDS THE FIRST NON-DICTIONARY MESSAGE REGARDLESS OF -C WHETHER OR NOT IT CONTAINS ANY REPORTS (I.E., IT WOULD STOP AT THE -C DUMMY MESSAGE CONTAINING THE CENTER TIME FOR DUMP FILES). -C THE SECOND METHOD IN WHICH THIS SUBROUTINE CAN BE USED OCCURS -C WHEN LUNIN IS PASSED IN WITH A VALUE LESS THAN ZERO. IN THIS CASE, -C IT SIMPLY RETURNS THE MESSAGE TYPE AND COMPRESSION INDICATOR FOR THE -C BUFR MESSAGE CURRENTLY STORED IN THE INTERNAL MESSAGE BUFFER (ARRAY -C MBAY IN COMMON BLOCK /BITBUF/). IN THIS CASE, THE BUFR FILE -C CONNECTED TO ABS(LUNIN) MUST HAVE BEEN PREVIOUSLY OPENED FOR INPUT -C OPERATIONS BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE BUFR -C MESSAGE MUST HAVE BEEN READ INTO MEMORY BY BUFR ARCHIVE LIBRARY -C ROUTINE READMG OR EQUIVALENT. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 D. KEYSER -- ORIGINAL AUTHOR -C 2004-06-29 D. KEYSER -- ADDED NEW OPTION TO RETURN MESSAGE TYPE AND -C COMPRESSION INDICATOR FOR BUFR MESSAGE -C CURRENTLY STORED IN MEMORY (TRIGGERED BY -C INPUT ARGUMENT LUNIN LESS THAN ZERO) -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE IUPBS01, GETLENS AND RDMSGW -C 2009-03-23 J. ATOR -- USE IUPBS3 AND IDXMSG -C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE -C ADD OPENBF AND CLOSBF FOR THE CASE -C WHEN LUNIN GT 0 -C -C USAGE: CALL MESGBC (LUNIN, MESGTYP, ICOMP) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE -C - IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE -C READS THROUGH ALL BUFR MESSAGES FROM BEGINNING OF -C FILE UNTIL IT FINDS THE FIRST MESSAGE CONTAINING -C REPORT DATA -C - IF LUNIN IS LESS THAN ZERO, THIS SUBROUTINE -C OPERATES ON THE BUFR MESSAGE CURRENTLY STORED IN -C MEMORY -C -C OUTPUT ARGUMENT LIST: -C MESGTYP - INTEGER: BUFR MESSAGE TYPE FOR EITHER THE FIRST -C MESSAGE IN FILE CONTAINING REPORT DATA (IF LUNIN > 0), -C OR FOR THE MESSAGE CURRENTLY IN MEMORY (IF LUNIN < 0) -C -256 = for LUNIN > 0 case only: no messages read -C or error reading file -C < 0 = for LUNIN > 0 case only: none of the -C messages read contain reports; this is the -C negative of the message type the last -C message read (i.e., -11 indicates the BUFR -C file contains only BUFR table messages) -C ICOMP - INTEGER: BUFR MESSAGE COMPRESSION SWITCH: -C -3 = for LUNIN > 0 case only: BUFR file does not -C exist -C -2 = for LUNIN > 0 case only: BUFR file does not -C contain any report messages -C -1 = for LUNIN > 0 case only: cannot determine -C if first BUFR message containing report -C data is compressed due to error reading -C file -C 0 = BUFR message (either first containing -C report data if LUNIN > 0, or that currently -C in memory if LUNIN < 0) is NOT compressed -C 1 = BUFR message (either first containing -C report data if LUNIN > 0, or that currently -C in memory if LUNIN < 0) IS compressed -C -C INPUT FILES: -C UNIT ABS(LUNIN) - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: CLOSBF IDXMSG IUPBS01 IUPBS3 -C OPENBF RDMSGW STATUS -C THIS ROUTINE IS CALLED BY: COPYSB UFBTAB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - DIMENSION MSGS(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LUNIT = ABS(LUNIN) - -C DETERMINE METHOD OF OPERATION BASED ON SIGN OF LUNIN -C LUNIN > 0 - REWIND AND LOOK FOR FIRST DATA MESSAGE (ITYPE = 0) -C LUNIN < 0 - LOOK AT MESSAGE CURRENLY IN MEMORY (ITYPE = 1) -C --------------------------------------------------------------- - - ITYPE = 0 - IF(LUNIT.NE.LUNIN) ITYPE = 1 - - ICOMP = -1 - MESGTYP = -256 - - IF(ITYPE.EQ.0) THEN - - IREC = 0 - -C CALL OPENBF SINCE FILE IS NOT OPEN TO THE C INTERFACE YET -C --------------------------------------------------------- - - CALL OPENBF(LUNIT,'INX',LUNIT) - -C READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND -C ----------------------------------------------------------------- - -1 CALL RDMSGW(LUNIT,MSGS,IER) - IF(IER.EQ.-1) GOTO 900 - IF(IER.EQ.-2) GOTO 901 - - IREC = IREC + 1 - - MESGTYP = IUPBS01(MSGS,'MTYP') - - IF((IDXMSG(MSGS).EQ.1).OR.(IUPBS3(MSGS,'NSUB').EQ.0)) GOTO 1 - - ELSE - -C RETURN MESSAGE TYPE FOR MESSAGE CURRENTLY STORED IN MEMORY -C ---------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - - DO I=1,12 - MSGS(I) = MBAY(I,LUN) - ENDDO - - MESGTYP = IUPBS01(MSGS,'MTYP') - - END IF - -C SET THE COMPRESSION SWITCH -C -------------------------- - - ICOMP = IUPBS3(MSGS,'ICMP') - - GOTO 100 - -C CAN ONLY GET TO STATEMENTS 900 OR 901 WHEN ITYPE = 0 -C ---------------------------------------------------- - -900 IF(IREC.EQ.0) THEN - MESGTYP = -256 - ICOMP = -3 - ELSE - IF(MESGTYP.GE.0) MESGTYP = -MESGTYP - ICOMP = -2 - ENDIF - GOTO 100 - -901 MESGTYP = -256 - ICOMP = -1 - -C EXIT -C ---- - -100 IF(ITYPE.EQ.0) CALL CLOSBF(LUNIT) - RETURN - END diff --git a/src/bufr/mesgbf.f b/src/bufr/mesgbf.f deleted file mode 100644 index 0834c9ab19..0000000000 --- a/src/bufr/mesgbf.f +++ /dev/null @@ -1,98 +0,0 @@ - SUBROUTINE MESGBF(LUNIT,MESGTYP) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MESGBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS AND EXAMINES SECTION 1 OF MESSAGES -C IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE FIRST MESSAGE THAT -C IS NOT A BUFR TABLE (DICTIONARY) MESSAGE. IT THEN RETURNS THE -C MESSAGE TYPE FOR THIS FIRST NON-DICTIONARY MESSAGE. THE BUFR FILE -C SHOULD NOT BE OPEN VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF PRIOR -C TO CALLING THIS SUBROUTINE; HOWEVER, THE BUFR FILE MUST BE CONNECTED -C TO UNIT LUNIT. THIS SUBROUTINE IS IDENTICAL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE MESGBC EXCEPT THAT MESGBC RETURNS THE MESSAGE TYPE FOR -C THE FIRST NON-DICTIONARY MESSAGE THAT ACTUALLY CONTAINS REPORT DATA -C (WHEREAS MESGBF WOULD RETURN THE REPORT TYPE OF A DUMMY MESSAGE -C CONTAINING THE CENTER TIME FOR DUMP FILES), AND MESGBC ALSO -C INDICATES WHETHER OR NOT THE FIRST REPORT DATA MESSAGE IS BUFR -C COMPRESSED. MESGBC ALSO HAS AN OPTION TO OPERATE ON THE CURRENT -C MESSAGE STORED IN MEMORY, WHICH IS SOMETHING THAT MESGBF CANNOT DO. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE IUPBS01 AND RDMSGW -C 2009-03-23 J. ATOR -- USE IDXMSG -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE -C THE C FILE WITHOUT CLOSING THE FORTRAN FILE -C 2013-01-25 J. WOOLLEN -- ALWAYS CALL CLOSBF BEFORE EXITING -C -C USAGE: CALL MESGBF (LUNIT, MESGTYP) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C MESGTYP - INTEGER: BUFR MESSAGE TYPE FOR FIRST NON-DICTIONARY -C MESSAGE -C -1 = no messages read or error -C 11 = if only BUFR table messages in BUFR file -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: CLOSBF IDXMSG IUPBS01 OPENBF -C RDMSGW -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - DIMENSION MBAY(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - MESGTYP = -1 - -C SINCE OPENBF HAS NOT YET BEEN CALLED, CALL IT -C --------------------------------------------- - - CALL OPENBF(LUNIT,'INX',LUNIT) - -C READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND -C ----------------------------------------------------------------- - -1 CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.EQ.0) THEN - MESGTYP = IUPBS01(MBAY,'MTYP') - IF(IDXMSG(MBAY).EQ.1) GOTO 1 - ENDIF - -C CLOSE THE FILE -C -------------- - - CALL CLOSBF(LUNIT) - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/minimg.f b/src/bufr/minimg.f deleted file mode 100644 index 6d60fa0c3c..0000000000 --- a/src/bufr/minimg.f +++ /dev/null @@ -1,79 +0,0 @@ - SUBROUTINE MINIMG(LUNIT,MINI) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MINIMG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PACKS THE VALUE OF MINI INTO SECTION 1 OF -C THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT, -C SO THAT THIS VALUE THEN BECOMES THE MINUTES COMPONENT OF THE -C SECTION 1 DATE-TIME FOR THE MESSAGE. THIS SUBROUTINE SHOULD ONLY -C BE CALLED WHEN LOGICAL UNIT LUNIT HAS BEEN OPENED FOR OUTPUT -C OPERATIONS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN MSGINI) -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" (IN PARENT ROUTINE MSGINI) -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) (IN PARENT -C ROUTINE MSGINI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES (IN PARENT ROUTINE -C MSGINI) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE PKBS1 -C -C USAGE: CALL MINIMG (LUNIT, MINI) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C MINI - INTEGER: MINUTES VALUE TO BE PACKED -C -C REMARKS: -C THIS ROUTINE CALLS: BORT PKBS1 STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - - CALL PKBS1(MINI,MBAY(1,LUN),'MINU') - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: MINIMG - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') - END diff --git a/src/bufr/mrginv.f b/src/bufr/mrginv.f deleted file mode 100644 index 7ab6b662d8..0000000000 --- a/src/bufr/mrginv.f +++ /dev/null @@ -1,66 +0,0 @@ - SUBROUTINE MRGINV - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MRGINV -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 -C -C ABSTRACT: THIS SUBROUTINE PRINTS A SUMMARY OF MERGE ACTIVITY. -C -C PROGRAM HISTORY LOG: -C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN INVMRG) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL MRGINV -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT - COMMON /QUIET / IPRT - - CHARACTER*128 ERRSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') - CALL ERRWRT('---------------------------------------------------') - CALL ERRWRT('INVENTORY FROM MERGE PROCESS IN SUBROUTINE INVMRG:') - CALL ERRWRT('---------------------------------------------------') - WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) - . 'NUMBER OF DRB EXPANSIONS = ', NRPL - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) - . 'NUMBER OF MERGES = ', NMRG - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) - . 'NUMBER THAT ARE AMBIGUOUS = ', NAMB - CALL ERRWRT(ERRSTR) - CALL ERRWRT('---------------------------------------------------') - WRITE ( UNIT=ERRSTR, FMT='(A,I9)' ) - . 'TOTAL NUMBER OF VISITS = ', NTOT - CALL ERRWRT(ERRSTR) - CALL ERRWRT('---------------------------------------------------') - CALL ERRWRT('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - RETURN - END diff --git a/src/bufr/msgfull.f b/src/bufr/msgfull.f deleted file mode 100644 index 4748fe4c3b..0000000000 --- a/src/bufr/msgfull.f +++ /dev/null @@ -1,79 +0,0 @@ - LOGICAL FUNCTION MSGFULL(MSIZ,ITOADD,MXSIZ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MSGFULL -C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS LOGICAL FUNCTION DETERMINES WHETHER THE CURRENT SUBSET -C (OF LENGTH ITOADD BYTES) WILL FIT WITHIN THE CURRENT BUFR MESSAGE. -C A FINITE AMOUNT OF "WIGGLE ROOM" IS ALLOWED FOR AS SHOWN BELOW. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: MSGFULL (MSIZ,ITOADD,MXSIZ) -C INPUT ARGUMENT LIST: -C MSIZ - INTEGER: SIZE OF CURRENT MESSAGE (IN BYTES) -C ITOADD - INTEGER: SIZE OF SUBSET TO BE ADDED (IN BYTES) -C MXSIZ - INTEGER: MAXIMUM SIZE OF A BUFR MESSAGE -C -C OUTPUT ARGUMENT LIST: -C MSGFULL - LOGICAL: FALSE IF SUBSET WILL FIT; TRUE OTHERWISE -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD WRCMPS WRDXTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGSTD/ CSMF - COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT - - CHARACTER*1 CSMF - CHARACTER*1 CTRT - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C Allow for at least 11 additional bytes of "wiggle room" in the -C message, because subroutine MSGWRT may do any or all of the -C following: -C 3 bytes may be added by a call to subroutine CNVED4 -C + 1 byte (at most) of padding may be added to Section 4 -C + 7 bytes (at most) of padding may be added up to the next -C word boundary after Section 5 -C ---- -C 11 - - IWGBYT = 11 - -C But subroutine MSGWRT may also do any of all of the following: - -C 6 bytes may be added by a call to subroutine ATRCPT - - IF(CTRT.EQ.'Y') IWGBYT = IWGBYT + 6 - -C (MAXNC*2) bytes (at most) may be added by a call to -C subroutine STNDRD - - IF(CSMF.EQ.'Y') IWGBYT = IWGBYT + (MAXNC*2) - -C Determine whether the subset will fit. - - IF ( ( MSIZ + ITOADD + IWGBYT ) .GT. MXSIZ ) THEN - MSGFULL = .TRUE. - ELSE - MSGFULL = .FALSE. - ENDIF - - RETURN - END diff --git a/src/bufr/msgini.f b/src/bufr/msgini.f deleted file mode 100644 index 2adc9ae57d..0000000000 --- a/src/bufr/msgini.f +++ /dev/null @@ -1,214 +0,0 @@ - SUBROUTINE MSGINI(LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MSGINI -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A -C NEW BUFR MESSAGE FOR OUTPUT. ARRAYS ARE FILLED IN COMMON BLOCKS -C /MSGPTR/, /MSGCWD/ AND /BITBUF/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-12-11 J. WOOLLEN -- MODIFIED TO ALLOW INCLUSION OF MINUTES IN -C WRITING THE MESSAGE DATE INTO A BUFR -C MESSAGE -C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION -C WRITTEN IN SECTION 0 FROM 2 TO 3 -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT MINIMG (IT BECAME A -C SEPARATE ROUTINE IN THE BUFRLIB TO -C INCREASE PORTABILITY TO OTHER PLATFORMS) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 -C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13 -C 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO INITIALIZE LUNCPY -C -C USAGE: CALL MSGINI (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: BORT NEMTAB NEMTBA PKB -C PKC -C THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD OPENMB OPENMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 - COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /UFBCPL/ LUNCPY(NFILES) - - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*8 SUBTAG - CHARACTER*4 BUFR,SEVN - CHARACTER*3 TYP - CHARACTER*1 TAB - - DATA BUFR/'BUFR'/ - DATA SEVN/'7777'/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE -C --------------------------------------------------- - - SUBTAG = TAG(INODE(LUN)) -c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD - CALL NEMTBA(LUN,SUBTAG,MTYP,MSBT,INOD) - IF(INODE(LUN).NE.INOD) GOTO 900 - CALL NEMTAB(LUN,SUBTAG,ISUB,TAB,IRET) - IF(IRET.EQ.0) GOTO 901 - -C DATE CAN BE YYMMDDHH OR YYYYMMDDHH -C ---------------------------------- - - MCEN = MOD(IDATE(LUN)/10**8,100)+1 - MEAR = MOD(IDATE(LUN)/10**6,100) - MMON = MOD(IDATE(LUN)/10**4,100) - MDAY = MOD(IDATE(LUN)/10**2,100) - MOUR = MOD(IDATE(LUN) ,100) - MMIN = 0 - -c .... DK: Can this happen?? (investigate) - IF(MCEN.EQ.1) GOTO 902 - - IF(MEAR.EQ.0) MCEN = MCEN-1 - IF(MEAR.EQ.0) MEAR = 100 - -C INITIALIZE THE MESSAGE -C ---------------------- - - MBIT = 0 - NBY0 = 8 - NBY1 = 18 - NBY2 = 0 - NBY3 = 20 - NBY4 = 4 - NBY5 = 4 - NBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5 - -C SECTION 0 -C --------- - - CALL PKC(BUFR , 4 , MBAY(1,LUN),MBIT) - CALL PKB(NBYT , 24 , MBAY(1,LUN),MBIT) - CALL PKB( 3 , 8 , MBAY(1,LUN),MBIT) - -C SECTION 1 -C --------- - - CALL PKB(NBY1 , 24 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 3 , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 7 , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MTYP , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MSBT , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 13 , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MEAR , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MMON , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MDAY , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MOUR , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MMIN , 8 , MBAY(1,LUN),MBIT) - CALL PKB(MCEN , 8 , MBAY(1,LUN),MBIT) - -C SECTION 3 -C --------- - - CALL PKB(NBY3 , 24 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 16 , MBAY(1,LUN),MBIT) - CALL PKB(2**7 , 8 , MBAY(1,LUN),MBIT) - CALL PKB(IBCT , 16 , MBAY(1,LUN),MBIT) - CALL PKB(ISUB , 16 , MBAY(1,LUN),MBIT) - CALL PKB(IPD1 , 16 , MBAY(1,LUN),MBIT) - CALL PKB(IPD2 , 16 , MBAY(1,LUN),MBIT) - CALL PKB(IPD3 , 16 , MBAY(1,LUN),MBIT) - CALL PKB(IPD4 , 16 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - -C SECTION 4 -C --------- - - CALL PKB(NBY4 , 24 , MBAY(1,LUN),MBIT) - CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) - -C SECTION 5 -C --------- - - CALL PKC(SEVN , 4 , MBAY(1,LUN),MBIT) - -C DOUBLE CHECK INITIAL MESSAGE LENGTH -C ----------------------------------- - - IF(MOD(MBIT,8).NE.0) GOTO 903 - IF(MBIT/8.NE.NBYT ) GOTO 904 - - NMSG(LUN) = NMSG(LUN)+1 - NSUB(LUN) = 0 - MBYT(LUN) = NBYT - - LUNCPY(LUN)=0 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",'// - . 'I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN '// - . 'DICTIONARY")') INODE(LUN),INOD,SUBTAG - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE '// - . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBTAG - CALL BORT(BORT_STR) -902 CALL BORT - . ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') -903 CALL BORT('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END '// - . 'ON A BYTE BOUNDARY') -904 WRITE(BORT_STR,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR '// - . 'INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '// - . 'CALCULATED, NBYT (",I6)') MBIT/8,NBYT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/msgupd.f b/src/bufr/msgupd.f deleted file mode 100644 index 686369656d..0000000000 --- a/src/bufr/msgupd.f +++ /dev/null @@ -1,143 +0,0 @@ - SUBROUTINE MSGUPD(LUNIT,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MSGUPD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY -C (ARRAY IBAY IN COMMON BLOCK /BITBUF/) AND THEN TRIES TO ADD IT TO -C THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT -C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IF THE SUBSET WILL NOT FIT -C INTO THE CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO -C LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE CURRENT SUBSET. -C IF THE SUBSET IS LARGER THAN AN EMPTY MESSAGE, THE SUBSET IS -C DISCARDED AND A DIAGNOSTIC IS PRINTED. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1998-12-14 J. WOOLLEN -- NO LONGER CALLS BORT IF A SUBSET IS LARGER -C THAN A MESSAGE, JUST DISCARDS THE SUBSET -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- USE MSGFULL AND ERRWRT -C -C USAGE: CALL MSGUPD (LUNIT, LUN) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT IUPB MSGFULL MSGINI -C MSGWRT MVB PAD PKB -C USRTPL -C THIS ROUTINE IS CALLED BY: WRITSA WRITSB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /QUIET / IPRT - - LOGICAL MSGFULL - - CHARACTER*128 ERRSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C PAD THE SUBSET BUFFER -C --------------------- - - CALL PAD(IBAY,IBIT,IBYT,8) - -C SEE IF THE NEW SUBSET FITS -C -------------------------- - - IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) THEN -c .... NO it does not fit - CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) - CALL MSGINI(LUN) - ENDIF - - IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) GOTO 900 - -C SET A BYTE COUNT AND TRANSFER THE SUBSET BUFFER INTO THE MESSAGE -C ---------------------------------------------------------------- - - LBIT = 0 - CALL PKB(IBYT,16,IBAY,LBIT) - -C Note that we want to append the data for this subset to the end -C of Section 4, but the value in MBYT(LUN) already includes the -C length of Section 5 (i.e. 4 bytes). Therefore, we need to begin -C writing at the point 3 bytes prior to the byte currently pointed -C to by MBYT(LUN). - - CALL MVB(IBAY,1,MBAY(1,LUN),MBYT(LUN)-3,IBYT) - -C UPDATE THE SUBSET AND BYTE COUNTERS -C -------------------------------------- - - MBYT(LUN) = MBYT(LUN) + IBYT - NSUB(LUN) = NSUB(LUN) + 1 - - LBIT = (NBY0+NBY1+NBY2+4)*8 - CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT) - - LBYT = NBY0+NBY1+NBY2+NBY3 - NBYT = IUPB(MBAY(1,LUN),LBYT+1,24) - LBIT = LBYT*8 - CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT) - -C RESET THE USER ARRAYS AND EXIT NORMALLY -C --------------------------------------- - - CALL USRTPL(LUN,1,1) - GOTO 100 - -C ON ENCOUTERING OVERLARGE SUBSETS, EXIT GRACEFULLY (SUBSET DISCARDED) -C -------------------------------------------------------------------- - -900 IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A)') - . 'BUFRLIB: MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE ', - . '{MAXIMUM MESSAGE LENGTH = ', MAXBYT, '}' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('>>>>>>>OVERLARGE SUBSET DISCARDED FROM FILE<<<<<<<<') - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/msgwrt.f b/src/bufr/msgwrt.f deleted file mode 100644 index 625b05243a..0000000000 --- a/src/bufr/msgwrt.f +++ /dev/null @@ -1,307 +0,0 @@ - SUBROUTINE MSGWRT(LUNIT,MESG,MGBYT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MSGWRT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PERFORMS SOME FINAL CHECKS ON AN OUTPUT -C BUFR MESSAGE (E.G., CONFIRMING THAT EACH SECTION OF THE MESSAGE HAS -C AN EVEN NUMBER OF BYTES WHEN NECESSARY, "STANDARDIZING" THE MESSAGE -C IF REQUESTED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE -C STDMSG, ETC.), AND THEN PREPARES THE MESSAGE FOR FINAL OUTPUT TO -C LOGICAL UNIT LUNIT (E.G., ADDING THE STRING "7777" TO THE LAST FOUR -C BYTES OF THE MESSAGE, APPENDING ZEROED-OUT BYTES UP TO A SUBSEQUENT -C MACHINE WORD BOUNDARY, ETC.). IT THEN WRITES OUT THE FINISHED -C MESSAGE TO LOGICAL UNIT LUNIT AND ALSO STORES A COPY OF IT WITHIN -C COMMON /BUFRMG/ FOR POSSIBLE LATER RETRIEVAL VIA BUFR ARCHIVE -C LIBRARY SUBROUTINE WRITSA. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION -C WRITTEN IN SECTION 0 FROM 2 TO 3 -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1998-11-24 J. WOOLLEN -- MODIFIED TO ZERO OUT THE PADDING BYTES -C WRITTEN AT THE END OF SECTION 4 -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 J. ATOR -- DON'T WRITE TO LUNIT IF OPENED AS A NULL -C FILE BY OPENBF {NULL(LUN) = 1 IN NEW -C COMMON BLOCK /NULBFR/} (WAS IN DECODER -C VERSION); ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION; ADDED LOGIC TO CALL -C STNDRD IF REQUESTED VIA COMMON /MSGSTD/; -C ADDED LOGIC TO CALL OVRBS1 IF NECESSARY; -C MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01, PADMSG, PKBS1 AND -C NMWRD; ADDED LOGIC TO CALL PKBS1 AND/OR -C CNVED4 WHEN NECESSARY -C 2009-03-23 J. ATOR -- USE IDXMSG AND ERRWRT; ADD CALL TO ATRCPT; -C ALLOW STANDARDIZING VIA COMMON /MSGSTD/ -C EVEN IF DATA IS COMPRESSED; WORK ON LOCAL -C COPY OF INPUT MESSAGE -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C CALL NEW ROUTINE BLOCKS FOR FILE BLOCKING -C AND NEW C ROUTINE CWRBUFR TO WRITE BUFR -C MESSAGE TO DISK FILE -C -C USAGE: CALL MSGWRT (LUNIT, MESG, MGBYT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE TO OUTPUT TO LUNIT -C MGBYT - INTEGER: LENGTH OF BUFR MESSAGE IN BYTES -C -C OUTPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: ATRCPT BORT CNVED4 ERRWRT -C GETLENS IDXMSG IUPB IUPBS01 -C NMWRD PADMSG PKB PKBS1 -C PKC STATUS STNDRD BLOCKS -C CWRBUFR -C THIS ROUTINE IS CALLED BY: CLOSMG COPYBF COPYMG CPYMEM -C CPYUPD MSGUPD WRCMPS WRDXTB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - PARAMETER (MXCOD=15) - - COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) - COMMON /NULBFR/ NULL(NFILES) - COMMON /QUIET / IPRT - COMMON /MSGSTD/ CSMF - COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) - COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT - - CHARACTER*128 ERRSTR - - CHARACTER*8 CMNEM - CHARACTER*4 BUFR,SEVN - CHARACTER*1 CSMF - CHARACTER*1 CTRT - DIMENSION MESG(*) - DIMENSION MBAY(MXMSGLD4),MSGNEW(MXMSGLD4) - DIMENSION IEC0(2) - - DATA BUFR/'BUFR'/ - DATA SEVN/'7777'/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C MAKE A LOCAL COPY OF THE INPUT MESSAGE FOR USE WITHIN THIS -C SUBROUTINE, SINCE CALLS TO ANY OR ALL OF THE SUBROUTINES STNDRD, -C CNVED4, PKBS1, ATRCPT, ETC. MAY END UP MODIFYING THE MESSAGE -C BEFORE IT FINALLY GETS WRITTEN OUT TO LUNIT. - - MBYT = MGBYT - - IEC0(1) = MESG(1) - IEC0(2) = MESG(2) - IBIT = 32 - CALL PKB(MBYT,24,IEC0,IBIT) - - DO II = 1, NMWRD(IEC0) - MBAY(II) = MESG(II) - ENDDO - -C OVERWRITE ANY VALUES WITHIN SECTION 0 OR SECTION 1 THAT WERE -C REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE -C PKVS01. IF A REQUEST WAS MADE TO CHANGE THE BUFR EDITION NUMBER -C TO 4, THEN ACTUALLY CONVERT THE MESSAGE AS WELL. - - IF(NS01V.GT.0) THEN - DO I=1,NS01V - IF(CMNEM(I).EQ.'BEN') THEN - IF(IVMNEM(I).EQ.4) THEN - -C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4. - - IBIT = 32 - CALL PKB(MBYT,24,MBAY,IBIT) - - CALL CNVED4(MBAY,MXMSGLD4,MSGNEW) - -C COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE. - - MBYT = IUPBS01(MSGNEW,'LENM') - -C COPY THE MSGNEW ARRAY BACK INTO MBAY. - - DO II = 1, NMWRD(MSGNEW) - MBAY(II) = MSGNEW(II) - ENDDO - ENDIF - ELSE - -C OVERWRITE THE REQUESTED VALUE. - - CALL PKBS1(IVMNEM(I),MBAY,CMNEM(I)) - ENDIF - ENDDO - ENDIF - -C "STANDARDIZE" THE MESSAGE IF REQUESTED VIA COMMON /MSGSTD/. -C HOWEVER, WE DO NOT WANT TO DO THIS IF THE MESSAGE CONTAINS BUFR -C TABLE (DX) INFORMATION, IN WHICH CASE IT IS ALREADY "STANDARD". - - IF ( ( CSMF.EQ.'Y' ) .AND. ( IDXMSG(MBAY).NE.1 ) ) THEN - -C INSTALL SECTION 0 BYTE COUNT AND SECTION 5 '7777' INTO THE -C ORIGINAL MESSAGE. THIS IS NECESSARY BECAUSE SUBROUTINE STNDRD -C REQUIRES A COMPLETE AND WELL-FORMED BUFR MESSAGE AS ITS INPUT. - - IBIT = 32 - CALL PKB(MBYT,24,MBAY,IBIT) - IBIT = (MBYT-4)*8 - CALL PKC(SEVN,4,MBAY,IBIT) - - CALL STNDRD(LUNIT,MBAY,MXMSGLD4,MSGNEW) - -C COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE. - - MBYT = IUPBS01(MSGNEW,'LENM') - -C COPY THE MSGNEW ARRAY BACK INTO MBAY. - - DO II = 1, NMWRD(MSGNEW) - MBAY(II) = MSGNEW(II) - ENDDO - ENDIF - -C APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA -C COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX) -C INFORMATION. - - IF ( ( CTRT.EQ.'Y' ) .AND. ( IDXMSG(MBAY).NE.1 ) ) THEN - -C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE ATRCPT. - - IBIT = 32 - CALL PKB(MBYT,24,MBAY,IBIT) - - CALL ATRCPT(MBAY,MXMSGLD4,MSGNEW) - -C COMPUTE MBYT FOR THE REVISED MESSAGE. - - MBYT = IUPBS01(MSGNEW,'LENM') - -C COPY THE MSGNEW ARRAY BACK INTO MBAY. - - DO II = 1, NMWRD(MSGNEW) - MBAY(II) = MSGNEW(II) - ENDDO - ENDIF - -C GET THE SECTION LENGTHS. - - CALL GETLENS(MBAY,4,LEN0,LEN1,LEN2,LEN3,LEN4,L5) - -C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE -C THAT EACH SECTION WITHIN THE MESSAGE HAS AN EVEN NUMBER OF BYTES. - - IF(IUPBS01(MBAY,'BEN').LT.4) THEN - IF(MOD(LEN1,2).NE.0) GOTO 901 - IF(MOD(LEN2,2).NE.0) GOTO 902 - IF(MOD(LEN3,2).NE.0) GOTO 903 - IF(MOD(LEN4,2).NE.0) THEN - -C PAD SECTION 4 WITH AN ADDITIONAL BYTE -C THAT IS ZEROED OUT. - - IAD4 = LEN0+LEN1+LEN2+LEN3 - IAD5 = IAD4+LEN4 - IBIT = IAD4*8 - LEN4 = LEN4+1 - CALL PKB(LEN4,24,MBAY,IBIT) - IBIT = IAD5*8 - CALL PKB(0,8,MBAY,IBIT) - MBYT = MBYT+1 - ENDIF - ENDIF - -C WRITE SECTION 0 BYTE COUNT AND SECTION 5 -C ---------------------------------------- - - IBIT = 0 - CALL PKC(BUFR, 4,MBAY,IBIT) - CALL PKB(MBYT,24,MBAY,IBIT) - - KBIT = (MBYT-4)*8 - CALL PKC(SEVN, 4,MBAY,KBIT) - -C ZERO OUT THE EXTRA BYTES WHICH WILL BE WRITTEN -C ---------------------------------------------- - -C I.E. SINCE THE BUFR MESSAGE IS STORED WITHIN THE INTEGER ARRAY -C MBAY(*) (RATHER THAN WITHIN A CHARACTER ARRAY), WE NEED TO MAKE -C SURE THAT THE "7777" IS FOLLOWED BY ZEROED-OUT BYTES UP TO THE -C BOUNDARY OF THE LAST MACHINE WORD THAT WILL BE WRITTEN OUT. - - CALL PADMSG(MBAY,MXMSGLD4,NPBYT) - -C WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0 -C ------------------------------------------------------------------ - - MWRD = NMWRD(MBAY) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(NULL(LUN).EQ.0) then - CALL BLOCKS(MBAY,MWRD) - call cwrbufr(lun,mbay,mwrd) - ENDIF - - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,I7)') - . 'BUFRLIB: MSGWRT: LUNIT =', LUNIT, ', BYTES =', MBYT+NPBYT - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C SAVE A MEMORY COPY OF THIS MESSAGE, UNLESS IT'S A DX MESSAGE -C ------------------------------------------------------------ - - IF(IDXMSG(MBAY).NE.1) THEN - -C STORE A COPY OF THIS MESSAGE WITHIN COMMON /BUFRMG/, -C FOR POSSIBLE LATER RETRIEVAL DURING THE NEXT CALL TO -C SUBROUTINE WRITSA. - - MSGLEN = MWRD - DO I=1,MSGLEN - MSGTXT(I) = MBAY(I) - ENDDO - ENDIF - -C EXITS -C ----- - - RETURN -901 CALL BORT - . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2') -902 CALL BORT - . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2') -903 CALL BORT - . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') - END diff --git a/src/bufr/mtinfo.f b/src/bufr/mtinfo.f deleted file mode 100644 index be82da1557..0000000000 --- a/src/bufr/mtinfo.f +++ /dev/null @@ -1,62 +0,0 @@ - SUBROUTINE MTINFO ( CMTDIR, LUNMT1, LUNMT2 ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MTINFO -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY THE DIRECTORY LOCATION -C AND FORTRAN LOGICAL UNIT NUMBERS TO USE WHEN READING BUFR MASTER -C TABLES ON THE LOCAL FILE SYSTEM. THE INPUT LOGICAL UNIT NUMBERS -C SHOULD BE UNIQUE BUT SHOULD NOT ALREADY BE ASSIGNED TO ANY ACTUAL -C BUFR MASTER TABLE FILES. IF THIS SUBROUTINE IS NOT CALLED, THEN -C DEFAULT VALUES ARE USED AS DEFINED WITHIN BUFR ARCHIVE LIBRARY -C SUBROUTINE BFRINI. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL MTINFO ( CMTDIR, LUNMT1, LUNMT2 ) -C INPUT ARGUMENT LIST: -C CMTDIR - CHARACTER*(*): DIRECTORY LOCATION OF BUFR MASTER TABLES -C ON LOCAL FILE SYSTEM (UP TO 100 CHARACTERS) -C LUNMT1 - INTEGER: FIRST FORTRAN LOGICAL UNIT NUMBER TO USE WHEN -C READING BUFR MASTER TABLES ON LOCAL FILE SYSTEM -C LUNMT2 - INTEGER: SECOND FORTRAN LOGICAL UNIT NUMBER TO USE WHEN -C READING BUFR MASTER TABLES ON LOCAL FILE SYSTEM -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 STRSUC -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR - - CHARACTER*(*) CMTDIR - - CHARACTER*128 BORT_STR - CHARACTER*100 MTDIR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STRSUC ( CMTDIR, MTDIR, LMTD ) - IF ( LMTD .LT. 0 ) GOTO 900 - - LUN1 = LUNMT1 - LUN2 = LUNMT2 - -C EXITS -C ----- - - RETURN -900 BORT_STR = 'BUFRLIB: MTINFO - BAD INPUT MASTER TABLE DIRECTORY:' - CALL BORT2(BORT_STR,CMTDIR) - END diff --git a/src/bufr/mvb.f b/src/bufr/mvb.f deleted file mode 100644 index 5ae94eb343..0000000000 --- a/src/bufr/mvb.f +++ /dev/null @@ -1,79 +0,0 @@ - SUBROUTINE MVB(IB1,NB1,IB2,NB2,NBM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: MVB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF BYTES FROM -C ONE PACKED BINARY ARRAY TO ANOTHER. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2005-11-29 J. ATOR -- MAXIMUM NUMBER OF BYTES TO COPY INCREASED -C FROM 24000 TO MXIMB -C -C USAGE: CALL MVB (IB1, NB1, IB2, NB2, NBM) -C INPUT ARGUMENT LIST: -C IB1 - INTEGER: *-WORD PACKED INPUT BINARY ARRAY -C NB1 - INTEGER: POINTER TO FIRST BYTE IN IB1 TO COPY FROM -C NB2 - INTEGER: POINTER TO FIRST BYTE IN IB2 TO COPY TO -C NBM - INTEGER: NUMBER OF BYTES TO COPY -C -C OUTPUT ARGUMENT LIST: -C IB2 - INTEGER: *-WORD PACKED OUTPUT BINARY ARRAY -C -C REMARKS: -C THIS ROUTINE CALLS: BORT PKB UPB -C THIS ROUTINE IS CALLED BY: ATRCPT CNVED4 CPYUPD MSGUPD -C STNDRD -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - CHARACTER*128 BORT_STR - DIMENSION IB1(*),IB2(*),NVAL(MXIMB) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(NBM.GT.MXIMB) GOTO 900 - JB1 = 8*(NB1-1) - JB2 = 8*(NB2-1) - - DO N=1,NBM - CALL UPB(NVAL(N),8,IB1,JB1) - ENDDO - - DO N=1,NBM - CALL PKB(NVAL(N),8,IB2,JB2) - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: MVB - THE NUMBER OF BYTES BEING '// - . 'REQUESTED TO COPY (",I7,") EXCEEDS THE LIMIT (",I7,")")') - . NBM, MXIMB - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nemock.f b/src/bufr/nemock.f deleted file mode 100644 index 9dacfa2dee..0000000000 --- a/src/bufr/nemock.f +++ /dev/null @@ -1,89 +0,0 @@ - FUNCTION NEMOCK(NEMO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEMOCK -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CHECKS A MNEMONIC TO VERIFY THAT IT HAS A -C LENGTH OF BETWEEN ONE AND EIGHT CHARACTERS AND THAT IT ONLY -C CONTAINS CHARACTERS FROM THE ALLOWABLE CHARACTER SET. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- SPLIT NON-ZERO RETURN INTO -1 FOR LENGTH -C NOT 1-8 CHARACTERS AND -2 FOR INVALID -C CHARACTERS (RETURN ONLY -1 BEFORE FOR ALL -C PROBLEMATIC CASES); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION -C -C USAGE: NEMOCK (NEMO) -C INPUT ARGUMENT LIST: -C NEMO - CHARACTER*(*): MNEMONIC TO BE CHECKED -C -C OUTPUT ARGUMENT LIST: -C NEMOCK - INTEGER: INDICATOR AS TO WHETHER NEMO IS VALID: -C 0 = yes -C -1 = no, length not between 1 and 8 characters -C -2 = no, it does not contain characters from the -C allowable character set -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: RDUSDX SEQSDX SNTBBE SNTBDE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) NEMO - CHARACTER*38 CHRSET - - DATA CHRSET /'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_.'/ - DATA NCHR /38/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C GET THE LENGTH OF NEMO -C ---------------------- - - LNEMO = 0 - - DO I=LEN(NEMO),1,-1 - IF(NEMO(I:I).NE.' ') THEN - LNEMO = I - GOTO 1 - ENDIF - ENDDO - -1 IF(LNEMO.LT.1 .OR. LNEMO.GT.8) THEN - NEMOCK = -1 - GOTO 100 - ENDIF - -C SCAN NEMO FOR ALLOWABLE CHARACTERS -C ---------------------------------- - - DO 10 I=1,LNEMO - DO J=1,NCHR - IF(NEMO(I:I).EQ.CHRSET(J:J)) GOTO 10 - ENDDO - NEMOCK = -2 - GOTO 100 -10 ENDDO - - NEMOCK = 0 - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/nemtab.f b/src/bufr/nemtab.f deleted file mode 100644 index 8cb273cb72..0000000000 --- a/src/bufr/nemtab.f +++ /dev/null @@ -1,149 +0,0 @@ - SUBROUTINE NEMTAB(LUN,NEMO,IDN,TAB,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEMTAB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE -C INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS -C IN COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT -C THAT MNEMONIC FROM WITHIN THESE ARRAYS. OTHERWISE, IT CHECKS -C WHETHER NEMO IS A TABLE C OPERATOR DESCRIPTOR AND, IF SO, DIRECTLY -C COMPUTES AND RETURNS SIMILAR INFORMATION ABOUT THAT DESCRIPTOR. -C THIS SUBROUTINE MAY BE USEFUL TO APPLICATION PROGRAMS WHICH WANT -C TO CHECK WHETHER A PARTICULAR MNEMONIC IS IN THE DICTIONARY. IN -C THIS CASE, BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF MUST FIRST BE -C CALLED TO STORE THE DICTIONARY TABLE INTERNALLY, AND BUFR ARCHIVE -C LIBRARY SUBROUTINE STATUS MUST BE CALLED TO CONNECT THE LOGICAL -C UNIT NUMBER FOR THE BUFR FILE OPENED IN OPENBF TO LUN. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA -C USING THE OPERATOR DESCRIPTORS (BUFR TABLE -C C) FOR CHANGING WIDTH AND CHANGING SCALE -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS -C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 AND 205 OPERATORS -C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR -C -C USAGE: CALL NEMTAB (LUN, NEMO, IDN, TAB, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C NEMO - CHARACTER*(*): MNEMONIC TO SEARCH FOR -C -C OUTPUT ARGUMENT LIST: -C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE -C CORRESPONDING TO NEMO (IF NEMO WAS FOUND) -C TAB - CHARACTER*1: INTERNAL TABLE ARRAY IN WHICH NEMO WAS -C FOUND: -C 'B' = Table B array -C 'C' = Table C array -C 'D' = Table D array -C IRET - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB -C 0 = NEMO was not found within any of the Table -C B, C, or D arrays -C -C REMARKS: -C THIS ROUTINE CALLS: IFXY -C THIS ROUTINE IS CALLED BY: CHEKSTAB CMSGINI ELEMDX MSGINI -C SEQSDX STSEQ TABSUB UFBDMP -C UFBQCD UFDUMP UPFTBV -C Also called by application programs -C (see ABSTRACT). -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*(*) NEMO - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*8 NEMT - CHARACTER*1 TAB - LOGICAL FOLVAL - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - FOLVAL = NEMO(1:1).EQ.'.' - IRET = 0 - TAB = ' ' - -C LOOK FOR NEMO IN TABLE B -C ------------------------ - - DO 1 I=1,NTBB(LUN) - NEMT = TABB(I,LUN)(7:14) - IF(NEMT.EQ.NEMO) THEN - IDN = IDNB(I,LUN) - TAB = 'B' - IRET = I - GOTO 100 - ELSEIF(FOLVAL.AND.NEMT(1:1).EQ.'.') THEN - DO J=2,LEN(NEMT) - IF(NEMT(J:J).NE.'.' .AND. NEMT(J:J).NE.NEMO(J:J)) GOTO 1 - ENDDO - IDN = IDNB(I,LUN) - TAB = 'B' - IRET = I - GOTO 100 - ENDIF -1 ENDDO - -C DON'T LOOK IN TABLE D FOR FOLLOWING VALUE-MNEMONICS -C --------------------------------------------------- - - IF(FOLVAL) GOTO 100 - -C LOOK IN TABLE D IF WE GOT THIS FAR -C ---------------------------------- - - DO I=1,NTBD(LUN) - NEMT = TABD(I,LUN)(7:14) - IF(NEMT.EQ.NEMO) THEN - IDN = IDND(I,LUN) - TAB = 'D' - IRET = I - GOTO 100 - ENDIF - ENDDO - -C IF STILL NOTHING, CHECK HERE FOR TABLE C OPERATOR DESCRIPTORS -C ------------------------------------------------------------- - - IF ( (NEMO(1:2).EQ.'20') .AND. - . ( LGE(NEMO(3:3),'1') .AND. LLE(NEMO(3:3),'8') ) ) THEN - READ(NEMO,'(1X,I2)') IRET - IDN = IFXY(NEMO) - TAB = 'C' - GOTO 100 - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/nemtba.f b/src/bufr/nemtba.f deleted file mode 100644 index a0142eb831..0000000000 --- a/src/bufr/nemtba.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE NEMTBA(LUN,NEMO,MTYP,MSBT,INOD) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEMTBA -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE -C INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS IN -C COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT THAT -C MNEMONIC FROM WITHIN THESE ARRAYS. IT IS IDENTICAL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE NEMTBAX EXCEPT THAT, IF NEMO IS NOT FOUND, THIS -C SUBROUTINE MAKES AN APPROPRIATE CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2009-05-07 J. ATOR -- USE NEMTBAX -C -C USAGE: CALL NEMTBA (LUN, NEMO, MTYP, MSBT, INOD) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C NEMO - CHARACTER*(*): TABLE A MNEMONIC TO SEARCH FOR -C -C OUTPUT ARGUMENT LIST: -C MTYP - INTEGER: MESSAGE TYPE CORRESPONDING TO NEMO -C MSBT - INTEGER: MESSAGE SUBTYPE CORRESPONDING TO NEMO -C INOD - INTEGER: POSITIONAL INDEX OF NEMO WITHIN INTERNAL -C JUMP/LINK TABLE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT NEMTBAX -C THIS ROUTINE IS CALLED BY: CMSGINI COPYMG CPYMEM LCMGDF -C MSGINI OPENMB OPENMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - CHARACTER*(*) NEMO - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C LOOK FOR NEMO IN TABLE A -C ------------------------ - - CALL NEMTBAX(LUN,NEMO,MTYP,MSBT,INOD) - IF(INOD.EQ.0) GOTO 900 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NEMTBA - CAN''T FIND MNEMONIC ",A)') - . NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nemtbax.f b/src/bufr/nemtbax.f deleted file mode 100644 index 5473ccf115..0000000000 --- a/src/bufr/nemtbax.f +++ /dev/null @@ -1,92 +0,0 @@ - SUBROUTINE NEMTBAX(LUN,NEMO,MTYP,MSBT,INOD) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEMTBAX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 -C -C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE -C INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS IN -C COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT -C THAT MNEMONIC FROM WITHIN THESE ARRAYS. IT IS IDENTICAL TO BUFR -C ARCHIVE LIBRARY SUBROUTINE NEMTBA EXCEPT THAT, IF NEMO IS NOT -C FOUND, THIS SUBROUTINE RETURNS WITH INOD EQUAL TO ZERO, WHEREAS -C NEMTBA CALLS BUFR ARCHIVE LIBRARY SUBROUTINE BORT IN SUCH CASES. -C -C PROGRAM HISTORY LOG: -C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: CALL NEMTBAX (LUN, NEMO, MTYP, MSBT, INOD) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C NEMO - CHARACTER*(*): TABLE A MNEMONIC TO SEARCH FOR -C -C OUTPUT ARGUMENT LIST: -C MTYP - INTEGER: MESSAGE TYPE CORRESPONDING TO NEMO -C MSBT - INTEGER: MESSAGE SUBTYPE CORRESPONDING TO NEMO -C INOD - INTEGER: POSITIONAL INDEX OF NEMO WITHIN INTERNAL -C JUMP/LINK TABLE IF NEMO FOUND -C 0 = NEMO not found -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: CKTABA IOK2CPY NEMTBA STNDRD -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*(*) NEMO - CHARACTER*600 TABD - CHARACTER*128 BORT_STR - CHARACTER*128 TABB - CHARACTER*128 TABA - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - INOD = 0 - -C LOOK FOR NEMO IN TABLE A -C ------------------------ - - DO I=1,NTBA(LUN) - IF(TABA(I,LUN)(4:11).EQ.NEMO) THEN - MTYP = IDNA(I,LUN,1) - MSBT = IDNA(I,LUN,2) - INOD = MTAB(I,LUN) - IF(MTYP.LT.0 .OR. MTYP.GT.255) GOTO 900 - IF(MSBT.LT.0 .OR. MSBT.GT.255) GOTO 901 - GOTO 100 - ENDIF - ENDDO - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NEMTBAX - INVALID MESSAGE TYPE (",I4'// - . ',") RETURNED FOR MENMONIC ",A)') MTYP,NEMO - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: NEMTBAX - INVALID MESSAGE SUBTYPE ("'// - . ',I4,") RETURNED FOR MENMONIC ",A)') MSBT,NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nemtbb.f b/src/bufr/nemtbb.f deleted file mode 100644 index 7fee620203..0000000000 --- a/src/bufr/nemtbb.f +++ /dev/null @@ -1,129 +0,0 @@ - SUBROUTINE NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEMTBB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CHECKS ALL OF THE PROPERTIES (E.G. FXY -C VALUE, UNITS, SCALE FACTOR, REFERENCE VALUE, ETC.) OF A SPECIFIED -C MNEMONIC WITHIN THE INTERNAL BUFR TABLE B ARRAYS (IN COMMON BLOCK -C /TABABD/) IN ORDER TO VERIFY THAT THE VALUES OF THOSE PROPERTIES -C ARE ALL LEGAL AND WELL-DEFINED. IF ANY ERRORS ARE FOUND, THEN AN -C APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS -C 1999-11-18 J. WOOLLEN -- CHANGED CALL TO FUNCTION "VAL$" TO "VALX" -C (IT HAS BEEN RENAMED TO REMOVE THE -C POSSIBILITY OF THE "$" SYMBOL CAUSING -C PROBLEMS ON OTHER PLATFORMS) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL NEMTBB (LUN, ITAB, UNIT, ISCL, IREF, IBIT) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C ITAB - INTEGER: POSITIONAL INDEX INTO INTERNAL BUFR TABLE B -C ARRAYS FOR MNEMONIC TO BE CHECKED -C -C OUTPUT ARGUMENT LIST: -C UNIT - CHARACTER*24: UNITS OF MNEMONIC -C ISCL - INTEGER: SCALE FACTOR OF MNEMONIC -C IREF - INTEGER: REFERENCE VALUE OF MNEMONIC -C IBIT - INTEGER: BIT WIDTH OF MNEMONIC -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IFXY VALX -C THIS ROUTINE IS CALLED BY: CHEKSTAB RESTD TABENT -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*24 UNIT - CHARACTER*8 NEMO - REAL*8 MXR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - MXR = 1E11-1 - - IF(ITAB.LE.0 .OR. ITAB.GT.NTBB(LUN)) GOTO 900 - -C PULL OUT TABLE B INFORMATION -C ---------------------------- - - IDN = IDNB(ITAB,LUN) - NEMO = TABB(ITAB,LUN)( 7:14) - UNIT = TABB(ITAB,LUN)(71:94) - ISCL = VALX(TABB(ITAB,LUN)( 95: 98)) - IREF = VALX(TABB(ITAB,LUN)( 99:109)) - IBIT = VALX(TABB(ITAB,LUN)(110:112)) - -C CHECK TABLE B CONTENTS -C ---------------------- - - IF(IDN.LT.IFXY('000000')) GOTO 901 - IF(IDN.GT.IFXY('063255')) GOTO 901 - - IF(ISCL.LT.-999 .OR. ISCL.GT.999) GOTO 902 - IF(IREF.LE.-MXR .OR. IREF.GE.MXR) GOTO 903 - IF(IBIT.LE.0) GOTO 904 - IF(UNIT(1:5).NE.'CCITT' .AND. IBIT.GT.32 ) GOTO 904 - IF(UNIT(1:5).EQ.'CCITT' .AND. MOD(IBIT,8).NE.0) GOTO 905 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - ITAB (",I7,") NOT FOUND IN '// - . 'TABLE B")') ITAB - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - INTEGER REPRESENTATION OF '// - . 'DESCRIPTOR FOR TABLE B MNEMONIC ",A," (",I7,") IS OUTSIDE '// - . 'RANGE 0-16383 (16383 -> 0-63-255)")') NEMO,IDN - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - SCALE VALUE FOR TABLE B '// - .'MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE -999 TO 999")') - . NEMO,ISCL - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - REFERENCE VALUE FOR TABLE B'// - .' MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE +/- 1E11-1")') - . NEMO,IREF - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - BIT WIDTH FOR NON-CHARACTER'// - . ' TABLE B MNEMONIC ",A," (",I7,") IS > 32")') NEMO,IBIT - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - BIT WIDTH FOR CHARACTER '// - . 'TABLE B MNEMONIC ",A," (",I7,") IS NOT A MULTIPLE OF 8")') - . NEMO,IBIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nemtbd.f b/src/bufr/nemtbd.f deleted file mode 100644 index 659bfef88e..0000000000 --- a/src/bufr/nemtbd.f +++ /dev/null @@ -1,224 +0,0 @@ - SUBROUTINE NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEMTBD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE RETURNS A LIST OF THE MNEMONICS (I.E., -C "CHILD" MNEMONICS) CONTAINED WITHIN A TABLE D SEQUENCE MNEMONIC -C (I.E., A "PARENT MNEMONIC"). THIS INFORMATION SHOULD HAVE BEEN -C PACKED INTO THE INTERNAL BUFR TABLE D ENTRY FOR THE PARENT MNEMONIC -C (IN COMMON BLOCK /TABABD/) VIA PREVIOUS CALLS TO BUFR ARCHIVE -C LIBRARY SUBROUTINE PKTDD. NOTE THAT NEMTBD DOES NOT RECURSIVELY -C RESOLVE CHILD MNEMONICS WHICH ARE THEMSELVES TABLE D SEQUENCE -C MNEMONICS; RATHER, SUCH RESOLUTION MUST BE DONE VIA SEPARATE -C SUBSEQUENT CALLS TO THIS SUBROUTINE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MUST NOW CHECK FOR TABLE C (OPERATOR -C DESCRIPTOR) MNEMONICS SINCE THE CAPABILITY -C HAS NOW BEEN ADDED TO ENCODE AND DECODE -C THESE -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL NEMTBD (LUN, ITAB, NSEQ, NEMS, IRPS, KNTS) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C ITAB - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN -C INTERNAL BUFR TABLE D ARRAY TABD(*,*) -C -C OUTPUT ARGUMENT LIST: -C NSEQ - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS FOR THE -C PARENT MNEMONIC GIVEN BY TABD(ITAB,LUN) -C NEMS - CHARACTER*8: (NSEQ)-WORD ARRAY OF CHILD MNEMONICS -C IRPS - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS) -C KNTS - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS) -C -C REMARKS: -C VALUE FOR OUTPUT ARGUMENT IRPS: -C The interpretation of the return value IRPS(I) depends upon the -C type of descriptor corresponding to NEMS(I), as follows: -C -C IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed) -C replication descriptor ) THEN -C IRPS(I) = 1 -C ELSE IF ( NEMS(I) corresponds to a delayed replicator or -C replication factor descriptor ) THEN -C IRPS(I) = positional index of corresponding descriptor -C within internal replication array IDNR(*,*) -C ELSE -C IRPS(I) = 0 -C END IF -C -C -C VALUE FOR OUTPUT ARGUMENT KNTS: -C The interpretation of the return value KNTS(I) depends upon the -C type of descriptor corresponding to NEMS(I), as follows: -C -C IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed) -C replication descriptor ) THEN -C KNTS(I) = number of replications -C ELSE -C KNTS(I) = 0 -C END IF -C -C -C THIS ROUTINE CALLS: ADN30 BORT IFXY NUMTAB -C RSVFVM UPTDD -C THIS ROUTINE IS CALLED BY: CHEKSTAB DXDUMP GETABDB TABSUB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*128 BORT_STR - CHARACTER*8 NEMO,NEMS,NEMT,NEMF - CHARACTER*6 ADN30,CLEMON - CHARACTER*1 TAB - DIMENSION NEMS(MAXCD),IRPS(MAXCD),KNTS(MAXCD) - LOGICAL REP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(ITAB.LE.0 .OR. ITAB.GT.NTBD(LUN)) GOTO 900 - - REP = .FALSE. - -C CLEAR THE RETURN VALUES -C ----------------------- - - NSEQ = 0 - - DO I=1,MAXCD - NEMS(I) = ' ' - IRPS(I) = 0 - KNTS(I) = 0 - ENDDO - -C PARSE THE TABLE D ENTRY -C ----------------------- - - NEMO = TABD(ITAB,LUN)(7:14) - IDSC = IDND(ITAB,LUN) - CALL UPTDD(ITAB,LUN,0,NDSC) - - IF(IDSC.LT.IFXY('300000')) GOTO 901 - IF(IDSC.GT.IFXY('363255')) GOTO 901 -cccc IF(NDSC.LE.0 ) GOTO 902 - -C Loop through each child mnemonic. - -c .... DK: What happens here if NDSC=0 ? - DO J=1,NDSC - IF(NSEQ+1.GT.MAXCD) GOTO 903 - CALL UPTDD(ITAB,LUN,J,IDSC) -c .... get NEMT from IDSC - CALL NUMTAB(LUN,IDSC,NEMT,TAB,IRET) - IF(TAB.EQ.'R') THEN - IF(REP) GOTO 904 - REP = .TRUE. - IF(IRET.LT.0) THEN - -C F=1 regular (i.e. non-delayed) replication. - - IRPS(NSEQ+1) = 1 - KNTS(NSEQ+1) = ABS(IRET) - ELSEIF(IRET.GT.0) THEN - -C Delayed replication. - - IRPS(NSEQ+1) = IRET - ENDIF - ELSEIF(TAB.EQ.'F') THEN - -C Replication factor. - - IF(.NOT.REP) GOTO 904 - IRPS(NSEQ+1) = IRET - REP = .FALSE. - ELSEIF(TAB.EQ.'D'.OR.TAB.EQ.'C') THEN - REP = .FALSE. - NSEQ = NSEQ+1 - NEMS(NSEQ) = NEMT - ELSEIF(TAB.EQ.'B') THEN - REP = .FALSE. - NSEQ = NSEQ+1 - IF(NEMT(1:1).EQ.'.') THEN - -C This is a "following value" mnemonic. - - CALL UPTDD(ITAB,LUN,J+1,IDSC) -c .... get NEMF from IDSC - CALL NUMTAB(LUN,IDSC,NEMF,TAB,IRET) - CALL RSVFVM(NEMT,NEMF) - IF(TAB.NE.'B') GOTO 906 - ENDIF - NEMS(NSEQ) = NEMT - ELSE - GOTO 905 - ENDIF - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - ITAB (",I7,") NOT FOUND IN '// - . 'TABLE D")') ITAB - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - INTEGER REPRESENTATION OF '// - . 'DESCRIPTOR FOR TABLE D MNEMONIC ",A," (",I7,") IS OUTSIDE '// - . 'RANGE 0-65535 (65535 -> 3-63-255)")') NEMO,IDSC - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - TABLE D MNEMONIC ",A," IS A'// - . ' ZERO LENGTH SEQUENCE")') NEMO - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - THERE ARE MORE THAN '// - . '(",I4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '// - . 'MNEMONIC ",A)') MAXCD, NEMO - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - REPLICATOR IS OUT OF ORDER '// - . 'IN TABLE D SEQUENCE MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -905 CLEMON = ADN30(IDSC,6) - WRITE(BORT_STR,'("BUFRLIB: NEMTBD - UNRECOGNIZED DESCRIPTOR '// - . '",A," IN TABLE D SEQUENCE MNEMONIC ",A)') CLEMON,NEMO - CALL BORT(BORT_STR) -906 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - A ''FOLLOWING VALUE'' '// - . 'MNEMONIC (",A,") IS FROM TABLE ",A,", IT MUST BE FROM TABLE B'// - . '")') NEMF,TAB - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nenubd.f b/src/bufr/nenubd.f deleted file mode 100644 index 83c04083b0..0000000000 --- a/src/bufr/nenubd.f +++ /dev/null @@ -1,103 +0,0 @@ - SUBROUTINE NENUBD(NEMO,NUMB,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NENUBD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CHECKS A MNEMONIC AND FXY VALUE PAIR THAT -C WERE READ FROM A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER -C FORMAT, IN ORDER TO MAKE SURE THAT NEITHER VALUE HAS ALREADY BEEN -C DEFINED WITHIN INTERNAL BUFR TABLE B OR D (IN COMMON BLOCK -C /TABABD/) FOR THE GIVEN LUN. IF EITHER VALUE HAS ALREADY BEEN -C DEFINED FOR THIS LUN, THEN AN APPROPRIATE CALL IS MADE TO -C BUFR ARCHIVE LIBRARY SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN NENUCK) -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" (IN PARENT ROUTINE NENUCK) -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) (IN PARENT -C ROUTINE NENUCK) -C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE -C PORTABILITY TO OTHER PLATFORMS (NENUCK WAS -C THEN REMOVED BECAUSE IT WAS JUST A DUMMY -C ROUTINE WITH ENTRIES) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL NENUBD (NEMO, NUMB, LUN) -C INPUT ARGUMENT LIST: -C NEMO - CHARACTER*8: MNEMONIC -C NUMB - CHARACTER*6: FXY VALUE ASSOCIATED WITH NEMO -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: STBFDX STNTBI -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*8 NEMO - CHARACTER*6 NUMB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- -C CHECK TABLE B AND D -C ------------------- - - DO N=1,NTBB(LUN) - IF(NUMB.EQ.TABB(N,LUN)(1: 6)) GOTO 900 - IF(NEMO.EQ.TABB(N,LUN)(7:14)) GOTO 901 - ENDDO - - DO N=1,NTBD(LUN) - IF(NUMB.EQ.TABD(N,LUN)(1: 6)) GOTO 902 - IF(NEMO.EQ.TABD(N,LUN)(7:14)) GOTO 903 - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE B FXY VALUE (",A,") '// - . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE B MNEMONIC (",A,") '// - . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE D FXY VALUE (",A,") '// - . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE D MNEMONIC (",A,") '// - . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nevn.f b/src/bufr/nevn.f deleted file mode 100644 index c0c2722497..0000000000 --- a/src/bufr/nevn.f +++ /dev/null @@ -1,110 +0,0 @@ - FUNCTION NEVN(NODE,LUN,INV1,INV2,I1,I2,I3,USR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEVN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS FUNCTION LOOKS FOR ALL STACKED DATA EVENTS FOR A -C SPECIFIED DATA VALUE AND LEVEL WITHIN THE PORTION OF THE CURRENT -C SUBSET BUFFER BOUNDED BY THE INDICES INV1 AND INV2. ALL SUCH -C EVENTS ARE ACCUMULATED AND RETURNED TO THE CALLING PROGRAM WITHIN -C ARRAY USR. THE VALUE OF THE FUNCTION ITSELF IS THE TOTAL NUMBER -C OF EVENTS FOUND. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION -C VERSION) -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION -C -C USAGE: NEVN (NODE, LUN, INV1, INV2, I1, I2, I3, USR) -C INPUT ARGUMENT LIST: -C NODE - INTEGER: JUMP/LINK TABLE INDEX OF NODE TO RETURN -C STACKED VALUES FOR -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK FOR STACK VALUES -C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK FOR STACK VALUES -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR -C -C OUTPUT ARGUMENT LIST: -C USR - REAL*8:(I1,I2,I3) STARTING ADDRESS OF DATA VALUES READ -C FROM DATA SUBSET, EVENTS ARE RETURNED IN THE THIRD -C DIMENSION FOR A PARTICULAR DATA VALUE AND LEVEL IN THE -C FIRST AND SECOND DIMENSIONS -C NEVN - INTEGER: NUMBER OF EVENTS IN STACK (MUST BE LESS THAN -C OR EQUAL TO I3) -C -C REMARKS: -C IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY ROUTINE UFBIN3, -C WHICH, ITSELF, IS CALLED ONLY BY VERIFICATION -C APPLICATION PROGRAM GRIDTOBS, WHERE IT WAS PREVIOUSLY -C AN IN-LINE SUBROUTINE. IN GENERAL, NEVN DOES NOT WORK -C PROPERLY IN OTHER APPLICATION PROGRAMS AT THIS TIME. -C -C THIS ROUTINE CALLS: BORT INVWIN LSTJPB -C THIS ROUTINE IS CALLED BY: UFBIN3 -C Should NOT be called by any -C application programs!!! -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*128 BORT_STR - DIMENSION USR(I1,I2,I3) - REAL*8 VAL,USR - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - NEVN = 0 - -C FIND THE ENCLOSING EVENT STACK DESCRIPTOR -C ----------------------------------------- - - NDRS = LSTJPB(NODE,LUN,'DRS') - IF(NDRS.LE.0) GOTO 100 - - INVN = INVWIN(NDRS,LUN,INV1,INV2) - IF(INVN.EQ.0) GOTO 900 - - NEVN = VAL(INVN,LUN) - IF(NEVN.GT.I3) GOTO 901 - -C SEARCH EACH STACK LEVEL FOR THE REQUESTED NODE AND COPY THE VALUE -C ----------------------------------------------------------------- - - N2 = INVN + 1 - - DO L=1,NEVN - N1 = N2 - N2 = N2 + VAL(N1,LUN) - DO N=N1,N2 - IF(INV(N,LUN).EQ.NODE) USR(1,1,L) = VAL(N,LUN) - ENDDO - ENDDO - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: NEVN - CAN''T FIND THE EVENT STACK!!!!!!') -901 WRITE(BORT_STR,'("BUFRLIB: NEVN - THE NO. OF EVENTS FOR THE '// - . 'REQUESTED STACK (",I3,") EXCEEDS THE VALUE OF THE 3RD DIM. OF'// - . ' THE USR ARRAY (",I3,")")') NEVN,I3 - CALL BORT(BORT_STR) - END diff --git a/src/bufr/newwin.f b/src/bufr/newwin.f deleted file mode 100644 index 9fd82ede29..0000000000 --- a/src/bufr/newwin.f +++ /dev/null @@ -1,93 +0,0 @@ - SUBROUTINE NEWWIN(LUN,IWIN,JWIN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NEWWIN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: GIVEN AN INDEX WITHIN THE INTERNAL JUMP/LINK TABLE WHICH -C POINTS TO THE START OF AN "RPC" WINDOW (I.E. ITERATION OF AN 8-BIT -C OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE COMPUTES -C THE ENDING INDEX OF THE WINDOW. ALTERNATIVELY, IF THE GIVEN INDEX -C POINTS TO THE START OF A "SUB" WINDOW (I.E. THE FIRST NODE OF A -C SUBSET), THE SUBROUTINE RETURNS THE INDEX OF THE LAST NODE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION -C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC -C -C USAGE: CALL NEWWIN (LUN, IWIN, JWIN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IWIN - INTEGER: STARTING INDEX OF WINDOW ITERATION -C -C OUTPUT ARGUMENT LIST: -C JWIN - INTEGER: ENDING INDEX OF WINDOW ITERATION -C -C REMARKS: -C -C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN -C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. -C -C THIS ROUTINE CALLS: BORT LSTJPB -C THIS ROUTINE IS CALLED BY: DRSTPL UFBRW -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*128 BORT_STR - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(IWIN.EQ.1) THEN - -C This is a "SUB" (subset) node, so return JWIN as pointing to -C the last value of the entire subset. - - JWIN = NVAL(LUN) - GOTO 100 - ENDIF - -C Confirm that IWIN points to an RPC node and then compute JWIN. - - NODE = INV(IWIN,LUN) - IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 - JWIN = IWIN+VAL(IWIN,LUN) - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NEWWIN - LSTJPB FOR NODE",I6,'// - . '" (LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC '// - . '(IWIN =",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nmsub.f b/src/bufr/nmsub.f deleted file mode 100644 index 6d63f145fc..0000000000 --- a/src/bufr/nmsub.f +++ /dev/null @@ -1,77 +0,0 @@ - FUNCTION NMSUB(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NMSUB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION RETURNS THE NUMBER OF SUBSETS IN A BUFR -C MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE READMG OR EQUIVALENT. THE SUBSETS THEMSELVES DO NOT -C HAVE TO BE READ. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: NMSUB (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C NMSUB - INTEGER: NUMBER OF SUBSETS IN BUFR MESSAGE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT STATUS -C THIS ROUTINE IS CALLED BY: UFBMNS UFBPOS UFBTAB UFBTAM -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - NMSUB = 0 - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - - NMSUB = MSUB(LUN) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: NMSUB - INPUT BUFR FILE IS CLOSED, IT MUST '// - . 'BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: NMSUB - INPUT BUFR FILE IS OPEN FOR OUTPUT,'// - . ' IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: NMSUB - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') - END diff --git a/src/bufr/nmwrd.f b/src/bufr/nmwrd.f deleted file mode 100644 index 277975cbe1..0000000000 --- a/src/bufr/nmwrd.f +++ /dev/null @@ -1,52 +0,0 @@ - FUNCTION NMWRD(MBAY) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NMWRD -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: GIVEN AN INTEGER ARRAY CONTAINING SECTION ZERO FROM A -C BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT OF MACHINE WORDS -C (I.E. INTEGER ARRAY MEMBERS) THAT WILL HOLD THE ENTIRE MESSAGE. -C NOTE THAT THIS COUNT MAY BE GREATER THAN THE MINIMUM NUMBER -C OF WORDS REQUIRED TO HOLD THE MESSAGE. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: NMWRD (MBAY) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD ARRAY CONTAINING SECTION ZERO -C FROM A BUFR MESSAGE -C -C OUTPUT ARGUMENT LIST: -C NMWRD - INTEGER: BUFR MESSAGE LENGTH (IN MACHINE WORDS) -C -C REMARKS: -C THIS ROUTINE CALLS: IUPBS01 -C THIS ROUTINE IS CALLED BY: CNVED4 CPDXMM LMSG MSGWRT -C PADMSG STBFDX UFBMEM UFBMEX -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION MBAY(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LENM = IUPBS01(MBAY,'LENM') - IF(LENM.EQ.0) THEN - NMWRD = 0 - ELSE - NMWRD = ((LENM/8)+1)*(8/NBYTW) - ENDIF - - RETURN - END diff --git a/src/bufr/numbck.f b/src/bufr/numbck.f deleted file mode 100644 index 22241d1cdf..0000000000 --- a/src/bufr/numbck.f +++ /dev/null @@ -1,91 +0,0 @@ - FUNCTION NUMBCK(NUMB) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NUMBCK -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION CHECKS THE INPUT CHARACTER STRING TO DETERMINE -C WHETHER IT CONTAINS A VALID FXY (DESCRIPTOR) VALUE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- SPLIT NON-ZERO RETURN INTO -1 FOR INVALID -C CHARACTER IN POSITION 1, -2 FOR INVALID -C CHARACTERS IN POSITIONS 2 THROUGH 6, -3 FOR -C INVALID CHARACTERS IN POSITIONS 2 AND 3 DUE -C TO BEING OUT OF RANGE, AND -4 FOR INVALID -C CHARACTERS IN POSITIONS 4 THROUGH 6 DUE TO -C BEING OUT OF RANGE (RETURN ONLY -1 BEFORE -C FOR ALL PROBLEMATIC CASES); UNIFIED/ -C PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2007-01-19 J. ATOR -- CLEANED UP AND SIMPLIFIED LOGIC -C -C USAGE: NUMBCK (NUMB) -C INPUT ARGUMENT LIST: -C NUMB - CHARACTER*6: FXY VALUE TO BE CHECKED -C -C OUTPUT ARGUMENT LIST: -C NUMBCK - INTEGER: INDICATOR AS TO WHETHER NUMB IS VALID: -C 0 = YES -C -1 = NO - first character ("F" value) is not '0', -C '1', '2' OR '3' -C -2 = NO - remaining characters (2-6) ("X" and "Y" -C values) are not all numeric -C -3 = NO - characters 2-3 ("X" value) are not -C between '00' and '63' -C -4 = NO - characters 4-6 ("Y" value) are not -C between '000' and '255' -C -C REMARKS: -C THIS ROUTINE CALLS: DIGIT -C THIS ROUTINE IS CALLED BY: IGETFXY RDUSDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*6 NUMB - LOGICAL DIGIT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FIRST CHARACTER OF NUMB -C --------------------------------- - - IF( LLT(NUMB(1:1),'0') .OR. LGT(NUMB(1:1),'3') ) THEN - NUMBCK = -1 - RETURN - ENDIF - -C CHECK FOR A VALID DESCRIPTOR -C ---------------------------- - - IF(DIGIT(NUMB(2:6))) THEN - READ(NUMB,'(1X,I2,I3)') IX,IY - ELSE - NUMBCK = -2 - RETURN - ENDIF - - IF(IX.LT.0 .OR. IX.GT. 63) THEN - NUMBCK = -3 - RETURN - ELSE IF(IY.LT.0 .OR. IY.GT.255) THEN - NUMBCK = -4 - RETURN - ENDIF - - NUMBCK = 0 - - RETURN - END diff --git a/src/bufr/nummtb.c b/src/bufr/nummtb.c deleted file mode 100644 index 2d9b46e7ce..0000000000 --- a/src/bufr/nummtb.c +++ /dev/null @@ -1,68 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NUMMTB -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS ROUTINE SEARCHES FOR AN ENTRY CORRESPONDING TO IDN -C IN THE BUFR MASTER TABLE (EITHER 'B' OR 'D', DEPENDING ON THE VALUE -C OF IDN). THE SEARCH USES BINARY SEARCH LOGIC, SO ALL OF THE ENTRIES -C IN THE TABLE MUST BE SORTED IN ASCENDING ORDER (BY FXY NUMBER) IN -C ORDER FOR THIS ROUTINE TO WORK PROPERLY. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL NUMMTB( IDN, TAB, IPT ) -C INPUT ARGUMENT LIST: -C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE TO BE -C SEARCHED FOR -C -C OUTPUT ARGUMENT LIST: -C TAB - CHARACTER: TABLE IN WHICH IDN WAS FOUND ('B' OR 'D') -C IPT - INTEGER: INDEX OF ENTRY FOR IDN IN MASTER TABLE TAB -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CADN30 CMPIA -C THIS ROUTINE IS CALLED BY: STSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#define COMMON_MSTABS -#include "bufrlib.h" - -void nummtb( f77int *idn, char *tab, f77int *ipt ) -{ - f77int *pifxyn, *pbs, nmt; - - char adn[7], errstr[129]; - - if ( *idn >= ifxy( "300000", 6 ) ) { - *tab = 'D'; - pifxyn = &mstabs.idfxyn[0]; - nmt = mstabs.nmtd; - } - else { - *tab = 'B'; - pifxyn = &mstabs.ibfxyn[0]; - nmt = mstabs.nmtb; - } - - pbs = ( f77int * ) bsearch( idn, pifxyn, ( size_t ) nmt, sizeof( f77int ), - ( int (*) ( const void *, const void * ) ) cmpia ); - if ( pbs == NULL ) { - cadn30( idn, adn, sizeof( adn ) ); - adn[6] = '\0'; - sprintf( errstr, "BUFRLIB: NUMMTB - COULD NOT FIND DESCRIPTOR " - "%s IN MASTER TABLE %c", adn, *tab ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - *ipt = pbs - pifxyn; - - return; -} diff --git a/src/bufr/numtab.f b/src/bufr/numtab.f deleted file mode 100644 index d673ab0caa..0000000000 --- a/src/bufr/numtab.f +++ /dev/null @@ -1,183 +0,0 @@ - SUBROUTINE NUMTAB(LUN,IDN,NEMO,TAB,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NUMTAB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE FIRST SEARCHES FOR AN INTEGER IDN, -C CONTAINING THE BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, -C WITHIN THE INTERNAL BUFR REPLICATION ARRAYS IN COMMON BLOCK /REPTAB/ -C TO SEE IF IDN IS A REPLICATION DESCRIPTOR OR A REPLICATION FACTOR -C DESCRIPTOR. IF THIS SEARCH IS UNSUCCESSFUL, IT SEACHES FOR IDN -C WITHIN THE INTERNAL BUFR TABLE D AND B ARRAYS TO SEE IF IDN IS A -C TABLE D OR TABLE B DESCRIPTOR. IF THIS SEARCH IS ALSO UNSUCCESSFUL, -C IT SEARCHES TO SEE IF IDN IS A TABLE C OPERATOR DESCRIPTOR. IF IDN -C IS FOUND IN ANY OF THESE SEARCHES, THIS SUBROUTINE RETURNS THE -C CORRESPONDING MNEMONIC AND OTHER INFORMATION FROM WITHIN EITHER THE -C INTERNAL ARRAYS FOR REPLICATION, REPLICATION FACTOR, TABLE D OR -C TABLE B DESCRIPTORS, OR ELSE FROM THE KNOWN VALUES FOR TABLE C -C DESCRIPTORS. IF IDN IS NOT FOUND, IT RETURNS WITH IRET=0. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA -C USING THE OPERATOR DESCRIPTORS (BUFR TABLE -C C) FOR CHANGING WIDTH AND CHANGING SCALE -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; CORRECTED TYPO ("IDN" WAS -C SPECIFIED AS "ID" IN CALCULATION OF IRET -C FOR TAB='C') -C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS -C 2009-04-21 J. ATOR -- USE NUMTBD -C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 AND 205 OPERATORS -C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR -C -C USAGE: CALL NUMTAB (LUN, IDN, NEMO, TAB, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) -C VALUE -C -C OUTPUT ARGUMENT LIST: -C NEMO - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN -C TAB - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE -C REPRESENTED BY IDN: -C 'B' = BUFR Table B descriptor -C 'C' = BUFR Table C descriptor -C 'D' = BUFR Table D descriptor -C 'R' = BUFR replication descriptor -C 'F' = BUFR replication factor descriptor -C IRET - INTEGER: RETURN VALUE (SEE REMARKS) -C -C REMARKS: -C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE -C RETURN VALUE OF TAB AND THE INPUT VALUE IDN, AS FOLLOWS: -C -C IF ( TAB = 'B' ) THEN -C IRET = positional index of IDN within internal BUFR Table B -C array -C ELSE IF ( TAB = 'C') THEN -C IRET = the X portion of the FXY value that is bit-wise -C represented by IDN -C ELSE IF ( TAB = 'D') THEN -C IRET = positional index of IDN within internal BUFR Table D -C array -C ELSE IF ( TAB = 'R') THEN -C IF ( IDN denoted regular (i.e. non-delayed) replication ) THEN -C IRET = ((-1)*Y), where Y is the number of replications -C ELSE ( i.e. delayed replication ) -C IRET = positional index (=I) of IDN within internal -C replication descriptor array IDNR(I,1), where: -C IRET (=I) =2 --> 16-bit delayed replication descriptor -C IRET (=I) =3 --> 8-bit delayed replication descriptor -C IRET (=I) =4 --> 8-bit delayed replication descriptor -C (stack) -C IRET (=I) =5 --> 1-bit delayed replication descriptor -C END IF -C ELSE IF ( TAB = 'F') THEN -C IRET = positional index (=I) of IDN within internal replication -C factor array IDNR(I,2), where: -C IRET (=I) =2 --> 16-bit replication factor -C IRET (=I) =3 --> 8-bit replication factor -C IRET (=I) =4 --> 8-bit replication factor -C (stack) -C IRET (=I) =5 --> 1-bit replication factor -C ELSE IF ( IRET = 0 ) THEN -C IDN was not found in internal BUFR Table B or D, nor does it -C represent a Table C operator descriptor, a replication -C descriptor, or a replication factor descriptor -C END IF -C -C -C THIS ROUTINE CALLS: ADN30 NUMTBD -C THIS ROUTINE IS CALLED BY: CKTABA NEMTBD SEQSDX STNDRD -C UFBQCP -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - -C Note that the values within the COMMON /REPTAB/ arrays were -C initialized within subroutine BFRINI. - - COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) - - CHARACTER*(*) NEMO - CHARACTER*6 ADN30,CID - CHARACTER*3 TYPS - CHARACTER*1 REPS,TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - NEMO = ' ' - IRET = 0 - TAB = ' ' - -C LOOK FOR A REPLICATOR OR A REPLICATION FACTOR DESCRIPTOR -C -------------------------------------------------------- - - IF(IDN.GE.IDNR(1,1) .AND. IDN.LE.IDNR(1,2)) THEN - -C Note that the above test is checking whether IDN is the bit- -C wise representation of a FXY (descriptor) value denoting F=1 -C regular (i.e. non-delayed) replication, since, as was -C initialized within subroutine BFRINI, -C IDNR(1,1) = IFXY('101000'), and IDNR(1,2) = IFXY('101255'). - - TAB = 'R' - IRET = -MOD(IDN,256) - GOTO 100 - ENDIF - - DO I=2,5 - IF(IDN.EQ.IDNR(I,1)) THEN - TAB = 'R' - IRET = I - GOTO 100 - ELSEIF(IDN.EQ.IDNR(I,2)) THEN - TAB = 'F' - IRET = I - GOTO 100 - ENDIF - ENDDO - -C LOOK FOR IDN IN TABLE B AND TABLE D -C ----------------------------------- - - CALL NUMTBD(LUN,IDN,NEMO,TAB,IRET) - IF(IRET.NE.0) GOTO 100 - -C LOOK FOR IDN IN TABLE C -C ----------------------- - - CID = ADN30(IDN,6) - IF ( (CID(1:2).EQ.'20') .AND. - . ( LGE(CID(3:3),'1') .AND. LLE(CID(3:3),'8') ) ) THEN - NEMO = CID(1:6) - READ(NEMO,'(1X,I2)') IRET - TAB = 'C' - GOTO 100 - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/numtbd.f b/src/bufr/numtbd.f deleted file mode 100644 index d0ebac2bed..0000000000 --- a/src/bufr/numtbd.f +++ /dev/null @@ -1,118 +0,0 @@ - SUBROUTINE NUMTBD(LUN,IDN,NEMO,TAB,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NUMTBD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE SEARCHES FOR AN INTEGER IDN, CONTAINING THE -C BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, WITHIN THE -C INTERNAL BUFR TABLE B AND D ARRAYS IN COMMON BLOCK /TABABD/. IF -C FOUND, IT RETURNS THE CORRESPONDING MNEMONIC AND OTHER INFORMATION -C FROM WITHIN THESE ARRAYS. IF IDN IS NOT FOUND, IT RETURNS WITH -C IRET=0. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C 2009-04-21 J. ATOR -- USE IFXY FOR MORE EFFICIENT SEARCHING -C -C USAGE: CALL NUMTBD (LUN, IDN, NEMO, TAB, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) -C VALUE -C -C OUTPUT ARGUMENT LIST: -C NEMO - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN -C TAB - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE -C REPRESENTED BY IDN: -C 'B' = BUFR Table B descriptor -C 'D' = BUFR Table D descriptor -C IRET - INTEGER: RETURN VALUE (SEE REMARKS) -C -C REMARKS: -C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE -C RETURN VALUE OF TAB, AS FOLLOWS: -C -C IF ( TAB = 'B' ) THEN -C IRET = positional index of IDN within internal BUFR Table B -C array -C ELSE IF ( TAB = 'D') THEN -C IRET = positional index of IDN within internal BUFR Table D -C array -C ELSE IF ( IRET = 0 ) THEN -C IDN was not found in internal BUFR Table B or D -C END IF -C -C -C THIS ROUTINE CALLS: IFXY -C THIS ROUTINE IS CALLED BY: NUMTAB RESTD STSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*(*) NEMO - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*1 TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - NEMO = ' ' - IRET = 0 - TAB = ' ' - - IF(IDN.GE.IFXY('300000')) THEN - -C LOOK FOR IDN IN TABLE D -C ----------------------- - - DO I=1,NTBD(LUN) - IF(IDN.EQ.IDND(I,LUN)) THEN - NEMO = TABD(I,LUN)(7:14) - TAB = 'D' - IRET = I - GOTO 100 - ENDIF - ENDDO - - ELSE - -C LOOK FOR IDN IN TABLE B -C ----------------------- - - DO I=1,NTBB(LUN) - IF(IDN.EQ.IDNB(I,LUN)) THEN - NEMO = TABB(I,LUN)(7:14) - TAB = 'B' - IRET = I - GOTO 100 - ENDIF - ENDDO - - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/nvnwin.f b/src/bufr/nvnwin.f deleted file mode 100644 index d06ce97adf..0000000000 --- a/src/bufr/nvnwin.f +++ /dev/null @@ -1,109 +0,0 @@ - FUNCTION NVNWIN(NODE,LUN,INV1,INV2,INVN,NMAX) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NVNWIN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION LOOKS FOR AND RETURNS ALL OCCURRENCES OF A -C SPECIFIED NODE WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER -C BOUNDED BY THE INDICES INV1 AND INV2. THE RESULTING LIST IS A -C STACK OF "EVENT" INDICES FOR THE REQUESTED NODE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR -C UNUSUAL THINGS HAPPEN -C 2009-03-23 J. ATOR -- USE 1E9 TO PREVENT OVERFLOW WHEN -C INITIALIZING INVN; USE ERRWRT -C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION -C -C USAGE: NVNWIN (NODE, LUN, INV1, INV2, INVN, NMAX) -C INPUT ARGUMENT LIST: -C NODE - INTEGER: JUMP/LINK TABLE INDEX TO LOOK FOR -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK -C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET -C BUFFER IN WHICH TO LOOK -C NMAX - INTEGER: DIMENSIONED SIZE OF INVN; USED BY THE -C FUNCTION TO ENSURE THAT IT DOES NOT OVERFLOW THE -C INVN ARRAY -C -C OUTPUT ARGUMENT LIST: -C INVN - INTEGER: ARRAY OF STACK "EVENT" INDICES FOR NODE -C NVNWIN - INTEGER: NUMBER OF INDICES RETURNED WITHIN INVN -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT -C THIS ROUTINE IS CALLED BY: UFBEVN -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET / IPRT - - CHARACTER*128 BORT_STR - DIMENSION INVN(NMAX) - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - NVNWIN = 0 - - IF(NODE.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT('BUFRLIB: NVNWIN - NODE=0, IMMEDIATE RETURN') - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ENDIF - - DO I=1,NMAX - INVN(I) = 1E9 - ENDDO - -C SEARCH BETWEEN INV1 AND INV2 -C ---------------------------- - - DO N=INV1,INV2 - IF(INV(N,LUN).EQ.NODE) THEN - IF(NVNWIN+1.GT.NMAX) GOTO 900 - NVNWIN = NVNWIN+1 - INVN(NVNWIN) = N - ENDIF - ENDDO - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NVNWIN - THE NUMBER OF EVENTS, '// - . 'NVNWIN (",I5,") EXCEEDS THE LIMIT, NMAX (",I5,")")') NVNWIN,NMAX - CALL BORT(BORT_STR) - END diff --git a/src/bufr/nwords.f b/src/bufr/nwords.f deleted file mode 100644 index b3b6481aa7..0000000000 --- a/src/bufr/nwords.f +++ /dev/null @@ -1,63 +0,0 @@ - FUNCTION NWORDS(N,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NWORDS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 -C -C ABSTRACT: THIS FUNCTION ADDS UP THE COMPLETE LENGTH OF THE DELAYED -C REPLICATION SEQUENCE BEGINNING AT INDEX N OF THE DATA SUBSET. -C -C PROGRAM HISTORY LOG: -C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE) -C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION -C -C USAGE: NWORDS (N, LUN) -C INPUT ARGUMENT LIST: -C N - INTEGER: INDEX TO START OF DELAYED REPLICATION SEQUENCE -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C OUTPUT ARGUMENT LIST: -C NWORDS - INTEGER: COMPLETE LENGTH OF DELAYED REPLICATION -C SEQUENCE WITHIN DATA SUBSET -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: INVMRG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - REAL*8 VAL - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - NWORDS = 0 - - DO K=1,NINT(VAL(N,LUN)) - NWORDS = NWORDS + NINT(VAL(NWORDS+N+1,LUN)) - ENDDO - - RETURN - END diff --git a/src/bufr/nxtwin.f b/src/bufr/nxtwin.f deleted file mode 100644 index e862c17d15..0000000000 --- a/src/bufr/nxtwin.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE NXTWIN(LUN,IWIN,JWIN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NXTWIN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: GIVEN INDICES WITHIN THE INTERNAL JUMP/LINK TABLE WHICH -C POINT TO THE START AND END OF AN "RPC" WINDOW (I.E. ITERATION OF -C AN 8-BIT OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE -C COMPUTES THE START AND END INDICES OF THE NEXT WINDOW. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE); OUTPUTS MORE -C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION -C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC -C -C USAGE: CALL NXTWIN (LUN, IWIN, JWIN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IWIN - INTEGER: STARTING INDEX OF CURRENT WINDOW ITERATION -C JWIN - INTEGER: ENDING INDEX OF CURRENT WINDOW ITERATION -C -C OUTPUT ARGUMENT LIST: -C IWIN - INTEGER: STARTING INDEX OF NEXT WINDOW ITERATION -C JWIN - INTEGER: ENDING INDEX OF NEXT WINDOW ITERATION -C -C REMARKS: -C -C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN -C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. -C -C THIS ROUTINE CALLS: BORT LSTJPB -C THIS ROUTINE IS CALLED BY: UFBEVN UFBIN3 UFBRW -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*128 BORT_STR - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(JWIN.EQ.NVAL(LUN)) THEN - IWIN = 0 - GOTO 100 - ENDIF - -C FIND THE NEXT SEQUENTIAL WINDOW -C ------------------------------- - - NODE = INV(IWIN,LUN) - IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 - IF(VAL(JWIN,LUN).EQ.0) THEN - IWIN = 0 - ELSE - IWIN = JWIN - JWIN = IWIN+VAL(IWIN,LUN) - ENDIF - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: NXTWIN - LSTJPB FOR NODE",I6," '// - . '(LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN '// - . '=",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN - CALL BORT(BORT_STR) - END diff --git a/src/bufr/openbf.f b/src/bufr/openbf.f deleted file mode 100644 index d7076c1d65..0000000000 --- a/src/bufr/openbf.f +++ /dev/null @@ -1,318 +0,0 @@ - SUBROUTINE OPENBF(LUNIT,IO,LUNDX) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: OPENBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE NORMALLY (I.E. EXCEPT WHEN INPUT ARGUMENT -C IO IS 'QUIET') IDENTIFIES A NEW LOGICAL UNIT TO THE BUFR ARCHIVE -C LIBRARY SOFTWARE FOR INPUT OR OUTPUT OPERATIONS. HOWEVER, THE -C FIRST TIME IT IS CALLED, IT ALSO FIGURES OUT SOME IMPORTANT -C INFORMATION ABOUT THE LOCAL MACHINE ON WHICH THE SOFTWARE IS BEING -C RUN (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE WRDLEN), AND IT -C ALSO INITIALIZES ARRAYS IN MANY BUFR ARCHIVE LIBRARY COMMON BLOCKS -C (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI). UP TO 32 -C LOGICAL UNITS CAN BE CONNECTED TO THE BUFR ARCHIVE LIBRARY SOFTWARE -C AT ANY ONE TIME. -C -C NOTE: IF IO IS PASSED IN AS 'QUIET', THEN OPENBF PERFORMS ONLY ONE -C FUNCTION - IT SIMPLY SETS THE "DEGREE OF PRINTOUT" SWITCH IPRT (IN -C COMMON BLOCK /QUIET/) TO THE VALUE OF INPUT ARGUMENT LUNDX, -C OVERRIDING ITS PREVIOUS VALUE. A DEFAULT IPRT VALUE OF 0 (I.E. -C "LIMITED PRINTOUT") IS SET DURING THE FIRST CALL TO THIS ROUTINE, -C BUT THIS OR ANY OTHER IPRT VALUE MAY BE SET AND RESET AS OFTEN AS -C DESIRED VIA SUCCESSIVE CALLS TO OPENBF WITH IO = 'QUIET'. -C IN ALL SUCH CASES, OPENBF SIMPLY (RE)SETS IPRT AND THEN RETURNS -C WITHOUT ACTUALLY OPENING ANY FILES. THE DEGREE OF PRINTOUT -C INCREASES AS IPRT INCREASES FROM "-1" TO "0" TO "1" TO "2". -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED IO='NUL' OPTION IN ORDER TO PREVENT -C LATER WRITING TO BUFR FILE IN LUNIT (WAS IN -C DECODER VERSION); ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY, UNUSUAL THINGS HAPPEN OR FOR -C INFORMATIONAL PURPOSES -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST FLAG AND IO="NODX" -C OPTION -C 2005-11-29 J. ATOR -- ADDED COMMON /MSGFMT/ AND ICHKSTR CALL -C 2009-03-23 J. ATOR -- ADDED IO='SEC3' OPTION; REMOVED CALL TO -C POSAPN; CLARIFIED COMMENTS; USE ERRWRT -C 2010-05-11 J. ATOR -- ADDED COMMON /STCODE/ -C 2012-06-18 J. ATOR -- ADDED IO='INUL' OPTION -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C USE INQUIRE TO OBTAIN THE FILENAME; -C CALL C ROUTINES OPENRB, OPENWB, AND -C OPENAB TO CONNECT BUFR FILES TO C; -C ADDED IO TYPE 'INX' TO ENABLE OPEN AND -C CLOSE FOR C FILE WITHOUT CLOSING FORTRAN -C FILE; ADD IO TYPE 'FIRST' TO SUPPORT CALLS -C TO BFRINI AND WRDLEN PRIOR TO USER RESET -C OF BUFRLIB PARAMETERS FOUND IN NEW ROUTINES -C SETBMISS AND SETBLOCK -C -C USAGE: CALL OPENBF (LUNIT, IO, LUNDX) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C (UNLESS IO IS 'QUIET', THEN A DUMMY) -C IO - CHARACTER*(*): FLAG INDICATING HOW LUNIT IS TO BE -C USED BY THE SOFTWARE: -C 'IN' = input operations with table processing -C 'INX' = input operations w/o table processing -C 'OUX' = output operations w/o table processing -C 'OUT' = output operations with table processing -C 'SEC3' = same as 'IN', except use Section 3 of input -C messages for decoding rather than dictionary -C table information from LUNDX; in this case -C LUNDX is ignored, and user must provide -C appropriate BUFR master tables within -C directory specified by a subsequent call -C to subroutine MTINFO -C 'NODX' = same as 'OUT', except don't write dictionary -C (i.e. DX) table messages to LUNIT -C 'APN' = same as 'NODX', except begin writing at end -C of file ("append") -C 'APX' = same as 'APN', except backspace before -C appending -C 'NUL' = same as 'OUT', except don't write any -C messages whatsoever to LUNIT (e.g. when -C subroutine WRITSA is to be used) -C 'INUL' = same as 'IN', except don't read any -C messages whatsoever from LUNIT (e.g. when -C subroutine READERME is to be used) -C 'QUIET' = LUNIT is ignored, this is an indicator -C that the value for IPRT in COMMON block -C /QUIET/ is being reset (see LUNDX) -C 'FIRST' = calls bfrini and wrdlen as a prelude to user -c resetting of bufrlib parameters such as -c missing value or output block type -C LUNDX - INTEGER: IF IO IS NOT 'QUIET': -C FORTRAN logical unit number containing -C dictionary table information to be used in -C reading/writing from/to LUNIT (depending -C on the case); may be set equal to LUNIT if -C dictionary table information is already -C embedded in LUNIT -C IF IO IS 'QUIET': -C Indicator for degree of printout: -C -1 = NO printout except for ABORT -C messages -C 0 = LIMITED printout (default) -C 1 = ALL warning messages are printed -C out -C 2 = ALL warning AND informational -C messages are printed out -C (Note: this does not change until OPENBF -C is again called with IO equal to -C 'QUIET') -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BFRINI BORT DXINIT ERRWRT -C POSAPX READDX STATUS WRDLEN -C WRITDX WTSTAT OPENRB OPENWB -C OPENAB -C THIS ROUTINE IS CALLED BY: COPYBF GETBMISS MESGBC MESGBF -C RDMGSB UFBINX UFBMEM UFBMEX -C UFBTAB SETBMISS SETBLOCK -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /STBFR / IOLUN(NFILES),IOMSG(NFILES) - COMMON /NULBFR/ NULL(NFILES) - COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) - COMMON /LUSHR/ LUS(NFILES) - COMMON /STCODE/ ISCODES(NFILES) - COMMON /QUIET / IPRT - - CHARACTER*(*) IO - CHARACTER*255 filename,fileacc - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*28 CPRINT(0:3) - CHARACTER*8 TAMNEM - CHARACTER*1 BSTR(4) - - DATA IFIRST/0/ - DATA CPRINT/ - . ' (only ABORTs) ', - . ' (limited - default) ', - . ' (all warnings) ', - . ' (all warning+informational)'/ - - SAVE IFIRST - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C If this is the first call to this subroutine, initialize -C IPRT in /QUIET/ as 0 (limited printout - except for abort -C messages) - - IF(IFIRST.EQ.0) IPRT = 0 - - IF(IO.EQ.'QUIET') THEN -c .... override previous IPRT value (printout indicator) - IF(LUNDX.LT.-1) LUNDX = -1 - IF(LUNDX.GT. 2) LUNDX = 2 - IF(LUNDX.GE.0) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,A,I3,A)' ) - . 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR '// - . 'CHNGED FROM',IPRT,CPRINT(IPRT+1),' TO',LUNDX,CPRINT(LUNDX+1) - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IPRT = LUNDX - ENDIF - - IF(IFIRST.EQ.0) THEN - -C If this is the first call to this subroutine, then call WRDLEN -C to figure out some important information about the local -C machine and call BFRINI to initialize some global variables. - -C NOTE: WRDLEN must be called prior to calling BFRINI! - - CALL WRDLEN - CALL BFRINI - IFIRST = 1 - ENDIF - - IF(IO.EQ.'FIRST') GOTO 100 - IF(IO.EQ.'QUIET') GOTO 100 - -C SEE IF A FILE CAN BE OPENED -C --------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(LUN.EQ.0) GOTO 900 - IF(IL .NE.0) GOTO 901 - NULL(LUN) = 0 - ISC3(LUN) = 0 - ISCODES(LUN) = 0 - LUS(LUN) = 0 - -C USE INQUIRE TO OBTAIN THE FILENAME ASSOCIATED WITH UNIT LUNIT -C ------------------------------------------------------------- - - IF (IO.NE.'NUL' .AND. IO.NE.'INUL') THEN - inquire(lunit,access=fileacc) - if(fileacc=='UNDEFINED') open(lunit) - inquire(lunit,name=filename) - filename=trim(filename)//char(0) - ENDIF - -C SET INITIAL OPEN DEFAULTS (CLEAR OUT A MSG CONTROL WORD PARTITION) -C ------------------------------------------------------------------ - - NMSG (LUN) = 0 - NSUB (LUN) = 0 - MSUB (LUN) = 0 - INODE(LUN) = 0 - IDATE(LUN) = 0 - -C DECIDE HOW TO OPEN THE FILE AND SETUP THE DICTIONARY -C ---------------------------------------------------- - - IF(IO.EQ.'IN') THEN - call openrb(lun,filename) - CALL WTSTAT(LUNIT,LUN,-1,0) - CALL READDX(LUNIT,LUN,LUNDX) - ELSE IF(IO.EQ.'INUL') THEN - CALL WTSTAT(LUNIT,LUN,-1,0) - IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) - NULL(LUN) = 1 - ELSE IF(IO.EQ.'NUL') THEN - CALL WTSTAT(LUNIT,LUN, 1,0) - IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) - NULL(LUN) = 1 - ELSE IF(IO.EQ.'INX') THEN - call openrb(lun,filename) - CALL WTSTAT(LUNIT,LUN,-1,0) - NULL(LUN) = 1 - ELSE IF(IO.EQ.'OUX') THEN - call openwb(lun,filename) - CALL WTSTAT(LUNIT,LUN, 1,0) - ELSE IF(IO.EQ.'SEC3') THEN - call openrb(lun,filename) - CALL WTSTAT(LUNIT,LUN,-1,0) - ISC3(LUN) = 1 - ELSE IF(IO.EQ.'OUT') THEN - call openwb(lun,filename) - CALL WTSTAT(LUNIT,LUN, 1,0) - CALL WRITDX(LUNIT,LUN,LUNDX) - ELSE IF(IO.EQ.'NODX') THEN - call openwb(lun,filename) - CALL WTSTAT(LUNIT,LUN, 1,0) - CALL READDX(LUNIT,LUN,LUNDX) - ELSE IF(IO.EQ.'APN' .OR. IO.EQ.'APX') THEN - call openab(lun,filename) - CALL WTSTAT(LUNIT,LUN, 1,0) - IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) - CALL POSAPX(LUNIT) - ELSE - GOTO 904 - ENDIF - - GOTO 100 - -C FILE OPENED FOR INPUT IS EMPTY - LET READMG OR READERME GIVE -C THE BAD NEWS LATER - -200 REWIND LUNIT - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) - . 'BUFRLIB: OPENBF - INPUT BUFR FILE IN UNIT ', LUNIT, - . ' IS EMPTY' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - CALL WTSTAT(LUNIT,LUN,-1,0) - -C INITIALIZE THE DICTIONARY TABLE PARTITION -C ----------------------------------------- - - CALL DXINIT(LUN,0) - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3,'// - . '" BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') - . NFILES,LUNIT - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT"'// - . ',I5," IS ALREADY OPEN")') LUNIT - CALL BORT(BORT_STR) -904 CALL BORT('BUFRLIB: OPENBF - SECOND (INPUT) ARGUMENT MUST BE'// - . ' "IN", "OUT", "NODX", "NUL", "APN", "APX", "SEC3"'// - . ' OR "QUIET"') - END diff --git a/src/bufr/openbt.f b/src/bufr/openbt.f deleted file mode 100644 index d0a377ed8b..0000000000 --- a/src/bufr/openbt.f +++ /dev/null @@ -1,73 +0,0 @@ - SUBROUTINE OPENBT(LUNDX,MTYP) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: OPENBT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 -C -C ABSTRACT: THIS IS A DUMMY SUBROUTINE WHICH ALWAYS RETURNS LUNDX = 0. -C OPENBT MUST BE PRESENT BECAUSE IT IS CALLED BY BUFR ARCHIVE LIBRARY -C SUBROUTINE CKTABA AS A LAST RESORT TO TRY AND FIND AN EXTERNAL -C USER-SUPPLIED BUFR DICTIONARY TABLE FILE IN CHARACTER FORMAT FROM -C WHICH A TABLE A MNEMONIC CAN BE LOCATED. IF THE APPLICATION -C PROGRAM DOES NOT HAVE AN IN-LINE VERSION OF OPENBT (OVERRIDING THIS -C ONE), THEN THE RETURNED LUNDX = 0 WILL RESULT IN CKTABA RETURNING -C WITHOUT FINDING A TABLE A MNEMONIC BECAUSE THERE IS NO LINK TO ANY -C EXTERNAL BUFR TABLES. NORMALLY, IT IS EXPECTED THAT AN IN-LINE -C VERSION OF THIS SUBROUTINE WILL ACTUALLY FIND THE APPROPRIATE -C EXTERNAL BUFR TABLE. -C -C PROGRAM HISTORY LOG: -C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); ADDED -C MORE COMPLETE DIAGNOSTIC INFO WHEN UNUSUAL -C THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL OPENBT (LUNDX, MTYP) -C INPUT ARGUMENT LIST: -C MTYP - INTEGER: DUMMY {IN AN APPLICATION PROGRAM (IN-LINE) -C THIS WOULD BE THE BUFR MESSAGE TYPE} -C -C OUTPUT ARGUMENT LIST: -C LUNDX - INTEGER: DUMMY, ALWAYS RETURNED AS ZERO {IN AN -C APPLICATION PROGRAM (IN-LINE) THIS WOULD BE THE -C FORTRAN LOGICAL UNIT NUMBER CONNECTED TO THE FILE -C CONTAINING THE EXTERNAL BUFR TABLE} -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT -C THIS ROUTINE (IN BUFR -C ARCHIVE LIBRARY): Called by CKTABA only to allow the -C BUFR ARCHIVE LIBRARY to compile, CKTABA -C and any application programs should -C always call a version of OPENBT in-line -C in the application program. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /QUIET / IPRT - - CHARACTER*128 ERRSTR - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE'// - . ' CALLED BY CKTABA OR APPL. PGM; OPENBT SHOULD BE INCL.'// - . ' IN-LINE IN APPL. PGM' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - LUNDX = 0 - - RETURN - END diff --git a/src/bufr/openmb.f b/src/bufr/openmb.f deleted file mode 100644 index 68c9382ee3..0000000000 --- a/src/bufr/openmb.f +++ /dev/null @@ -1,111 +0,0 @@ - SUBROUTINE OPENMB(LUNIT,SUBSET,JDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: OPENMB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE OPENS AND INITIALIZES A NEW BUFR MESSAGE -C WITHIN MEMORY. IT SHOULD ONLY BE CALLED WHEN LOGICAL UNIT LUNIT -C HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT IS SIMILAR TO BUFR -C ARCHIVE LIBRARY SUBROUTINE OPENMG, HOWEVER UNLIKE OPENMG, IT WILL -C NOT OPEN A NEW MESSAGE IF THERE IS ALREADY A BUFR MESSAGE OPEN -C WITHIN MEMORY FOR THIS LUNIT WHICH HAS THE SAME SUBSET AND JDATE -C VALUES (IN WHICH CASE IT DOES NOTHING AND RETURNS TO THE CALLING -C ROUTINE/PROGRAM). OTHERWISE, IF THERE IS ALREADY A BUFR MESSAGE -C OPEN WITHIN MEMORY FOR THIS LUNIT BUT WHICH HAS A DIFFERENT SUBSET -C OR JDATE VALUE, THEN THAT MESSAGE WILL BE CLOSED AND FLUSHED TO -C LUNIT BEFORE OPENING THE NEW ONE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL OPENMB (LUNIT, SUBSET, JDATE) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C SUBSET - CHARACTER*(*): TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING OPENED -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING OPENED, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CLOSMG I4DY MSGINI -C NEMTBA STATUS USRTPL WTSTAT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - - CHARACTER*(*) SUBSET - LOGICAL OPEN - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - -C GET SOME SUBSET PARTICULARS -C --------------------------- - -c .... Given SUBSET, returns MTYP,MSTB,INOD - CALL NEMTBA(LUN,SUBSET,MTYP,MSTB,INOD) - OPEN = IM.EQ.0.OR.INOD.NE.INODE(LUN).OR.I4DY(JDATE).NE.IDATE(LUN) - -C MAYBE(?) OPEN A NEW OR DIFFERENT TYPE OF MESSAGE -C ------------------------------------------------ - - IF(OPEN) THEN - CALL CLOSMG(LUNIT) - CALL WTSTAT(LUNIT,LUN,IL, 1) -c .... Set pos. index for new Tbl A mnem. - INODE(LUN) = INOD -c .... Set date for new message - IDATE(LUN) = I4DY(JDATE) - -C INITIALIZE THE OPEN MESSAGE -C --------------------------- - - CALL MSGINI(LUN) - CALL USRTPL(LUN,1,1) - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') - END diff --git a/src/bufr/openmg.f b/src/bufr/openmg.f deleted file mode 100644 index f585cff73e..0000000000 --- a/src/bufr/openmg.f +++ /dev/null @@ -1,100 +0,0 @@ - SUBROUTINE OPENMG(LUNIT,SUBSET,JDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: OPENMG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE OPENS AND INITIALIZES A NEW BUFR MESSAGE -C WITHIN MEMORY. IT SHOULD ONLY BE CALLED WHEN LOGICAL UNIT LUNIT -C HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT IS SIMILAR TO BUFR -C ARCHIVE LIBRARY SUBROUTINE OPENMB, HOWEVER UNLIKE OPENMB, IT WILL -C ALWAYS OPEN A NEW MESSAGE REGARDLESS OF THE VALUES OF SUBSET AND -C JDATE. IF THERE IS ALREADY A BUFR MESSAGE OPEN WITHIN MEMORY FOR -C THIS LUNIT, THEN THAT MESSAGE WILL BE CLOSED AND FLUSHED TO LUNIT -C BEFORE OPENING THE NEW ONE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL OPENMG (LUNIT, SUBSET, JDATE) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C SUBSET - CHARACTER*(*): TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING OPENED -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING OPENED, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CLOSMG I4DY MSGINI -C NEMTBA STATUS USRTPL WTSTAT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - - CHARACTER*(*) SUBSET - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.NE.0) CALL CLOSMG(LUNIT) - CALL WTSTAT(LUNIT,LUN,IL, 1) - -C GET SOME SUBSET PARTICULARS -C --------------------------- - -c .... Given SUBSET, returns MTYP,MSTB,INOD - CALL NEMTBA(LUN,SUBSET,MTYP,MSTB,INOD) -c .... Set pos. index for new Tbl A mnem. - INODE(LUN) = INOD -c .... Set date for new message - IDATE(LUN) = I4DY(JDATE) - -C INITIALIZE THE OPEN MESSAGE -C --------------------------- - - CALL MSGINI(LUN) - CALL USRTPL(LUN,1,1) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') - END diff --git a/src/bufr/pad.f b/src/bufr/pad.f deleted file mode 100644 index c079d2421b..0000000000 --- a/src/bufr/pad.f +++ /dev/null @@ -1,92 +0,0 @@ - SUBROUTINE PAD(IBAY,IBIT,IBYT,IPADB) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PAD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE FIRST PACKS THE VALUE FOR THE NUMBER OF -C BITS BEING "PADDED" (WE'LL GET TO THAT LATER), STARTING WITH BIT -C IBIT+1 AND USING EIGHT BITS IN THE PACKED ARRAY IBAY (WHICH -C REPRESENTS A SUBSET PACKED INTO IBIT BITS). THEN, STARTING WITH -C IBIT+9, IT PACKS ZEROES (I.E., "PADS") TO THE SPECIFIED BIT -C BOUNDARY (IPADB). (NOTE: IT'S THE NUMBER OF BITS PADDED HERE THAT -C WAS PACKED IN BITS IBIT+1 THROUGH IBIT+8 - THIS IS ACTUALLY A -C DELAYED REPLICATION FACTOR). IPADB MUST BE A MULTIPLE OF EIGHT AND -C REPRESENTS THE BIT BOUNDARY ON WHICH THE PACKED SUBSET IN IBAY -C SHOULD END AFTER PADDING. FOR EXAMPLE, IF IPABD IS "8", THEN THE -C NUMBER OF BITS IN IBAY ACTUALLY CONSUMED BY PACKED DATA (INCLUDING -C THE PADDING) WILL BE A MULTIPLE OF EIGHT. IF IPADB IS "16", IT -C WILL BE A MULTIPLE OF SIXTEEN. IN EITHER (OR ANY) CASE, THIS -C ENSURES THAT THE PACKED SUBSET WILL ALWAYS END ON A FULL BYTE -C BOUNDARY. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: CALL PAD (IBAY, IBIT, IBYT, IPADB) -C INPUT ARGUMENT LIST: -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET PADDED -C IBIT - INTEGER: BIT POINTER WITHIN IBAY TO START PADDING FROM -C IPADB - INTEGER: BIT BOUNDARY TO PAD TO (MUST BE A MULTIPLE OF -C 8) -C -C OUTPUT ARGUMENT LIST: -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW PADDED -C IBIT - INTEGER: NUMBER OF BITS WITHIN IBAY CONTAINING PACKED -C DATA (INCLUDING PADDING, MUST BE A MULTIPLE OF 8) -C IBYT - INTEGER: NUMBER OF BYTES WITHIN IBAY CONTAINING PACKED -C DATA (INCLUDING PADDING) (I.E., IBIT/8) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT PKB -C THIS ROUTINE IS CALLED BY: MSGUPD -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*128 BORT_STR - DIMENSION IBAY(*) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C PAD THE SUBSET TO AN IPADB BIT BOUNDARY -C ---------------------------------------- - - IPAD = IPADB - MOD(IBIT+8,IPADB) -c .... First pack the # of bits being padded (this is a delayed -c .... replication factor) - CALL PKB(IPAD,8,IBAY,IBIT) -c .... Now pad with zeroes to the byte boundary - CALL PKB(0,IPAD,IBAY,IBIT) - IBYT = IBIT/8 - - IF(MOD(IBIT,IPADB).NE.0) GOTO 900 - IF(MOD(IBIT,8 ).NE.0) GOTO 901 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: PAD - THE INPUT BIT BOUNDARY TO PAD '// - . 'TO (",I8,") IS NOT A MULTIPLE OF 8")') IPADB - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: PAD - THE NUMBER OF BITS IN A PACKED'// - . ' SUBSET AFTER PADDING (",I8,") IS NOT A MULTIPLE OF 8")') IBIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/padmsg.f b/src/bufr/padmsg.f deleted file mode 100644 index 8db5b59a14..0000000000 --- a/src/bufr/padmsg.f +++ /dev/null @@ -1,63 +0,0 @@ - SUBROUTINE PADMSG(MESG,LMESG,NPBYT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PADMSG -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE PADS A BUFR MESSAGE WITH ZEROED-OUT BYTES -C FROM THE END OF THE MESSAGE UP TO THE NEXT 8-BYTE BOUNDARY. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL PADMSG (MESG, LMESG, NPBYT ) -C INPUT ARGUMENT LIST: -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE -C LMESG - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MESG; -C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT -C OVERFLOW THE MESG ARRAY -C -C OUTPUT ARGUMENT LIST: -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE WITH NPBYT ZEROED-OUT BYTES APPENDED TO THE END -C NPBYT - INTEGER: NUMBER OF ZEROED-OUT BYTES APPENDED TO MESG -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IUPBS01 NMWRD PKB -C THIS ROUTINE IS CALLED BY: MSGWRT -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION MESG(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Make sure that the array is big enough to hold the additional -C byte padding that will be appended to the end of the message. - - NMW = NMWRD(MESG) - IF(NMW.GT.LMESG) GOTO 900 - -C Pad from the end of the message up to the next 8-byte boundary. - - NMB = IUPBS01(MESG,'LENM') - IBIT = NMB*8 - NPBYT = ( NMW * NBYTW ) - NMB - DO I = 1, NPBYT - CALL PKB(0,8,MESG,IBIT) - ENDDO - - RETURN -900 CALL BORT('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE '// - . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END diff --git a/src/bufr/parstr.f b/src/bufr/parstr.f deleted file mode 100644 index 65fb12ca6f..0000000000 --- a/src/bufr/parstr.f +++ /dev/null @@ -1,98 +0,0 @@ - SUBROUTINE PARSTR(STR,TAGS,MTAG,NTAG,SEP,LIMIT80) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PARSTR -C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE -C SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS. THE SEPARATOR FOR THE -C SUBSTRINGS IS SPECIFIED DURING INPUT, AND MULTIPLE ADJACENT -C OCCURRENCES OF THIS CHARACTER WILL BE TREATED AS A SINGLE -C OCCURRENCE WHEN THE STRING IS ACTUALLY PARSED. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- BASED UPON SUBROUTINE PARSEQ -C -C USAGE: CALL PARSTR (STR, TAGS, MTAG, NTAG, SEP, LIMIT80) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING -C MTAG - INTEGER: MAXIMUM NUMBER OF SUBSTRINGS TO BE PARSED -C FROM STRING -C SEP - CHARACTER*1: SEPARATOR CHARACTER FOR SUBSTRINGS -C LIMIT80 - LOGICAL: .TRUE. IF AN ABORT SHOULD OCCUR WHEN STR IS -C LONGER THAN 80 CHARACTERS; INCLUDED FOR HISTORICAL -C CONSISTENCY WITH OLD SUBROUTINE PARSEQ -C -C OUTPUT ARGUMENT LIST: -C TAGS - CHARACTER*(*): MTAG-WORD ARRAY OF SUBSTRINGS (FIRST -C NTAG WORDS FILLED) -C NTAG - INTEGER: NUMBER OF SUBSTRINGS RETURNED -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 -C THIS ROUTINE IS CALLED BY: GETNTBE GETTAGPR GETTBH GETVALNB -C PARUSR READLC SEQSDX SNTBBE -C UFBSEQ UFBTAB UFBTAM WRITLC -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR,TAGS(MTAG) - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*1 SEP - LOGICAL SUBSTR,LIMIT80 - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LSTR = LEN(STR) - LTAG = LEN(TAGS(1)) - IF( LIMIT80 .AND. (LSTR.GT.80) ) GOTO 900 - NTAG = 0 - NCHR = 0 - SUBSTR = .FALSE. - - DO I=1,LSTR - - IF( .NOT.SUBSTR .AND. (STR(I:I).NE.SEP) ) THEN - NTAG = NTAG+1 - IF(NTAG.GT.MTAG) GOTO 901 - TAGS(NTAG) = ' ' - ENDIF - - IF( SUBSTR .AND. (STR(I:I).EQ.SEP) ) NCHR = 0 - SUBSTR = STR(I:I).NE.SEP - - IF(SUBSTR) THEN - NCHR = NCHR+1 - IF(NCHR.GT.LTAG) GOTO 902 - TAGS(NTAG)(NCHR:NCHR) = STR(I:I) - ENDIF - - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") HAS ")') - . STR - WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') - . LSTR - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") '// - . 'CONTAINS",I4)') STR,NTAG - WRITE(BORT_STR2,'(18X,"SUBSTRINGS, EXCEEDING THE LIMIT {",I4,'// - . '" - THIRD (INPUT) ARGUMENT}")') MTAG - CALL BORT2(BORT_STR1,BORT_STR2) -902 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") ")') STR - WRITE(BORT_STR2,'(18X,"CONTAINS A PARSED SUBSTRING WITH LENGTH '// - . 'EXCEEDING THE MAXIMUM OF",I4," CHARACTERS")') LTAG - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/parusr.f b/src/bufr/parusr.f deleted file mode 100644 index 1d4f78d460..0000000000 --- a/src/bufr/parusr.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE PARUSR(STR,LUN,I1,IO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PARUSR -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS -C (NODES) FROM A USER-SPECIFIED CHARACTER STRING, AND SEPARATES THEM -C INTO STORE AND CONDITION NODES. INFORMATION ABOUT THE STRING -C "PIECES" (I.E., THE MNEMONICS) IS STORED IN ARRAYS IN COMMON BLOCK -C /USRSTR/. CONDITION NODES ARE SORTED IN THE ORDER EXPECTED IN THE -C INTERNAL JUMP/LINK TABLES AND SEVERAL CHECKS ARE PERFORMED ON THE -C NODES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; IMPROVED MACHINE -C PORTABILITY -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY; CHANGED CALL FROM -C BORT TO BORT2; RESPONDED TO CHANGE IN -C PARUTG (WHICH THIS ROUTINE CALLS) TO NO -C LONGER EXPECT AN ALTERNATE RETURN TO A -C STATEMENT NUMBER IN THIS ROUTINE WHICH -C CALLED BORT (BORT IS NOW CALLED IN PARUTG) -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC -C -C USAGE: CALL PARUSR (STR, LUN, I1, IO) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER -C OF BLANK-SEPARATED MNEMONICS IN STR -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUN: -C 0 = input file -C 1 = output file -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 LSTJPB PARSTR PARUTG -C THIS ROUTINE IS CALLED BY: STRING -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /ACMODE/ IAC - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*80 UST - CHARACTER*20 UTG(30) - LOGICAL BUMP - - DATA MAXUSR /30/ - DATA MAXNOD /20/ - DATA MAXCON /10/ - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - UST = STR - IF(LEN(STR).GT.80) GOTO 900 - - NCON = 0 - NNOD = 0 - -C PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS) -C ----------------------------------------------- - - CALL PARSTR(UST,UTG,MAXUSR,NTOT,' ',.TRUE.) - - DO N=1,NTOT - -C DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE -C --------------------------------------------------------- - - CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL) - IF(KON.NE.0) THEN -c .... it is a condition node - NCON = NCON+1 - IF(NCON.GT.MAXCON) GOTO 901 - NODC(NCON) = NOD - KONS(NCON) = KON - IVLS(NCON) = NINT(VAL) - ELSE -c .... it is a store node - NNOD = NNOD+1 - IF(NNOD.GT.MAXNOD) GOTO 902 - NODS(NNOD) = NOD - ENDIF - ENDDO - -C SORT CONDITION NODES IN JUMP/LINK TABLE ORDER -C --------------------------------------------- - - DO I=1,NCON - DO J=I+1,NCON - IF(NODC(I).GT.NODC(J)) THEN - NOD = NODC(I) - NODC(I) = NODC(J) - NODC(J) = NOD - - KON = KONS(I) - KONS(I) = KONS(J) - KONS(J) = KON - - VAL = IVLS(I) - IVLS(I) = IVLS(J) - IVLS(J) = VAL - ENDIF - ENDDO - ENDDO - -C CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES -C ---------------------------------------------------------------- - - BUMP = .FALSE. - - DO N=1,NCON - IF(KONS(N).EQ.5) THEN - IF(IO.EQ.0) GOTO 903 - IF(N.NE.NCON) GOTO 904 - BUMP = .TRUE. - ENDIF - ENDDO - -C CHECK STORE NODE COUNT AND ALIGNMENT -C ------------------------------------ - - IF(.NOT.BUMP .AND. NNOD.EQ.0) GOTO 905 - IF(NNOD.GT.I1) GOTO 906 - - IRPC = -1 - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - IF(IRPC.LT.0) IRPC = LSTJPB(NODS(I),LUN,'RPC') - IF(IRPC.NE.LSTJPB(NODS(I),LUN,'RPC').AND.IAC.EQ.0) GOTO 907 - ENDIF - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")') - . STR - WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') - . LEN(STR) - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION '// - . 'NODES IN INPUT STRING")') - WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') - . STR,MAXCON - CALL BORT2(BORT_STR1,BORT_STR2) -902 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '// - . 'IN INPUT STRING")') - WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') - . STR,MAXNOD - CALL BORT2(BORT_STR1,BORT_STR2) -903 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '// - . 'STRING ",A)') STR - WRITE(BORT_STR2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '// - . 'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")') - CALL BORT2(BORT_STR1,BORT_STR2) -904 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// - . 'CONTAINS")') STR - WRITE(BORT_STR2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '// - . 'NODE - THE BUMP MUST BE ON THE INNER NODE")') - CALL BORT2(BORT_STR1,BORT_STR2) -905 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")') - . STR - WRITE(BORT_STR2,'(18X,"NO STORE NODES")') - CALL BORT2(BORT_STR1,BORT_STR2) -906 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') STR - WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// - . 'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') NNOD,I1 - CALL BORT2(BORT_STR1,BORT_STR2) -907 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// - . 'CONTAINS")') STR - WRITE(BORT_STR2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'// - . ' THAN ONE REPLICATION GROUP")') - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/parutg.f b/src/bufr/parutg.f deleted file mode 100644 index 27a5568dbb..0000000000 --- a/src/bufr/parutg.f +++ /dev/null @@ -1,277 +0,0 @@ - SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PARUTG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC) -C (UTG) THAT REPRESENTS A VALUE EITHER BEING DECODED FROM A BUFR FILE -C (IF IT IS BEING READ) OR ENCODED INTO A BUFR FILE (IF IT IS BEING -C WRITTEN). THIS SUBROUTINE FIRST CHECKS TO SEE IF THE TAG CONTAINS -C A CONDITION CHARACTER ('=', '!', '<', '>', '^' OR '#'). IF IT DOES -C NOT, NOTHING HAPPENS AT THIS POINT. IF IT DOES, THEN THE TYPE OF -C CONDITION CHARACTER IS NOTED AND THE TAG IS STRIPPED OF ALL -C CHARACTERS AT AND BEYOND THE CONDITION CHARACTER. IN EITHER EVENT, -C THE RESULTANT TAG IS CHECKED AGAINST THOSE IN THE INTERNAL JUMP/ -C LINK SUBSET TABLE (IN COMMON BLOCK /TABLES/). IF FOUND, THE NODE -C ASSOCIATED WITH THE TAG IS RETURNED (AND IT IS EITHER A "CONDITION" -C NODE OR A "STORE" NODE DEPENDING OF THE PRESENCE OR ABSENCE OF A -C CONDITION CHARACTER IN UTG). OTHERWISE THE NODE IS RETURNED AS -C ZERO. IF THE TAG REPRESENTS A CONDITION NODE, THEN THE CONDITION -C VALUE (NUMERIC CHARACTERS BEYOND THE CONDITION CHARACTER IN THE -C USER-SPECIFIED TAG INPUT HERE) IS RETURNED. -C -C AS AN EXAMPLE OF CONDITION CHARACTER USAGE, CONSIDER THE FOLLOWING -C EXAMPLE OF A CALL TO UFBINT: -C -C REAL*8 USR(4,50) -C .... -C .... -C CALL UFBINT(LUNIN,USR,4,50,IRET,'PRLC<50000 TMDB WDIR WSPD') -C -C ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING), -C THEN THE USR ARRAY NOW CONTAINS IRET LEVELS OF DATA (UP TO A MAXIMUM -C OF 50!) WHERE THE VALUE OF PRLC IS/WAS LESS THAN 50000, ALONG WITH -C THE CORRESPONDING VALUES FOR TMDB, WDIR AND WSPD AT THOSE LEVELS. -C -C AS ANOTHER EXAMPLE, CONSIDER THE FOLLOWING EXAMPLE OF A CALL TO -C READLC FOR A LONG CHARACTER STRING: -C -C CHARACTER*200 LCHR -C .... -C .... -C CALL READLC(LUNIN,LCHR,'NUMID#3') -C -C ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING), -C THEN THE LCHR STRING NOW CONTAINS THE VALUE CORRESPONDING TO THE -C THIRD OCCURRENCE OF NUMID WITHIN THE CURRENT SUBSET. -C -C VALID CONDITION CODES INCLUDE: -C '<' - LESS THAN -C '>' - GREATER THAN -C '=' - EQUAL TO -C '!' - NOT EQUAL TO -C '#' - ORDINAL IDENTIFIER FOR A PARTICULAR OCCURRENCE OF A LONG -C CHARACTER STRING -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY; -C CHANGED CALL FROM BORT TO BORT2 IN SOME -C CASES; REPLACED PREVIOUS "RETURN 1" -C STATEMENT WITH "GOTO 900" (AND CALL TO -C BORT) SINCE THE ONLY ROUTINE THAT CALLS -C THIS ROUTINE, PARUSR, USED THIS ALTERNATE -C RETURN TO GO TO A STATEMENT WHICH CALLED -C BORT -C 2005-04-22 J. ATOR -- HANDLED SITUATION WHERE INPUT TAG CONTAINS -C 1-BIT DELAYED REPLICATION, AND IMPROVED -C DOCUMENTATION -C 2009-03-23 J. ATOR -- ADDED '#' CONDITION CODE -C -C USAGE: CALL PARUTG (LUN, IO, UTG, NOD, KON, VAL) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUN: -C 0 = input file -C 1 = output file -C UTG CHARACTER*(*): USER-SUPPLIED TAG REPRESENTING A VALUE TO -C BE ENCODED/DECODED TO/FROM BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C NOD - INTEGER: POSITIONAL INDEX IN INTERNAL JUMP/LINK SUBSET -C TABLE FOR TAG -C 0 = tag not found in table -C KON - INTEGER: INDICATOR FOR TYPE OF CONDITION CHARACTER -C FOUND IN UTG: -C 0 = no condition character found (NOD is a store -C node) -C 1 = character '=' found -C 2 = character '!' found -C 3 = character '<' found -C 4 = character '>' found -C 5 = character '^' found -C 6 = character '#' found -C (1-6 means NOD is a condition node, and -C specifically 5 is a "bump" node) -C VAL - REAL: CONDITION VALUE ASSOCIATED WITH CONDITION -C CHARACTER FOUND IN UTG -C 0 = UTG does not have a condition character -C -C REMARKS: -C THIS ROUTINE CALLS: BORT BORT2 STRNUM -C THIS ROUTINE IS CALLED BY: PARUSR READLC WRITLC -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /UTGPRM/ PICKY - - CHARACTER*(*) UTG - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*20 ATAG - CHARACTER*10 TAG - CHARACTER*3 TYP,ATYP,BTYP - CHARACTER*1 COND(6) - DIMENSION BTYP(8),IOK(8) - LOGICAL PICKY - - DATA NCHK / 8/ - DATA BTYP /'SUB','SEQ','REP','RPC','RPS','DRB','DRP','DRS'/ - DATA IOK / -1 , -1 , -1 , -1 , -1 , 0 , 0 , 0 / - -C---------------------------------------------------------------------- -C For now, set PICKY (see below) to always be .FALSE. - PICKY = .FALSE. - COND(1) = '=' - COND(2) = '!' - COND(3) = '<' - COND(4) = '>' - COND(5) = '^' - COND(6) = '#' - NCOND = 6 -C---------------------------------------------------------------------- - - ATAG = ' ' - ATYP = ' ' - KON = 0 - NOD = 0 - VAL = 0 - LTG = MIN(20,LEN(UTG)) - -C PARSE UTG, SAVING INTO ATAG ONLY CHARACTERS PRIOR TO CONDITION CHAR. -C -------------------------------------------------------------------- - -C But first, take care of the special case where UTG denotes the -C short (i.e. 1-bit) delayed replication of a Table D mnemonic. -C This will prevent confusion later on since '<' and '>' are each -C also valid as condition characters. - - IF((UTG(1:1).EQ.'<').AND.(INDEX(UTG(3:),'>').NE.0)) THEN - ATAG = UTG - GO TO 1 - ENDIF - - DO I=1,LTG - IF(UTG(I:I).EQ.' ') GOTO 1 - DO J=1,NCOND - IF(UTG(I:I).EQ.COND(J)) THEN - KON = J - ICV = I+1 - GOTO 1 - ENDIF - ENDDO - ATAG(I:I) = UTG(I:I) - ENDDO - -C FIND THE NODE ASSOCIATED WITH ATAG IN THE SUBSET TABLE -C ------------------------------------------------------ - -1 INOD = INODE(LUN) - DO NOD=INOD,ISC(INOD) - IF(ATAG.EQ.TAG(NOD)) GOTO 2 - ENDDO - -C ATAG NOT FOUND IN SUBSET TABLE -C ------------------------------ - -C So what do we want to do? We could be "picky" and abort right -C here, or we could allow for the possibility that, e.g. a user -C application has been streamlined to always call UFBINT with the -C same STR, even though some of the mnemonics contained within that -C STR may not exist within the sequence definition of every -C possible type/subtype that is being written by the application. -C In such cases, by not being "picky", we could just allow BUFRLIB -C to subsequently (and quietly, if IPRT happened to be set to -1 -C in COMMON /QUIET/!) not actually store the value corresponding -C to such mnemonics, rather than loudly complaining and aborting. - - IF(KON.EQ.0 .AND. (IO.EQ.0.OR.ATAG.EQ.'NUL'.OR..NOT.PICKY)) THEN -C i.e. (if this tag does not contain any condition characters) -C .AND. -C ((either the file is open for input) .OR. -C (the tag consists of 'NUL') .OR. -C (we aren't being "picky")) - NOD = 0 - GOTO 100 - ELSE -C abort... - GOTO 900 - ENDIF - -C ATAG IS FOUND IN SUBSET TABLE, MAKE SURE IT HAS A VALID NODE TYPE -C ----------------------------------------------------------------- - -2 IF(KON.EQ.5) THEN -c .... Cond. char "^" must be assoc. with a delayed replication -c sequence (this is a "bump" node) (Note: This is obsolete but -c remains for "old" programs using the BUFR ARCHIVE LIBRARY) - IF(TYP(NOD-1).NE.'DRP' .AND. TYP(NOD-1).NE.'DRS') GOTO 901 - ELSEIF(KON.NE.6) THEN -C Allow reading (but not writing) of delayed replication factors. - ATYP = TYP(NOD) - DO I=1,NCHK - IF(ATYP.EQ.BTYP(I) .AND. IO.GT.IOK(I)) GOTO 902 - ENDDO - ENDIF - -C IF CONDITION NODE, GET CONDITION VALUE WHICH IS A NUMBER FOLLOWING IT -C --------------------------------------------------------------------- - - IF(KON.NE.0) THEN - CALL STRNUM(UTG(ICV:LTG),NUM) - IF(NUM.LT.0) GOTO 903 - VAL = NUM - ENDIF - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - TRYING TO WRITE A MNEMONIC'// - . ' (",A,") WHICH DOES NOT EXIST IN SUBSET TABLE")') ATAG - WRITE(BORT_STR2,'(18X,"(UPON INPUT, IT CONTAINED THE CONDITION '// - . 'CHARACTER ",A,")")') UTG(ICV-1:ICV-1) - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - BUMP NODE (MNEMONIC ",A,")'// - . ' MUST REFER TO A DELAYED REPLICATION SEQUENCE, HERE TYPE IS "'// - . ',A)') ATAG,TYP(NOD-1) - CALL BORT(BORT_STR1) -902 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - ILLEGAL NODE TYPE: ",A," '// - . 'FOR MNEMONIC ",A)') ATYP,ATAG - CALL BORT(BORT_STR1) -903 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - CONDITION VALUE IN '// - . 'MNEMONIC ",A," ILLEGAL BECAUSE ALL OTHER CHARACTERS IN '// - . 'MNEMONIC MUST BE NUMERIC")') UTG - CALL BORT(BORT_STR1) - END diff --git a/src/bufr/pkb.f b/src/bufr/pkb.f deleted file mode 100644 index 0cdc1c9850..0000000000 --- a/src/bufr/pkb.f +++ /dev/null @@ -1,87 +0,0 @@ - SUBROUTINE PKB(NVAL,NBITS,IBAY,IBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PKB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER VALUE (NVAL) INTO NBITS -C BITS OF AN INTEGER ARRAY (IBAY), STARTING WITH BIT (IBIT+1). ON -C OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS PACKED. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS -C IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C -C USAGE: CALL PKB (NVAL, NBITS, IBAY, IBIT) -C INPUT ARGUMENT LIST: -C NVAL - INTEGER: INTEGER TO BE PACKED -C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO PACK -C NVAL -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET CONTAINING -C PACKED NVAL -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER -C WHICH TO START PACKING -C -C OUTPUT ARGUMENT LIST: -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING -C PACKED NVAL -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT -C THAT WAS PACKED -C -C REMARKS: -C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE -C UPB. -C -C THIS ROUTINE CALLS: IREV -C THIS ROUTINE IS CALLED BY: ATRCPT CMSGINI CNVED4 CPYUPD -C DXMINI MSGINI MSGUPD MSGWRT -C MVB PAD PADMSG PKBS1 -C STNDRD WRCMPS WRDXTB WRTREE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION IBAY(*) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - NWD = IBIT/NBITW + 1 - NBT = MOD(IBIT,NBITW) - IVAL = NVAL - IF(ISHFT(IVAL,-NBITS).GT.0) IVAL = -1 - INT = ISHFT(IVAL,NBITW-NBITS) - INT = ISHFT(INT,-NBT) - MSK = ISHFT( -1,NBITW-NBITS) - MSK = ISHFT(MSK,-NBT) - IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT)) - IF(NBT+NBITS.GT.NBITW) THEN - -C There are less than NBITS bits remaining within the current -C word (i.e. array member) of IBAY, so store as many bits as -C will fit within the current word and then store the remaining -C bits within the next word. - - INT = ISHFT(IVAL,2*NBITW-(NBT+NBITS)) - MSK = ISHFT( -1,2*NBITW-(NBT+NBITS)) - IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT)) - ENDIF - - IBIT = IBIT + NBITS - - RETURN - END diff --git a/src/bufr/pkbs1.f b/src/bufr/pkbs1.f deleted file mode 100644 index 64ec92c73d..0000000000 --- a/src/bufr/pkbs1.f +++ /dev/null @@ -1,116 +0,0 @@ - SUBROUTINE PKBS1(IVAL,MBAY,S1MNEM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PKBS1 -C PRGMMR: J. ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE STORES A SPECIFIED INTEGER VALUE INTO A -C SPECIFIED LOCATION WITHIN SECTION 1 OF THE BUFR MESSAGE STORED IN -C ARRAY MBAY, OVERWRITING THE VALUE PREVIOUSLY STORED AT THAT -C LOCATION. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION -C 2, 3 OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") -C MUST BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE LOCATION -C WITHIN WHICH TO STORE THE VALUE IS SPECIFIED VIA THE MNEMONIC -C S1MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2006-04-14 D. KEYSER -- ADDED OPTIONS FOR 'MTYP', 'MSBT', 'YEAR', -C 'MNTH', 'DAYS', 'HOUR', 'YCEN' AND 'CENT' -C -C USAGE: PKBS1 (IVAL, MBAY, S1MNEM) -C INPUT ARGUMENT LIST: -C IVAL - INTEGER: VALUE TO BE STORED -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR MESSAGE PRIOR TO STORING IVAL -C S1MNEM - CHARACTER*(*): MNEMONIC SPECIFYING LOCATION WHERE IVAL -C IS TO BE STORED WITHIN SECTION 1 OF BUFR MESSAGE: -C 'BMT' = BUFR MASTER TABLE -C 'OGCE' = ORIGINATING CENTER -C 'GSES' = ORIGINATING SUBCENTER -C (NOTE: THIS VALUE IS STORED ONLY IN -C BUFR EDITION 3 OR 4 MESSAGES!) -C 'USN' = UPDATE SEQUENCE NUMBER -C 'MTYP' = DATA CATEGORY -C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) -C (NOTE: THIS VALUE IS STORED ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MSBT' = DATA SUBCATEGORY (LOCAL) -C 'MTV' = VERSION NUMBER OF MASTER TABLE -C 'MTVL' = VERSION NUMBER OF LOCAL TABLES -C 'YCEN' = YEAR OF CENTURY (1-100) -C (NOTE: THIS VALUE IS STORED ONLY IN -C BUFR EDITION 2 AND 3 MESSAGES!) -C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, -C 21 FOR YEARS 2001-2100) -C (NOTE: THIS VALUE IS STORED ONLY IN -C BUFR EDITION 2 AND 3 MESSAGES!) -C 'YEAR' = YEAR (4-DIGIT) -C (NOTE: THIS VALUE IS STORED ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MNTH' = MONTH -C 'DAYS' = DAY -C 'HOUR' = HOUR -C 'MINU' = MINUTE -C 'SECO' = SECOND -C (NOTE: THIS VALUE IS STORED ONLY IN -C BUFR EDITION 4 MESSAGES!) -C -C OUTPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE WITH IVAL NOW STORED AS REQUESTED -C -C REMARKS: -C THIS ROUTINE CALLS: BORT GETS1LOC IUPBS01 PKB -C THIS ROUTINE IS CALLED BY: MINIMG MSGWRT -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MBAY(*) - - CHARACTER*(*) S1MNEM - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Note that the following call to function IUPBS01 will ensure -C that subroutine WRDLEN has been called. - - IBEN = IUPBS01(MBAY,'BEN') - -C Determine where to store the value. - - CALL GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) - IF ( (IRET.EQ.0) .AND. - . ( (S1MNEM.EQ.'USN') .OR. (S1MNEM.EQ.'BMT') .OR. - . (S1MNEM.EQ.'OGCE') .OR. (S1MNEM.EQ.'GSES') .OR. - . (S1MNEM.EQ.'MTYP') .OR. (S1MNEM.EQ.'MSBTI') .OR. - . (S1MNEM.EQ.'MSBT') .OR. (S1MNEM.EQ.'MTV') .OR. - . (S1MNEM.EQ.'MTVL') .OR. (S1MNEM.EQ.'YCEN') .OR. - . (S1MNEM.EQ.'CENT') .OR. (S1MNEM.EQ.'YEAR') .OR. - . (S1MNEM.EQ.'MNTH') .OR. (S1MNEM.EQ.'DAYS') .OR. - . (S1MNEM.EQ.'HOUR') .OR. (S1MNEM.EQ.'MINU') .OR. - . (S1MNEM.EQ.'SECO') ) ) THEN - -C Store the value. - - IBIT = (IUPBS01(MBAY,'LEN0')+ISBYT-1)*8 - CALL PKB(IVAL,IWID,MBAY,IBIT) - ELSE - GOTO 900 - ENDIF - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: PKBS1 - CANNOT OVERWRITE LOCATION '// - . 'CORRESPONDING TO MNEMONIC (",A,") WITHIN BUFR EDITION '// - . '(",I1,")")') S1MNEM, IBEN - CALL BORT(BORT_STR) - END diff --git a/src/bufr/pkc.f b/src/bufr/pkc.f deleted file mode 100644 index 615894e47f..0000000000 --- a/src/bufr/pkc.f +++ /dev/null @@ -1,118 +0,0 @@ - SUBROUTINE PKC(CHR,NCHR,IBAY,IBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PKC -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER STRING (CHR) CONTAINING -C NCHR CHARACTERS INTO NCHR BYTES OF AN INTEGER ARRAY (IBAY), -C STARTING WITH BIT (IBIT+1). ON OUTPUT, IBIT IS UPDATED TO POINT TO -C THE LAST BIT THAT WAS PACKED. NOTE THAT THERE IS NO GUARANTEE THAT -C THE NCHR CHARACTERS WILL BE ALIGNED ON BYTE BOUNDARIES WHEN PACKED -C WITHIN IBAY. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS -C IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 -C 2004-08-18 J. ATOR -- MODIFIED TO BE COMPATIBLE WITH WRITLC -C -C USAGE: CALL PKC (CHR, NCHR, IBAY, IBIT) -C INPUT ARGUMENT LIST: -C CHR - CHARACTER*(*): CHARACTER STRING TO BE PACKED -C NCHR - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO PACK -C CHR (I.E., THE NUMBER OF CHARACTERS IN CHR) -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER -C WHICH TO START PACKING -C -C OUTPUT ARGUMENT LIST: -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING -C PACKED CHR -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT -C THAT WAS PACKED -C -C REMARKS: -C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE -C UPC. -C -C THIS ROUTINE CALLS: IPKM IREV IUPM -C THIS ROUTINE IS CALLED BY: CMSGINI DXMINI MSGINI MSGWRT -C STNDRD WRCMPS WRDXTB WRITLC -C WRTREE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*(*) CHR - CHARACTER*1 CVAL(8) - DIMENSION IBAY(*),IVAL(2) - EQUIVALENCE (CVAL,IVAL) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - LB = IORD(NBYTW) - -C LB now points to the "low-order" (i.e. least significant) byte -C within a machine word. - - IVAL(1) = 0 - NBIT = 8 - - DO I=1,NCHR - IF(I.LE.LEN(CHR)) THEN - CVAL(LB) = CHR(I:I) - ELSE - CVAL(LB) = ' ' - ENDIF - -C If the machine is EBCDIC, then translate character CVAL(LB) from -C EBCDIC to ASCII. - - IF(IASCII.EQ.0) CALL IPKM(CVAL(LB),1,IETOA(IUPM(CVAL(LB),8))) - - NWD = IBIT/NBITW + 1 - NBT = MOD(IBIT,NBITW) - INT = ISHFT(IVAL(1),NBITW-NBIT) - INT = ISHFT(INT,-NBT) - MSK = ISHFT( -1,NBITW-NBIT) - MSK = ISHFT(MSK,-NBT) - IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT)) - IF(NBT+NBIT.GT.NBITW) THEN - -C This character will not fit within the current word (i.e. -C array member) of IBAY, because there are less than 8 bits of -C space left. Store as many bits as will fit within the current -C word and then store the remaining bits within the next word. - - INT = ISHFT(IVAL(1),2*NBITW-(NBT+NBIT)) - MSK = ISHFT( -1,2*NBITW-(NBT+NBIT)) - IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT)) - ENDIF - IBIT = IBIT + NBIT - ENDDO - -C EXITS -C ----- - - RETURN - END diff --git a/src/bufr/pkftbv.f b/src/bufr/pkftbv.f deleted file mode 100644 index 3c53135345..0000000000 --- a/src/bufr/pkftbv.f +++ /dev/null @@ -1,50 +0,0 @@ - REAL*8 FUNCTION PKFTBV(NBITS,IBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PKFTBV -C PRGMMR: JATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS FUNCTION COMPUTES AND RETURNS THE VALUE EQUIVALENT -C TO THE SETTING OF BIT# IBIT WITHIN A FLAG TABLE OF NBITS BITS. -C IF THE COMPUTATION FAILS FOR ANY REASON, THEN THE VALUE BMISS -C (10E10) IS RETURNED. NOTE THAT THIS SUBROUTINE IS THE LOGICAL -C INVERSE OF BUFRLIB SUBROUTINE UPFTBV. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL VERSION -C -C USAGE: PKFTBV (NBITS,IBIT) -C INPUT ARGUMENT LIST: -C NBITS - INTEGER: NUMBER OF BITS IN FLAG TABLE -C IBIT - INTEGER: NUMBER OF BIT TO BE SET WITHIN FLAG TABLE -C -C OUTPUT ARGUMENT LIST: -C PKFTBV - REAL*8: VALUE EQUIVALENT TO THE SETTING OF BIT# IBIT -C WITHIN A FLAG TABLE OF NBITS BITS. -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF((NBITS.LE.0).OR.(IBIT.LE.0).OR.(IBIT.GT.NBITS)) THEN - PKFTBV = BMISS - ELSE - PKFTBV = (2.)**(NBITS-IBIT) - ENDIF - - RETURN - END diff --git a/src/bufr/pktdd.f b/src/bufr/pktdd.f deleted file mode 100644 index 3fb7aac846..0000000000 --- a/src/bufr/pktdd.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE PKTDD(ID,LUN,IDN,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PKTDD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE STORES INFORMATION ABOUT A "CHILD" -C MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (IN COMMON BLOCK -C /TABABD/) FOR A TABLE D SEQUENCE ("PARENT") MNEMONIC WHEN THE -C "CHILD" MNEMONIC IS CONTAINED WITHIN THE SEQUENCE REPRESENTED BY -C THE "PARENT" MNEMONIC (AS DETERMINED WITHIN BUFR ARCHIVE LIBRARY -C SUBROUTINE SEQSDX). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; ADDED MORE COMPLETE -C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL PKTDD (ID, LUN, IDN, IRET) -C INPUT ARGUMENT LIST: -C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN -C INTERNAL BUFR TABLE D ARRAY TABD(*,*) -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE -C CORRESPONDING TO CHILD MNEMONIC -C 0 = delete all information about all child -C mnemonics from within TABD(ID,LUN) -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS STORED THUS -C FAR (INCLUDING IDN) FOR THE PARENT MNEMONIC GIVEN BY -C TABD(ID,LUN) -C 0 = information was cleared from TABD(ID,LUN) -C because input IDN value was 0 -C -1 = bad counter value or maximum number of -C child mnemonics already stored for this -C parent mnemonic -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT IPKM IUPM -C THIS ROUTINE IS CALLED BY: DXINIT SEQSDX STBFDX STSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - COMMON /QUIET / IPRT - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*128 ERRSTR - CHARACTER*56 DXSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LDD = LDXD(IDXV+1)+1 - -C LDD points to the byte within TABD(ID,LUN) which contains (in -C packed integer format) a count of the number of child mnemonics -C stored thus far for this parent mnemonic. - -C ZERO THE COUNTER IF IDN IS ZERO -C ------------------------------- - - IF(IDN.EQ.0) THEN - CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,0) - IRET = 0 - GOTO 100 - ENDIF - -C UPDATE THE STORED DESCRIPTOR COUNT FOR THIS TABLE D ENTRY -C --------------------------------------------------------- - - ND = IUPM(TABD(ID,LUN)(LDD:LDD),8) - -C ND is the (unpacked) count of the number of child mnemonics -C stored thus far for this parent mnemonic. - - IF(ND.LT.0 .OR. ND.EQ.MAXCD) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - IF(ND.LT.0) THEN - WRITE ( UNIT=ERRSTR, FMT='(A,I4,A)' ) - . 'BUFRLIB: PKTDD - BAD COUNTER VALUE (=', ND, - . ') - RETURN WITH IRET = -1' - ELSE - WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,A)' ) - . 'BUFRLIB: PKTDD - MAXIMUM NUMBER OF CHILD MNEMONICS (=', - . MAXCD, ') ALREADY STORED FOR THIS PARENT - RETURN WITH ', - . 'IRET = -1' - ENDIF - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IRET = -1 - GOTO 100 - ELSE - ND = ND+1 - CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,ND) - IRET = ND - ENDIF - -C PACK AND STORE THE DESCRIPTOR -C ----------------------------- - - IDM = LDD+1 + (ND-1)*2 - -C IDM points to the starting byte within TABD(ID,LUN) at which -C the IDN value for this child mnemonic will be stored (as a -C packed integer of width = 2 bytes). - - CALL IPKM(TABD(ID,LUN)(IDM:IDM),2,IDN) - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/pkvs01.f b/src/bufr/pkvs01.f deleted file mode 100644 index 0fdc6f5cca..0000000000 --- a/src/bufr/pkvs01.f +++ /dev/null @@ -1,151 +0,0 @@ - SUBROUTINE PKVS01(S01MNEM,IVAL) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PKVS01 -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY A VALUE TO BE WRITTEN -C INTO A SPECIFIED LOCATION WITHIN SECTION 0 OR SECTION 1 OF ALL BUFR -C MESSAGES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR -C ARCHIVE LIBRARY SUBROUTINES WHICH CREATE SUCH MESSAGES (E.G. WRITCP, -C WRITSB, COPYMG, WRITSA, ETC.). IT WILL WORK ON ANY MESSAGE ENCODED -C USING BUFR EDITION 2, 3 OR 4, AND IT CAN BE CALLED AT ANY TIME, -C INCLUDING BEFORE THE FIRST CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE -C OPENBF IF IT IS DESIRED FOR THE NEW VALUE TO ALSO BE INCLUDED IN ANY -C DX DICTIONARY TABLE MESSAGES THAT WILL BE OUTPUT BY BUFR ARCHIVE -C LIBRARY SUBROUTINE WRITDX. IN ANY CASE, THE LOCATION WITHIN WHICH -C TO STORE THE VALUE IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS -C EXPLAINED IN FURTHER DETAIL BELOW. IF MULTIPLE VALUES ARE DESIRED -C TO BE CHANGED WITHIN SECTION 0 OR SECTION 1 OF FUTURE OUTPUT -C MESSAGES, THEN EACH SUCH VALUE (AND CORRESPONDING LOCATION) -C SHOULD BE SPECIFIED USING A SEPARATE CALL TO THIS SUBROUTINE. -C NOTE THAT EACH CALL TO THIS SUBROUTINE WITH A PARTICULAR LOCATION -C SPECIFICATION WILL OVERRIDE THE EFFECT OF ANY PREVIOUS CALL WITH -C THAT SAME SPECIFICATION (OR, IN THE CASE OF THE FIRST CALL WITH A -C PARTICULAR LOCATION SPECIFICATION, IT WILL OVERRIDE THE DEFAULT -C SECTION 0 OR SECTION 1 VALUE FOR THE CORRESPONDING LOCATION!). -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2006-04-14 D. KEYSER -- UPDATED DOCBLOCK -C -C USAGE: CALL PKVS01(S01MNEM,IVAL) -C INPUT ARGUMENT LIST: -C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING LOCATION WHERE IVAL -C IS TO BE STORED WITHIN SECTION 0 OR SECTION 1 OF ALL -C FUTURE OUTPUT BUFR MESSAGES: -C 'BEN' = BUFR EDITION NUMBER -C 'BMT' = BUFR MASTER TABLE -C 'OGCE' = ORIGINATING CENTER -C 'GSES' = ORIGINATING SUBCENTER -C (NOTE: THIS VALUE WILL BE STORED ONLY IN -C BUFR EDITION 3 OR 4 MESSAGES!) -C 'USN' = UPDATE SEQUENCE NUMBER -C 'MTYP' = DATA CATEGORY -C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) -C (NOTE: THIS VALUE WILL BE STORED ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MSBT' = DATA SUBCATEGORY (LOCAL) -C 'MTV' = VERSION NUMBER OF MASTER TABLE -C 'MTVL' = VERSION NUMBER OF LOCAL TABLES -C 'YCEN' = YEAR OF CENTURY (1-100) -C (NOTE: THIS VALUE WILL BE STORED ONLY IN -C BUFR EDITION 2 AND 3 MESSAGES!) -C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, -C 21 FOR YEARS 2001-2100) -C (NOTE: THIS VALUE WILL BE STORED ONLY IN -C BUFR EDITION 2 AND 3 MESSAGES!) -C 'YEAR' = YEAR (4-DIGIT) -C (NOTE: THIS VALUE WILL BE STORED ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'MNTH' = MONTH -C 'DAYS' = DAY -C 'HOUR' = HOUR -C 'MINU' = MINUTE -C 'SECO' = SECOND -C (NOTE: THIS VALUE WILL BE STORED ONLY IN -C BUFR EDITION 4 MESSAGES!) -C 'INIT' = THIS IS A SPECIAL FLAG TO FORCE THE -C INITIALIZATION OF NS01V = 0 WITHIN -C COMMON /S01CM/; IN THIS CASE IVAL IS -C IGNORED -C (NOTE: AN APPLICATION PROGRAM SHOULD -C NEVER ITSELF NEED TO DO THIS!) -C IVAL - INTEGER: NEW VALUE FOR LOCATION POINTED TO BY S01MNEM -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: BFRINI -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) - - CHARACTER*(*) S01MNEM - - CHARACTER*128 BORT_STR - CHARACTER*8 CMNEM - - DATA IFIRST/0/ - - SAVE IFIRST - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(IFIRST.EQ.0) THEN - -C NOTE THAT WE ARE INITIALIZING NS01V=0 HERE (RATHER THAN WITHIN -C SUBROUTINE BFRINI) IN ORDER TO ALLOW FOR THE POSSIBILITY THAT A -C USER MAY CALL SUBROUTINE PKVS01 PRIOR TO CALLING SUBROUTINE -C OPENBF (WHICH ITSELF CALLS BFRINI!). HOWEVER, IF THE USER DOES -C NOT DO THIS, THEN THE "CALL PKVS01('INIT',-99)" STATEMENT WITHIN -C BFRINI WILL ENSURE THAT THE REQUIRED INITIALIZATION OF NS01V=0 -C STILL GETS DONE; OTHERWISE, WE WOULD RUN THE RISK OF NS01V BEING -C UNINITIALIZED WHEN REFERENCED LATER ON WITHIN SUBROUTINE MSGWRT! - - NS01V = 0 - IFIRST = 1 - ENDIF - - IF (S01MNEM.EQ.'INIT') THEN - RETURN - ENDIF - -C IF AN IVAL HAS ALREADY BEEN ASSIGNED FOR THIS PARTICULAR S01MNEM, -C THEN OVERWRITE THAT ENTRY IN COMMON /S01CM/ USING THE NEW IVAL. - - IF(NS01V.GT.0) THEN - DO I=1,NS01V - IF(S01MNEM.EQ.CMNEM(I)) THEN - IVMNEM(I) = IVAL - RETURN - ENDIF - ENDDO - ENDIF - -C OTHERWISE, USE THE NEXT AVAILABLE UNUSED ENTRY IN COMMON /S01CM/. - - IF(NS01V.GE.MXS01V) GOTO 900 - - NS01V = NS01V + 1 - CMNEM(NS01V) = S01MNEM - IVMNEM(NS01V) = IVAL - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: PKVS01 - CANNOT OVERWRITE MORE THAN '// - . '",I2," DIFFERENT LOCATIONS WITHIN SECTION 0 OR SECTION 1")') - . MXS01V - CALL BORT(BORT_STR) - END diff --git a/src/bufr/posapx.f b/src/bufr/posapx.f deleted file mode 100644 index 85bc89770b..0000000000 --- a/src/bufr/posapx.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE POSAPX(LUNXX) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: POSAPX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS TO THE END OF THE FILE POINTED TO BY -C ABS(LUNXX) AND POSITIONS IT FOR APPENDING. THE FILE MUST HAVE -C ALREADY BEEN OPENED FOR OUTPUT OPERATIONS. IF LUNXX > 0, THE FILE -C IS BACKSPACED BEFORE BEING POSITIONED FOR APPEND. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE -C (DICTIONARY) MESSAGES; ADDED LUNXX < 0 -C OPTION TO SIMULATE POSAPN -C 2010-05-11 J. ATOR -- SET ISCODES TO -1 IF UNSUCCESSFUL -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR -C REMOVE UNECESSARY ERROR CHECKING LOGIC -C -C USAGE: CALL POSAPX (LUNXX) -C INPUT ARGUMENT LIST: -C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE (IF LUNXX < 0, THEN THE FILE IS NOT -C BACKSPACED BEFORE POSITIONING FOR APPEND) -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IDXMSG RDBFDX RDMSGW -C STATUS BACKBUFR -C THIS ROUTINE IS CALLED BY: OPENBF -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - DIMENSION MBAY(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LUNIT = ABS(LUNXX) - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 901 - IF(IL.LT.0) GOTO 902 - -C TRY TO READ TO THE END OF THE FILE -C ---------------------------------- - -1 CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.LT.0) RETURN - IF(IDXMSG(MBAY).EQ.1) THEN - -C This is an internal dictionary message that was generated by the -C BUFR archive library software. Backspace the file pointer and -C then read and store all such dictionary messages (they should be -C stored consecutively!) and reset the internal tables. - - call backbufr(lun) !BACKSPACE LUNIT - CALL RDBFDX(LUNIT,LUN) - - ENDIF - GOTO 1 - -C ERROR EXITS -C ----------- - -901 CALL BORT('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT'// - . ', IT MUST BE OPEN FOR OUTPUT') - END diff --git a/src/bufr/rbytes.c b/src/bufr/rbytes.c deleted file mode 100644 index 7c7447aa20..0000000000 --- a/src/bufr/rbytes.c +++ /dev/null @@ -1,62 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RBYTES -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS FUNCTION READS A SPECIFIED NUMBER OF BYTES FROM -C THE SYSTEM FILE MOST RECENTLY OPENED FOR READING/INPUT VIA -C BUFR ARCHIVE LIBRARY ROUTINE COBFL. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: RBYTES( BMG, MXMB, ISLOC, NEWBYTES ) -C INPUT ARGUMENT LIST: -C MXMB - INTEGER: DIMENSIONED SIZE (IN BYTES) OF BMG; USED -C BY THE FUNCTION TO ENSURE THAT IT DOES NOT OVERFLOW -C THE BMG ARRAY -C ISLOC - INTEGER: STARTING BYTE NUMBER WITHIN BMG INTO -C WHICH TO READ THE NEXT NEWBYTES BYTES -C NEWBYTES - INTEGER: NUMBER OF BYTES TO READ FROM THE SYSTEM -C FILE MOST RECENTLY OPENED FOR READING/INPUT VIA -C BUFR ARCHIVE LIBRARY ROUTINE COBFL -C -C OUTPUT ARGUMENT LIST: -C BMG - CHARACTER*1: ARRAY CONTAINING THE NEWBYTES BYTES -C THAT WERE READ, BEGINNING AT BYTE NUMBER ISLOC -C RBYTES - INTEGER: RETURN CODE: -C 0 = normal return -C 1 = overflow of BMG array -C -1 = end-of-file encountered while reading -C -2 = I/O error encountered while reading -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: CRBMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -f77int rbytes( char *bmg, f77int *mxmb, f77int isloc, f77int newbytes ) -{ - short iret; - - if ( ( isloc + newbytes ) > *mxmb ) { - iret = 1; - } - else if ( fread( &bmg[isloc], 1, newbytes, pbf[0] ) != newbytes ) { - iret = ( feof(pbf[0]) ? -1 : -2 ); - } - else { - iret = 0; - } - - return (f77int) iret; -} diff --git a/src/bufr/rcstpl.f b/src/bufr/rcstpl.f deleted file mode 100644 index b205639f28..0000000000 --- a/src/bufr/rcstpl.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE RCSTPL(LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RCSTPL -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL -C SUBSET ARRAYS IN COMMON BLOCKS /USRINT/ AND /USRBIT/. THIS IS IN -C PREPARATION FOR THE ACTUAL UNPACKING OF THE SUBSET IN BUFR ARCHIVE -C LIBRARY SUBROUTINE RDTREE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); MAXRCR (MAXIMUM -C NUMBER OF RECURSION LEVELS) INCREASED FROM -C 50 TO 100 (WAS IN VERIFICATION VERSION); -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY; COMMENTED OUT -C HARDWIRE OF VTMP TO "BMISS" (10E10) WHEN IT -C IS > 10E9 (CAUSED PROBLEMS ON SOME FOREIGN -C MACHINES) -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C -C USAGE: CALL RCSTPL (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: BORT UPBB -C THIS ROUTINE IS CALLED BY: RDTREE -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - PARAMETER (MAXRCR=100) - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) - COMMON /USRTMP/ ITMP(MAXJL,MAXRCR),VTMP(MAXJL,MAXRCR) - - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*3 TYP - DIMENSION NBMP(2,MAXRCR),NEWN(2,MAXRCR) - DIMENSION KNX(MAXRCR) - REAL*8 VAL,VTMP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C SET THE INITIAL VALUES FOR THE TEMPLATE -C --------------------------------------- - -c .... Positional index of Table A mnem. - INV(1,LUN) = INODE(LUN) - VAL(1,LUN) = 0 - NBMP(1,1) = 1 - NBMP(2,1) = 1 - NODI = INODE(LUN) - NODE = INODE(LUN) - MBMP = 1 - KNVN = 1 - NR = 0 - - DO I=1,MAXRCR - KNX(I) = 0 - ENDDO - -C SET UP THE PARAMETERS FOR A LEVEL OF RECURSION -C ---------------------------------------------- - -10 CONTINUE - - NR = NR+1 - IF(NR.GT.MAXRCR) GOTO 900 - NBMP(1,NR) = 1 - NBMP(2,NR) = MBMP - - N1 = ISEQ(NODE,1) - N2 = ISEQ(NODE,2) - IF(N1.EQ.0 ) GOTO 901 - IF(N2-N1+1.GT.MAXJL) GOTO 902 - NEWN(1,NR) = 1 - NEWN(2,NR) = N2-N1+1 - - DO N=1,NEWN(2,NR) - NN = JSEQ(N+N1-1) - ITMP(N,NR) = NN - VTMP(N,NR) = VALI(NN) - ENDDO - -C STORE NODES AT SOME RECURSION LEVEL -C ----------------------------------- - -20 DO I=NBMP(1,NR),NBMP(2,NR) - IF(KNX(NR).EQ.0000) KNX(NR) = KNVN - IF(I.GT.NBMP(1,NR)) NEWN(1,NR) = 1 - DO J=NEWN(1,NR),NEWN(2,NR) - KNVN = KNVN+1 - NODE = ITMP(J,NR) -c .... INV is positional index in internal jump/link table for packed -c subset element KNVN in MBAY - INV(KNVN,LUN) = NODE -c .... Actual unpacked subset values (VAL) are initialized here -c (numbers as BMISS) - VAL(KNVN,LUN) = VTMP(J,NR) -c .... MBIT is the bit in MBAY pointing to where the packed subset -c element KNVN begins - MBIT(KNVN) = MBIT(KNVN-1)+NBIT(KNVN-1) -c .... NBIT is the number of bits in MBAY occupied by packed subset -c element KNVN - NBIT(KNVN) = IBT(NODE) - IF(ITP(NODE).EQ.1) THEN - CALL UPBB(MBMP,NBIT(KNVN),MBIT(KNVN),MBAY(1,LUN)) - NEWN(1,NR) = J+1 - NBMP(1,NR) = I - GOTO 10 - ENDIF - ENDDO - NEW = KNVN-KNX(NR) - VAL(KNX(NR)+1,LUN) = VAL(KNX(NR)+1,LUN) + NEW - KNX(NR) = 0 - ENDDO - -C CONTINUE AT ONE RECURSION LEVEL BACK -C ------------------------------------ - - IF(NR-1.NE.0) THEN - NR = NR-1 - GOTO 20 - ENDIF - -C FINALLY STORE THE LENGTH OF (NUMBER OF ELEMENTS IN) SUBSET TEMPLATE -C ------------------------------------------------------------------- - - NVAL(LUN) = KNVN - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION '// - . 'LEVELS EXCEEDS THE LIMIT (",I3,")")') MAXRCR - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)') - . TAG(NODI) - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - TEMPLATE ARRAY OVERFLOW, '// - . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdbfdx.f b/src/bufr/rdbfdx.f deleted file mode 100644 index 4c9db1e82f..0000000000 --- a/src/bufr/rdbfdx.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE RDBFDX(LUNIT,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDBFDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT, -C THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE -C ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO INTERNAL MEMORY ARRAYS -C IN COMMON /TABABD/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1996-12-17 J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF -C INTERNAL READS (INCREASES PORTABILITY) -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01 AND RDMSGW -C 2009-03-23 J. ATOR -- USE STNTBIA; MODIFY LOGIC TO HANDLE BUFR -C TABLE MESSAGES ENCOUNTERED ANYWHERE IN THE -C FILE (AND NOT JUST AT THE BEGINNING!) -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR -C -C USAGE: CALL RDBFDX (LUNIT, LUN) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C -C THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE RDUSDX, EXCEPT THAT RDUSDX READS FROM A FILE CONTAINING -C A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT. SEE THE -C DOCBLOCK IN RDUSDX FOR A DESCRIPTION OF THE ARRAYS THAT ARE FILLED -C IN COMMON BLOCK /TABABD/. -C -C THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE CPDXMM, EXCEPT THAT CPDXMM WRITES TO THE INTERNAL MEMORY -C ARRAYS IN COMMON BLOCK /MSGMEM/, FOR USE WITH A FILE OF BUFR -C MESSAGES THAT IS BEING READ AND STORED INTO INTERNAL MEMORY BY -C BUFR ARCHIVE LIBRARY SUBROUTINE UFBMEM. -C -C THIS ROUTINE CALLS: BORT DXINIT ERRWRT IDXMSG -C IUPBS3 MAKESTAB RDMSGW STBFDX -C BACKBUFR -C THIS ROUTINE IS CALLED BY: POSAPX READDX READMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET/ IPRT - - DIMENSION MBAY(MXMSGLD4) - - CHARACTER*128 ERRSTR - - LOGICAL DONE - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL DXINIT(LUN,0) - - ICT = 0 - DONE = .FALSE. - -C Read a complete dictionary table from LUNIT, as a set of one or -C more DX dictionary messages. - - DO WHILE ( .NOT. DONE ) - CALL RDMSGW ( LUNIT, MBAY, IER ) - IF ( IER .EQ. -1 ) THEN - -C Don't abort for an end-of-file condition, since it may be -C possible for a file to end with dictionary messages. -C Instead, backspace the file pointer and let the calling -C routine diagnose the end-of-file condition and deal with -C it as it sees fit. - - call backbufr(lun) - DONE = .TRUE. - ELSE IF ( IER .EQ. -2 ) THEN - GOTO 900 - ELSE IF ( IDXMSG(MBAY) .NE. 1 ) THEN - -C This is a non-DX dictionary message. Assume we've reached -C the end of the dictionary table, and backspace LUNIT so that -C the next read (e.g. in the calling routine) will get this -C same message. - - call backbufr(lun) - DONE = .TRUE. - ELSE IF ( IUPBS3(MBAY,'NSUB') .EQ. 0 ) THEN - -C This is a DX dictionary message, but it doesn't contain any -C actual dictionary information. Assume we've reached the end -C of the dictionary table. - - DONE = .TRUE. - ELSE - -C Store this message into COMMON /TABABD/. - - ICT = ICT + 1 - CALL STBFDX(LUN,MBAY) - ENDIF - ENDDO - - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) - . 'BUFRLIB: RDBFDX - STORED NEW DX TABLE CONSISTING OF (', - . ICT, ') MESSAGES;' - CALL ERRWRT(ERRSTR) - ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA IN '// - . 'FILE UNTIL NEXT DX TABLE IS FOUND' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - CALL MAKESTAB - - RETURN - 900 CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '// - . 'MESSAGE') - END diff --git a/src/bufr/rdcmps.f b/src/bufr/rdcmps.f deleted file mode 100644 index d7ab6a2664..0000000000 --- a/src/bufr/rdcmps.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE RDCMPS(LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDCMPS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 -C -C ABSTRACT: THIS SUBROUTINE UNCOMPRESSES AND UNPACKS THE NEXT SUBSET -C FROM THE INTERNAL COMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON -C BLOCK /BITBUF/) AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL -C ARRAY VAL(*,LUN) IN COMMON BLOCK /USRINT/. -C -C PROGRAM HISTORY LOG: -C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR -C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY RDCMPS -C WOULD NOT RECOGNIZE COMPRESSED DELAYED -C REPLICATION AS A LEGITIMATE DATA STRUCTURE -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION -C 2004-08-18 J. ATOR -- INITIALIZE CVAL TO EMPTY BEFORE CALLING UPC; -C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS -C THE SAME FOR ALL SUBSETS IN A MESSAGE; -C MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- PREVENT OVERFLOW OF CVAL AND CREF FOR -C STRINGS LONGER THAN 8 CHARACTERS -C 2012-03-02 J. ATOR -- USE FUNCTION UPS -C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN -C CORRESPONDING CHARACTER FIELD HAS ALL BITS -C SET TO 1 -C -C USAGE: CALL RDCMPS (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ICBFMS UPB UPC -C UPS USRTPL -C THIS ROUTINE IS CALLED BY: READSB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST) - - CHARACTER*128 BORT_STR - CHARACTER*10 TAG,CRTAG - CHARACTER*8 CREF,CVAL - CHARACTER*3 TYP - EQUIVALENCE (CVAL,RVAL) - REAL*8 VAL,RVAL,UPS - -C----------------------------------------------------------------------- -C Statement function to compute BUFR "missing value" for field -C of length LBIT bits (all bits "on"): - - LPS(LBIT) = MAX(2**(LBIT)-1,1) -C----------------------------------------------------------------------- - -C SETUP THE SUBSET TEMPLATE -C ------------------------- - - CALL USRTPL(LUN,1,1) - -C UNCOMPRESS A SUBSET INTO THE VAL ARRAY ACCORDING TO TABLE B -C ----------------------------------------------------------- - - NSBS = NSUB(LUN) - -C Note that we are going to unpack the (NSBS)th subset from within -C the current BUFR message. - - IBIT = MBYT(LUN) - NRST = 0 - -C Loop through each element of the subset. - - N = 0 - -1 DO N=N+1,NVAL(LUN) - NODE = INV(N,LUN) - NBIT = IBT(NODE) - ITYP = ITP(NODE) - -C In each of the following code blocks, the "local reference value" -C for the element is determined first, followed by the 6-bit value -C which indicates how many bits are used to store the increment -C (i.e. offset) from this "local reference value". Then, we jump -C ahead to where this increment is stored for this particular subset, -C unpack it, and add it to the "local reference value" to determine -C the final uncompressed value for this element from this subset. - -C Note that, if an element has the same final uncompressed value -C for each subset in the message, then the encoding rules for BUFR -C compression dictate that the "local reference value" will be equal -C to this value, the 6-bit increment length indicator will have -C a value of zero, and the actual increments themselves will be -C omitted from the message. - - IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN - -C This is a numeric element. - - CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) - CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) - JBIT = IBIT + LINC*(NSBS-1) - CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) - IF(NINC.EQ.LPS(LINC)) THEN - IVAL = LPS(NBIT) - ELSE - IVAL = LREF+NINC - ENDIF - IF(ITYP.EQ.1) THEN - CALL USRTPL(LUN,N,IVAL) - GOTO 1 - ENDIF - IF(IVAL.LT.LPS(NBIT)) VAL(N,LUN) = UPS(IVAL,NODE) - IBIT = IBIT + LINC*MSUB(LUN) - ELSEIF(ITYP.EQ.3) THEN - -C This is a character element. If there are more than 8 -C characters, then only the first 8 will be unpacked by this -C routine, and a separate subsequent call to BUFR archive library -C subroutine READLC will be required to unpack the remainder of -C the string. In this case, pointers will be saved within -C COMMON /RLCCMN/ for later use within READLC. - -C Unpack the local reference value. - - LELM = NBIT/8 - NCHR = MIN(8,LELM) - IBSV = IBIT - CREF = ' ' - CALL UPC(CREF,NCHR,MBAY(1,LUN),IBIT) - IF(LELM.GT.8) THEN - IBIT = IBIT + (LELM-8)*8 - NRST = NRST + 1 - IF(NRST.GT.MXRST) GOTO 900 - CRTAG(NRST) = TAG(NODE) - ENDIF - -C Unpack the increment length indicator. For character elements, -C this length is in bytes rather than bits. - - CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) - IF(LINC.EQ.0) THEN - IF(LELM.GT.8) THEN - IRNCH(NRST) = LELM - IRBIT(NRST) = IBSV - ENDIF - CVAL = CREF - ELSE - JBIT = IBIT + LINC*(NSBS-1)*8 - IF(LELM.GT.8) THEN - IRNCH(NRST) = LINC - IRBIT(NRST) = JBIT - ENDIF - NCHR = MIN(8,LINC) - CVAL = ' ' - CALL UPC(CVAL,NCHR,MBAY(1,LUN),JBIT) - ENDIF - IF (LELM.LE.8 .AND. ICBFMS(CVAL,NCHR).NE.0) THEN - VAL(N,LUN) = BMISS - ELSE - VAL(N,LUN) = RVAL - ENDIF - IBIT = IBIT + 8*LINC*MSUB(LUN) - ENDIF - ENDDO - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER ' // - . 'STRINGS EXCEEDS THE LIMIT (",I4,")")') MXRST - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdmemm.f b/src/bufr/rdmemm.f deleted file mode 100644 index 216ac6612b..0000000000 --- a/src/bufr/rdmemm.f +++ /dev/null @@ -1,227 +0,0 @@ - SUBROUTINE RDMEMM(IMSG,SUBSET,JDATE,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMEMM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM -C INTERNAL MEMORY (ARRAY MSGS IN COMMON BLOCK /MSGMEM/) INTO A -C MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS -C IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMM EXCEPT IT DOES -C NOT ADVANCE THE VALUE OF IMSG PRIOR TO RETURNING TO CALLING -C PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI); THE MAXIMUM -C NUMBER OF BYTES REQUIRED TO STORE ALL -C MESSAGES INTERNALLY WAS INCREASED FROM 4 -C MBYTES TO 8 MBYTES -C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD -C BEEN REPLICATED IN THIS AND OTHER READ -C ROUTINES AND CONSOLIDATED IT INTO A NEW -C ROUTINE CKTABA, CALLED HERE, WHICH IS -C ENHANCED TO ALLOW COMPRESSED AND STANDARD -C BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE -C LENGTH INCREASED FROM 10,000 TO 20,000 -C BYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE -C (DICTIONARY) MESSAGES; USE ERRWRT -C -C -C USAGE: CALL RDMEMM (IMSG, SUBSET, JDATE, IRET) -C INPUT ARGUMENT LIST: -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C STORAGE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = IMSG is either zero or greater than the -C number of messages in memory -C -C REMARKS: -C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT CKTABA DXINIT ERRWRT -C MAKESTAB STATUS STBFDX WTSTAT -C THIS ROUTINE IS CALLED BY: READMM UFBMMS UFBRMS UFBTAM -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - COMMON /QUIET / IPRT - - DIMENSION MSGDX(MXMSGLD4) - - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*8 SUBSET - - LOGICAL KNOWN - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE MESSAGE REQUEST AND FILE STATUS -C ----------------------------------------- - - CALL STATUS(MUNIT,LUN,IL,IM) - CALL WTSTAT(MUNIT,LUN,IL, 1) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IRET = 0 - - IF(IMSG.EQ.0 .OR.IMSG.GT.MSGP(0)) THEN - CALL WTSTAT(MUNIT,LUN,IL,0) - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - IF(IMSG.EQ.0) THEN - ERRSTR = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE '// - . 'NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH '// - . 'IRET = -1' - ELSE - WRITE ( UNIT=ERRSTR, FMT='(A,I6,A,I6,A)' ) - . 'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', IMSG, - . ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (', - . MSGP(0), '), RETURN WITH IRET = -1' - ENDIF - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IRET = -1 - GOTO 100 - ENDIF - -C ENSURE THAT THE PROPER DICTIONARY TABLE IS IN SCOPE -C --------------------------------------------------- - -C Determine which table applies to this message. - - KNOWN = .FALSE. - JJ = NDXTS - DO WHILE ((.NOT.KNOWN).AND.(JJ.GE.1)) - IF (IPMSGS(JJ).LE.IMSG) THEN - KNOWN = .TRUE. - ELSE - JJ = JJ - 1 - ENDIF - ENDDO - IF (.NOT.KNOWN) GOTO 902 - -C Is this table the one that is currently in scope? - - IF (JJ.NE.LDXTS) THEN - -C No, so reset the software to use the proper table. - - IF(IPRT.GE.2) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A,I6)' ) - . 'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', JJ, - . ' INSTEAD OF DX TABLE #', LDXTS, - . ' FOR REQUESTED MESSAGE #', IMSG - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - CALL DXINIT(LUN,0) - -C Store each of the DX dictionary messages which constitute -C this table. - - DO II = IFDXTS(JJ), (IFDXTS(JJ)+ICDXTS(JJ)-1) - IF (II.EQ.NDXM) THEN - NWRD = LDXM - IPDXM(II) + 1 - ELSE - NWRD = IPDXM(II+1) - IPDXM(II) - ENDIF - DO KK = 1, NWRD - MSGDX(KK) = MDX(IPDXM(II)+KK-1) - ENDDO - CALL STBFDX(LUN,MSGDX) - ENDDO - -C Rebuild the internal jump/link table. - - CALL MAKESTAB - LDXTS = JJ - ENDIF - -C READ MEMORY MESSAGE NUMBER IMSG INTO A MESSAGE BUFFER -C ----------------------------------------------------- - - IPTR = MSGP(IMSG) - IF(IMSG.LT.MSGP(0)) LPTR = MSGP(IMSG+1)-IPTR - IF(IMSG.EQ.MSGP(0)) LPTR = MLAST-IPTR+1 - IPTR = IPTR-1 - - DO I=1,LPTR - MBAY(I,LUN) = MSGS(IPTR+I) - ENDDO - -C PARSE THE MESSAGE SECTION CONTENTS -C ---------------------------------- - - CALL CKTABA(LUN,SUBSET,JDATE,JRET) - NMSG(LUN) = IMSG - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 WRITE(BORT_STR,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR '// - . 'REQUESTED MESSAGE #",I5)') IMSG - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdmems.f b/src/bufr/rdmems.f deleted file mode 100644 index 5acf7b96f7..0000000000 --- a/src/bufr/rdmems.f +++ /dev/null @@ -1,165 +0,0 @@ - SUBROUTINE RDMEMS(ISUB,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMEMS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET FROM A BUFR -C MESSAGE IN INTERNAL MEMORY (ARRAY MBAY IN COMMON BLOCK /BITBUF/) -C INTO INTERNAL SUBSET ARRAYS BASED ON THE SUBSET NUMBER IN THE -C MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL RDMEMS (ISUB, IRET) -C INPUT ARGUMENT LIST: -C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR -C MESSAGE -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = ISUB is greater than the number of subsets -C in memory -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT IUPB READSB -C STATUS -C THIS ROUTINE IS CALLED BY: UFBMMS UFBMNS UFBRMS -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - CHARACTER*128 BORT_STR,ERRSTR - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /UNPTYP/ MSGUNP(NFILES) - COMMON /QUIET / IPRT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE MESSAGE REQUEST AND FILE STATUS -C ----------------------------------------- - - CALL STATUS(MUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(NSUB(LUN).NE.0) GOTO 903 - - IF(ISUB.GT.MSUB(LUN)) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I5,A,A,I5,A)' ) - . 'BUFRLIB: RDMEMS - REQ. SUBSET #', ISUB, ' (= 1st INPUT ', - . 'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', MSUB(LUN), ')' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('RETURN WITH IRET = -1') - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IRET = -1 - GOTO 100 - ENDIF - - MBYM = MBYT(LUN) - NBYT = 0 - -C POSITION TO SUBSET NUMBER ISUB IN MEMORY MESSAGE -C ------------------------------------------------ - - IF(MSGUNP(LUN).EQ.0) THEN - NSUB(LUN) = ISUB-1 - DO I=1,ISUB-1 - MBYT(LUN) = MBYT(LUN) + IUPB(MBAY(1,LUN),MBYT(LUN)+1,16) - ENDDO - ELSEIF(MSGUNP(LUN).EQ.1) THEN -c .... message with "standard" Section 3 - DO I=1,ISUB-1 - CALL READSB(MUNIT,IRET) - ENDDO - ELSEIF(MSGUNP(LUN).EQ.2) THEN -c .... compressed message - NSUB(LUN) = ISUB-1 - ENDIF - -C NOW READ SUBSET NUMBER ISUB FROM MEMORY MESSAGE -C ----------------------------------------------- - - CALL READSB(MUNIT,IRET) -c .... This should have already been accounted for with stmt. 902 or -c IRET = -1 above - IF(IRET.NE.0) GOTO 904 - -C RESET SUBSET POINTER BACK TO ZERO (BEGINNING OF MESSAGE) AND RETURN -C ------------------------------------------------------------------- - - MBYT(LUN) = MBYM - NSUB(LUN) = 0 - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: RDMEMS - A MEMORY MESSAGE MUST BE OPEN IN '// - . 'INPUT BUFR FILE, NONE ARE') -903 WRITE(BORT_STR,'("BUFRLIB: RDMEMS - UPON ENTRY, SUBSET POINTER '// - . 'IN MEMORY MESSAGE IS NOT AT BEGINNING (",I3," SUBSETS HAVE '// - . 'BEEN READ, SHOULD BE 0)")') NSUB(LUN) - CALL BORT(BORT_STR) -904 CALL BORT('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED '// - . 'WITH IRET = -1 (EITHER MEMORY MESSAGE NOT OPEN OR ALL '// - . 'SUBSETS IN MESSAGE READ') - END diff --git a/src/bufr/rdmgsb.f b/src/bufr/rdmgsb.f deleted file mode 100644 index 7d896edb9f..0000000000 --- a/src/bufr/rdmgsb.f +++ /dev/null @@ -1,112 +0,0 @@ - SUBROUTINE RDMGSB(LUNIT,IMSG,ISUB) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMGSB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE IN LOGICAL UNIT LUNIT FOR -C INPUT OPERATIONS, THEN READS A PARTICULAR SUBSET INTO INTERNAL -C SUBSET ARRAYS FROM A PARTICULAR BUFR MESSAGE IN A MESSAGE BUFFER. -C THIS IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE MESSAGE -C NUMBER IN THE BUFR FILE. THE MESSAGE NUMBER DOES NOT INCLUDE THE -C DICTIONARY MESSAGES AT THE BEGINNING OF THE FILE. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION -C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION -C VERSION AT ONE TIME AND THEN REMOVED) -C 2003-11-04 D. KEYSER -- INCORPORATED INTO "UNIFIED" BUFR ARCHIVE -C LIBRARY; UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- MODIFY LOGIC TO HANDLE BUFR TABLE MESSAGES -C ENCOUNTERED ANYWHERE IN THE FILE (AND NOT -C JUST AT THE BEGINNING!) -C -C USAGE: CALL RDMGSB (LUNIT, IMSG, ISUB) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER TO READ IN -C BUFR FILE -C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR -C MESSAGE -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT OPENBF READMG READSB -C STATUS UPB -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C OPEN THE FILE AND SKIP TO MESSAGE # IMSG -C ---------------------------------------- - - CALL OPENBF(LUNIT,'IN',LUNIT) - CALL STATUS(LUNIT,LUN,IL,IM) - -C Note that we need to use subroutine READMG to actually read in all -C of the messages (including the first (IMSG-1) messages!), just in -C case there are any embedded dictionary messages in the file. - - DO I=1,IMSG - CALL READMG(LUNIT,SUBSET,JDATE,IRET) - IF(IRET.LT.0) GOTO 901 - ENDDO - -C POSITION AT SUBSET # ISUB -C ------------------------- - - DO I=1,ISUB-1 - IF(NSUB(LUN).GT.MSUB(LUN)) GOTO 902 - IBIT = MBYT(LUN)*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - MBYT(LUN) = MBYT(LUN) + NBYT - NSUB(LUN) = NSUB(LUN) + 1 - ENDDO - - CALL READSB(LUNIT,IRET) - IF(IRET.NE.0) GOTO 902 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - ERROR READING MESSAGE '// - . '(RECORD) NUMBER",I5," IN INPUT BUFR FILE CONNECTED TO UNIT",'// - . 'I4)') I,LUNIT - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - HIT END OF FILE BEFORE '// - . 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO'// - . ' UNIT",I4)') IMSG,LUNIT - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - ALL SUBSETS READ BEFORE '// - . 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR '// - . 'FILE CONNECTED TO UNIT",I4)') ISUB,IMSG,LUNIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdmsgb.f b/src/bufr/rdmsgb.f deleted file mode 100644 index 08207c157b..0000000000 --- a/src/bufr/rdmsgb.f +++ /dev/null @@ -1,103 +0,0 @@ - SUBROUTINE RDMSGB(LUNIT,MESG,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMSGB -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL -C UNIT LUNIT AS AN ARRAY OF BYTES, WHICH ARE THEN TRANSFERRED TO -C AN ARRAY OF INTEGER WORDS FOR OUTPUT. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2009-03-23 D. KEYSER -- CALLS BORT IN CASE OF MESG OVERFLOW -C -C USAGE: CALL RDMSGB (LUNIT, MESG, IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C MESG - *-WORD ARRAY CONTAINING BUFR MESSAGE READ FROM LUNIT -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = end-of-file encountered while reading -C from LUNIT -C -2 = I/O error encountered while reading -C from LUNIT -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ICHKSTR IUPBS01 LMSG -C THIS ROUTINE IS CALLED BY: None -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION MESG(*) - - CHARACTER*128 BORT_STR - CHARACTER*8 SEC0 - CHARACTER*1 CBAY(8*MXMSGLD4) - DIMENSION JBAY(MXMSGLD4) - - EQUIVALENCE (CBAY(1),JBAY(1),SEC0) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - SEC0 = ' ' - -C Read Section 0 from the next message in the file. - - READ(LUNIT,END=100,ERR=200) SEC0 - -C Confirm that the first 4 bytes contain 'BUFR' encoded in -C CCITT IA5 (i.e. ASCII). - - IF(ICHKSTR('BUFR',CBAY,4).NE.0) GOTO 200 - -C Check the length of the next message to make sure it will fit -C within the output array. - - LNMSG = LMSG(SEC0) - IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 900 - -C Read the rest of the message as an array of bytes. - - READ(LUNIT,END=100,ERR=200) (CBAY(I),I=9,IUPBS01(JBAY,'LENM')) - -C Transfer the message to the output array. - - DO I=1,LNMSG - MESG(I) = JBAY(I) - ENDDO - -C EXITS -C ----- - - IRET = 0 - RETURN - -100 IRET = -1 - RETURN - -200 IRET = -2 - RETURN - -900 WRITE(BORT_STR,'("BUFRLIB: RDMSGB - INPUT BUFR MESSAGE LENGTH (", - . I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")') - . LNMSG*NBYTW,MXMSGL - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdmsgw.f b/src/bufr/rdmsgw.f deleted file mode 100644 index 01a168cdcb..0000000000 --- a/src/bufr/rdmsgw.f +++ /dev/null @@ -1,68 +0,0 @@ - SUBROUTINE RDMSGW(LUNIT,MESG,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMSGW -C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL -C UNIT LUNIT AS AN ARRAY OF INTEGER WORDS. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR -C 2009-03-23 D. KEYSER -- CALL BORT IN CASE OF MESG OVERFLOW -C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE; -C USE C ROUTINE CRDBUFR TO OBTAIN BUFR -C MESSAGE; REMOVE CODE WHICH CHECKS SEC0 -C AND MESSAGE LENGTH AS CRDBUFR DOES THAT -C -C USAGE: CALL RDMSGW (LUNIT, MESG, IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C MESG - *-WORD ARRAY CONTAINING BUFR MESSAGE READ FROM LUNIT -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = end-of-file encountered while reading -C from LUNIT -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: CRDBUFR ERRWRT STATUS -C THIS ROUTINE IS CALLED BY: COPYBF CPDXMM DATEBF DUMPBF -C MESGBC MESGBF POSAPX RDBFDX -C READMG UFBMEM UFBMEX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION MESG(*) - - CHARACTER*128 BORT_STR - integer crdbufr - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) -1 IRET=CRDBUFR(LUN,MESG,MXMSGL) - IF(IRET.eq.-3) - + CALL ERRWRT('BUFRLIB: RDMSGW - SKIPPING OVERLARGE MESSAGE') - IF(IRET.eq.-2) - + CALL ERRWRT('BUFRLIB: RDMSGW - SKIPPING CORRUPTED MESSAGE') - if(iret.lt.-1) goto 1 - RETURN - END - diff --git a/src/bufr/rdmtbb.f b/src/bufr/rdmtbb.f deleted file mode 100644 index 66110140ca..0000000000 --- a/src/bufr/rdmtbb.f +++ /dev/null @@ -1,130 +0,0 @@ - SUBROUTINE RDMTBB ( LUNSTB, LUNLTB, MXMTBB, - . IMT, IMTV, IOGCE, ILTV, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMTBB -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE READS MASTER TABLE B INFORMATION FROM TWO -C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES AND THEN -C MERGES IT INTO A UNIFIED SET OF MASTER TABLE B ARRAYS FOR OUTPUT. -C EACH OF THE TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN -C ASCENDING ORDER WITH RESPECT TO THE FXY NUMBERS. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL RDMTBB ( LUNSTB, LUNLTB, MXMTBB, IMT, IMTV, IOGCE, -C ILTV, NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, -C CMUNIT, CMMNEM, CMDSC, CMELEM ) -C INPUT ARGUMENT LIST: -C LUNSTB - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING STANDARD TABLE B INFORMATION -C LUNLTB - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING LOCAL TABLE B INFORMATION -C MXMTBB - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN -C MERGED MASTER TABLE B ARRAYS; THIS SHOULD BE THE SAME -C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN -C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE -C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS -C -C OUTPUT ARGUMENT LIST: -C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE -C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) -C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM -C STANDARD ASCII FILE -C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE -C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM -C LOCAL ASCII FILE -C NMTBB - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE B -C ARRAYS -C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE -C REPRESENTATIONS OF FXY NUMBERS -C CMSCL(*) - CHARACTER*4: MERGED ARRAY CONTAINING SCALE FACTORS -C CMSREF(*)- CHARACTER*12: MERGED ARRAY CONTAINING REFERENCE VALUES -C CMBW(*) - CHARACTER*4: MERGED ARRAY CONTAINING BIT WIDTHS -C CMUNIT(*)- CHARACTER*14: MERGED ARRAY CONTAINING UNITS -C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS -C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES -C CMELEM(*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH -C SNTBBE WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*200 STLINE, LTLINE - CHARACTER*128 BORT_STR - CHARACTER*120 CMELEM(*) - CHARACTER*14 CMUNIT(*) - CHARACTER*12 CMSREF(*) - CHARACTER*8 CMMNEM(*) - CHARACTER*6 CMATCH, ADN30 - CHARACTER*4 CMSCL(*), CMBW(*), CMDSC(*) - - INTEGER IMFXYN(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Call WRDLEN to initialize some important information about the -C local machine, just in case it hasn't already been called. - - CALL WRDLEN - -C Read and parse the header lines of both files. - - CALL GETTBH ( LUNSTB, LUNLTB, 'B', IMT, IMTV, IOGCE, ILTV ) - -C Read through the remainder of both files, merging the -C contents into a unified set of master Table B arrays. - - NMTBB = 0 - CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) - CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) - DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) - IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN - IF ( ISFXYN .EQ. ILFXYN ) THEN - CMATCH = ADN30 ( ISFXYN, 6 ) - GOTO 900 - ELSE IF ( ISFXYN .LT. ILFXYN ) THEN - CALL SNTBBE ( ISFXYN, STLINE, MXMTBB, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) - ELSE - CALL SNTBBE ( ILFXYN, LTLINE, MXMTBB, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) - ENDIF - ELSE IF ( IERS .EQ. 0 ) THEN - CALL SNTBBE ( ISFXYN, STLINE, MXMTBB, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) - ELSE IF ( IERL .EQ. 0 ) THEN - CALL SNTBBE ( ILFXYN, LTLINE, MXMTBB, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) - ENDIF - ENDDO - - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBB - STANDARD AND LOCAL'// - . ' TABLE B FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') - . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdmtbd.f b/src/bufr/rdmtbd.f deleted file mode 100644 index db41c20f8e..0000000000 --- a/src/bufr/rdmtbd.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, - . IMT, IMTV, IOGCE, ILTV, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDMTBD -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE READS MASTER TABLE D INFORMATION FROM TWO -C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES AND THEN -C MERGES IT INTO A UNIFIED SET OF MASTER TABLE D ARRAYS FOR OUTPUT. -C EACH OF THE TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN -C ASCENDING ORDER WITH RESPECT TO THE FXY NUMBERS. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, -C IMT, IMTV, IOGCE, ILTV, -C NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, -C NMELEM, IEFXYN, CEELEM ) -C INPUT ARGUMENT LIST: -C LUNSTD - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING STANDARD TABLE D INFORMATION -C LUNLTD - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING LOCAL TABLE D INFORMATION -C MXMTBD - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN -C MERGED MASTER TABLE D ARRAYS; THIS SHOULD BE THE SAME -C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN -C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE -C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS -C MXELEM - INTEGER: MAXIMUM NUMBER OF ELEMENTS TO BE STORED PER -C ENTRY WITHIN THE MERGED MASTER TABLE D ARRAYS; THIS -C SHOULD BE THE SAME NUMBER AS WAS USED TO DIMENSION THE -C OUTPUT ARRAYS IN THE CALLING PROGRAM, AND IT IS USED -C BY THIS SUBROUTINE TO ENSURE THAT IT DOESN'T OVERFLOW -C THESE ARRAYS -C -C OUTPUT ARGUMENT LIST: -C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE -C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) -C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM -C STANDARD ASCII FILE -C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE -C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM -C LOCAL ASCII FILE -C NMTBD - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE D -C ARRAYS -C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE -C REPRESENTATIONS OF FXY NUMBERS (I.E. SEQUENCE -C DESCRIPTORS) -C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS -C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES -C CMSEQ(*) - CHARACTER*120: MERGED ARRAY CONTAINING SEQUENCE NAMES -C NMELEM(*)- INTEGER: MERGED ARRAY CONTAINING NUMBER OF ELEMENTS -C STORED FOR EACH ENTRY -C IEFXYN(*,*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE -C REPRESENTATIONS OF ELEMENT FXY NUMBERS -C CEELEM(*,*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH -C SNTBDE WRDLEN -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*200 STLINE, LTLINE - CHARACTER*128 BORT_STR - CHARACTER*120 CMSEQ(*), CEELEM(MXMTBD,MXELEM) - CHARACTER*8 CMMNEM(*) - CHARACTER*6 CMATCH, ADN30 - CHARACTER*4 CMDSC(*) - - INTEGER IMFXYN(*), NMELEM(*), - . IEFXYN(MXMTBD,MXELEM) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Call WRDLEN to initialize some important information about the -C local machine, just in case it hasn't already been called. - - CALL WRDLEN - -C Read and parse the header lines of both files. - - CALL GETTBH ( LUNSTD, LUNLTD, 'D', IMT, IMTV, IOGCE, ILTV ) - -C Read through the remainder of both files, merging the -C contents into a unified set of master Table D arrays. - - NMTBD = 0 - CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) - CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) - DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) - IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN - IF ( ISFXYN .EQ. ILFXYN ) THEN - CMATCH = ADN30 ( ISFXYN, 6 ) - GOTO 900 - ELSE IF ( ISFXYN .LT. ILFXYN ) THEN - CALL SNTBDE ( LUNSTD, ISFXYN, STLINE, MXMTBD, MXELEM, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) - ELSE - CALL SNTBDE ( LUNLTD, ILFXYN, LTLINE, MXMTBD, MXELEM, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) - ENDIF - ELSE IF ( IERS .EQ. 0 ) THEN - CALL SNTBDE ( LUNSTD, ISFXYN, STLINE, MXMTBD, MXELEM, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) - ELSE IF ( IERL .EQ. 0 ) THEN - CALL SNTBDE ( LUNLTD, ILFXYN, LTLINE, MXMTBD, MXELEM, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) - ENDIF - ENDDO - - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBD - STANDARD AND LOCAL'// - . ' TABLE D FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') - . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rdtree.f b/src/bufr/rdtree.f deleted file mode 100644 index 1747bb74fb..0000000000 --- a/src/bufr/rdtree.f +++ /dev/null @@ -1,137 +0,0 @@ - SUBROUTINE RDTREE(LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDTREE -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL -C UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/) -C AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL ARRAY VAL(*,LUN) -C IN COMMON BLOCK /USRINT/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 J. WOOLLEN -- FIXED A BUG WHICH COULD ONLY OCCUR WHEN -C THE LAST ELEMENT IN A SUBSET IS A CHARACTER -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER -C THAN 8 CHARACTERS -C 2012-03-02 J. ATOR -- USE FUNCTION UPS -C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN -C CORRESPONDING CHARACTER FIELD HAS ALL BITS -C SET TO 1 -C -C USAGE: CALL RDTREE (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: RCSTPL ICBFMS UPBB UPC -C UPS -C THIS ROUTINE IS CALLED BY: READSB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) - - CHARACTER*10 TAG - CHARACTER*8 CVAL - CHARACTER*3 TYP - DIMENSION IVAL(MAXSS) - EQUIVALENCE (CVAL,RVAL) - REAL*8 VAL,RVAL,UPS - -C----------------------------------------------------------------------- -C Statement function to compute BUFR "missing value" for field -C of length IBT(NODE)) bits (all bits "on"): - - MPS(NODE) = 2**(IBT(NODE))-1 -C----------------------------------------------------------------------- - -C CYCLE THROUGH A SUBSET SETTING UP THE TEMPLATE -C ---------------------------------------------- - - MBIT(1) = IBIT - NBIT(1) = 0 - CALL RCSTPL(LUN) - -C UNPACK A SUBSET INTO THE USER ARRAY IVAL -C ---------------------------------------- - - DO N=1,NVAL(LUN) - CALL UPBB(IVAL(N),NBIT(N),MBIT(N),MBAY(1,LUN)) - ENDDO - -C LOOP THROUGH EACH ELEMENT OF THE SUBSET, CONVERTING THE UNPACKED -C VALUES TO THE PROPER TYPES -C ---------------------------------------------------------------- - - DO N=1,NVAL(LUN) - NODE = INV(N,LUN) - IF(ITP(NODE).EQ.1) THEN - -C The unpacked value is a delayed descriptor replication factor. - - VAL(N,LUN) = IVAL(N) - ELSEIF(ITP(NODE).EQ.2) THEN - -C The unpacked value is a real. - - IF(IVAL(N).LT.MPS(NODE)) VAL(N,LUN) = UPS(IVAL(N),NODE) - ELSEIF(ITP(NODE).EQ.3) THEN - -C The value is a character string, so unpack it using an -C equivalenced REAL*8 value. Note that a maximum of 8 characters -C will be unpacked here, so a separate subsequent call to BUFR -C archive library subroutine READLC will be needed to fully -C unpack any string longer than 8 characters. - - CVAL = ' ' - KBIT = MBIT(N) - NBT = MIN(8,NBIT(N)/8) - CALL UPC(CVAL,NBT,MBAY(1,LUN),KBIT) - IF (NBIT(N).LE.64 .AND. ICBFMS(CVAL,NBT).NE.0) THEN - VAL(N,LUN) = BMISS - ELSE - VAL(N,LUN) = RVAL - ENDIF - ENDIF - ENDDO - - IBIT = NBIT(NVAL(LUN))+MBIT(NVAL(LUN)) - - RETURN - END diff --git a/src/bufr/rdusdx.f b/src/bufr/rdusdx.f deleted file mode 100644 index 97ec31906e..0000000000 --- a/src/bufr/rdusdx.f +++ /dev/null @@ -1,273 +0,0 @@ - SUBROUTINE RDUSDX(LUNDX,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RDUSDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS AND PARSES A FILE CONTAINING A USER- -C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT, AND THEN STORES -C THIS INFORMATION INTO INTERNAL ARRAYS IN COMMON BLOCK /TABABD/ (SEE -C REMARKS FOR CONTENTS OF INTERNAL ARRAYS). THIS SUBROUTINE PERFORMS -C A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE RDBFDX, -C EXECPT THAT RDBFDX READS THE BUFR TABLE DIRECTLY FROM MESSAGES AT -C BEGINNING OF AN INPUT BUFR FILE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1996-12-17 J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF -C INTERNAL READS (INCREASES PORTABILITY) -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 -C 2006-04-14 D. KEYSER -- ABORTS IF A USER-DEFINED MESSAGE TYPE "011" -C IS READ (EITHER DIRECTLY FROM A TABLE A -C MNEMONIC OR FROM THE "Y" VALUE OF A TABLE A -C FXY SEQUENCE DESCRIPTOR), MESSAGE TYPE -C "011" IS RESERVED FOR DICTIONARY MESSAGES -C (PREVIOUSLY WOULD STORE DATA WITH MESSAGE -C TYPE "011" BUT SUCH MESSAGES WOULD BE -C SKIPPED OVER WHEN READ) -C 2007-01-19 J. ATOR -- MODIFIED IN RESPONSE TO NUMBCK CHANGES -C 2009-03-23 J. ATOR -- INCREASE SIZE OF BORT_STR2; USE STNTBIA -C 2013-01-08 J. WHITING -- ADD ERR= OPTION TO READ STATEMENT -C -C USAGE: CALL RDUSDX (LUNDX, LUN) -C INPUT ARGUMENT LIST: -C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER- -C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C INPUT FILES: -C UNIT "LUNDX" - USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER -C FORMAT -C -C REMARKS: -C CONTENTS OF INTERNAL ARRAYS WRITTEN INTO COMMON BLOCK /TABABD/: -C -C For Table A entries: -C NTBA(LUN) - INTEGER: Number of Table A entries (note that -C NTBA(0) contains the maximum number of such -C entries as set within subroutine BFRINI) -C TABA(N,LUN) - CHARACTER*128: Table A entries, where -C N=1,2,3,...,NTBA(LUN) -C IDNA(N,LUN,1) - INTEGER: Message type corresponding to -C TABA(N,LUN) -C IDNA(N,LUN,2) - INTEGER: Message subtype corresponding to -C TABA(N,LUN) -C -C For Table B entries: -C NTBB(LUN) - INTEGER: Number of Table B entries (note that -C NTBB(0) contains the maximum number of such -C entries as set within subroutine BFRINI) -C TABB(N,LUN) - CHARACTER*128: Table B entries, where -C N=1,2,3,...,NTBB(LUN) -C IDNB(N,LUN) - INTEGER: Bit-wise representation of the FXY -C value corresponding to TABB(N,LUN) -C -C For Table D entries: -C NTBD(LUN) - INTEGER: Number of Table D entries (note that -C NTBD(0) contains the maximum number of such -C entries as set within subroutine BFRINI) -C TABD(N,LUN) - CHARACTER*600: Table D entries, where -C N=1,2,3,...,NTBD(LUN) -C IDND(N,LUN) - INTEGER: Bit-wise representation of the FXY -C value corresponding to TABD(N,LUN) -C -C -C THIS ROUTINE CALLS: BORT2 DXINIT ELEMDX IGETNTBI -C MAKESTAB NEMOCK NUMBCK SEQSDX -C STNTBI STNTBIA -C THIS ROUTINE IS CALLED BY: CKTABA READDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR1 - CHARACTER*156 BORT_STR2 - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*80 CARD - CHARACTER*8 NEMO - CHARACTER*6 NUMB,NMB2 - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C INITIALIZE THE DICTIONARY TABLE CONTROL WORD PARTITION ARRAYS -C WITH APRIORI TABLE B AND D ENTRIES -C -------------------------------------------------------------- - - CALL DXINIT(LUN,1) - REWIND LUNDX - -C READ USER CARDS UNTIL THERE ARE NO MORE -C --------------------------------------- - -1 READ(LUNDX,'(A80)',END=200,ERR=200) CARD - -C REREAD IF NOT A DEFINITION CARD -C ------------------------------- - -c .... This is a comment line - IF(CARD(1: 1).EQ. '*') GOTO 1 -c .... This is a separation line - IF(CARD(3:10).EQ.'--------') GOTO 1 -c .... This is a blank line - IF(CARD(3:10).EQ.' ') GOTO 1 -c .... This is a header line - IF(CARD(3:10).EQ.'MNEMONIC') GOTO 1 -c .... This is a header line - IF(CARD(3:10).EQ.'TABLE D') GOTO 1 -c .... This is a header line - IF(CARD(3:10).EQ.'TABLE B') GOTO 1 - -C PARSE A DESCRIPTOR DEFINITION CARD -C ---------------------------------- - - IF(CARD(12:12).EQ.'|' .AND. CARD(21:21).EQ.'|') THEN - -c .... NEMO is the 8-character mnemonic name - NEMO = CARD(3:10) - IRET=NEMOCK(NEMO) - IF(IRET.EQ.-1) GOTO 900 - IF(IRET.EQ.-2) GOTO 901 - -c .... NUMB is the 6-character FXY value corresponding to NEMO - NUMB = CARD(14:19) - NMB2 = NUMB - IF(NMB2(1:1).EQ.'A') NMB2(1:1) = '3' - IRET=NUMBCK(NMB2) - IF(IRET.EQ.-1) GOTO 902 - IF(IRET.EQ.-2) GOTO 903 - IF(IRET.EQ.-3) GOTO 904 - IF(IRET.EQ.-4) GOTO 905 - -C TABLE A DESCRIPTOR FOUND -C ------------------------ - - IF(NUMB(1:1).EQ.'A') THEN - N = IGETNTBI ( LUN, 'A' ) - CALL STNTBIA ( N, LUN, NUMB, NEMO, CARD(23:) ) - IF ( IDNA(N,LUN,1) .EQ. 11 ) GOTO 906 -c .... Replace "A" with "3" so Table D descriptor will be found in -c .... card as well (see below) - NUMB(1:1) = '3' - ENDIF - -C TABLE B DESCRIPTOR FOUND -C ------------------------ - - IF(NUMB(1:1).EQ.'0') THEN - CALL STNTBI ( IGETNTBI(LUN,'B'), LUN, NUMB, NEMO, CARD(23:) ) - GOTO 1 - ENDIF - -C TABLE D DESCRIPTOR FOUND -C ------------------------ - - IF(NUMB(1:1).EQ.'3') THEN - CALL STNTBI ( IGETNTBI(LUN,'D'), LUN, NUMB, NEMO, CARD(23:) ) - GOTO 1 - ENDIF - -c .... First character of NUMB is not 'A', '0' or '3' - GOTO 902 - - ENDIF - -C PARSE A SEQUENCE DEFINITION CARD -C -------------------------------- - - IF(CARD(12:12).EQ.'|' .AND. CARD(19:19).NE.'|') THEN - CALL SEQSDX(CARD,LUN) - GOTO 1 - ENDIF - -C PARSE AN ELEMENT DEFINITION CARD -C -------------------------------- - - IF(CARD(12:12).EQ.'|' .AND. CARD(19:19).EQ.'|') THEN - CALL ELEMDX(CARD,LUN) - GOTO 1 - ENDIF - -C CAN'T FIGURE OUT WHAT KIND OF CARD IT IS -C ---------------------------------------- - - GOTO 907 - -C NORMAL ENDING -C ------------- - -200 CALL MAKESTAB - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY IS NOT'// - . ' BETWEEN 1 AND 8 CHARACTERS")') NEMO - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY HAS '// - . 'INVALID CHARACTERS")') NEMO - CALL BORT2(BORT_STR1,BORT_STR2) -902 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// - . 'DICTIONARY HAS AN INVALID FIRST CHARACTER (F VALUE) - MUST BE'// - . ' A, 0 OR 3")') NUMB - CALL BORT2(BORT_STR1,BORT_STR2) -903 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// - . 'DICTIONARY HAS NON-NUMERIC VALUES IN CHARACTERS 2-6 (X AND Y '// - . 'VALUES)")') NUMB - CALL BORT2(BORT_STR1,BORT_STR2) -904 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// - . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 2-3 (X VALUE) - '// - . 'MUST BE BETWEEN 00 AND 63")') NUMB - CALL BORT2(BORT_STR1,BORT_STR2) -905 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// - . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 4-6 (Y VALUE) - '// - . 'MUST BE BETWEEN 000 AND 255")') NUMB - CALL BORT2(BORT_STR1,BORT_STR2) -906 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"USER-DEFINED MESSAGE TYPE ""011"" IS '// - . 'RESERVED FOR DICTIONARY MESSAGES")') - CALL BORT2(BORT_STR1,BORT_STR2) -907 WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"THIS CARD HAS A BAD FORMAT - IT IS NOT '// - . 'RECOGNIZED BY THIS SUBROUTINE")') - CALL BORT2(BORT_STR1,BORT_STR2) - - END diff --git a/src/bufr/readdx.f b/src/bufr/readdx.f deleted file mode 100644 index 3cda41b506..0000000000 --- a/src/bufr/readdx.f +++ /dev/null @@ -1,147 +0,0 @@ - SUBROUTINE READDX(LUNIT,LUN,LUNDX) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE GENERATES INTERNAL ARRAYS CONTAINING BUFR -C DICTIONARY TABLES WHICH ARE NEEDED TO READ, WRITE, INITIALIZE OR -C APPEND A BUFR FILE. THE INFORMATION USED TO CREATE THE INTERNAL -C DICTIONARY TABLE ARRAYS (IN COMMON BLOCK /TABABD/) AND THE -C DICTIONARY MESSAGE CONTROL WORD PARTITION ARRAYS (IN COMMON BLOCK -C /MSGCWD/) (WHICH ARE ALWAYS THEN ASSOCIATED WITH THE BUFR FILE IN -C LUNIT) MAY COME FROM AN EXTERNAL, USER-SUPPLIED, BUFR DICTIONARY -C TABLE FILE IN CHARACTER FORMAT (I.E., A BUFR MNEMONIC TABLE), FROM -C THE BUFR FILE BEING ACTED UPON (IN WHICH CASE THE FILE MUST BE -C OPENED FOR INPUT PROCESSING AND POSITIONED AT A DICTIONARY TABLE -C MESSAGE SOMEWHERE IN THE FILE), OR FROM ANOTHER CURRENTLY OPENED -C AND DEFINED BUFR FILE. IN THIS LATTER CASE, THE BUFR FILE WOULD -C MOST LIKELY BE OPENED FOR INPUT, HOWEVER THERE IS NOTHING -C PREVENTING THE USE OF A FILE OPEN FOR OUTPUT AS LONG AS IT IS -C ASSOCIATED WITH INTERNAL DICTIONARY ARRAYS THAT CAN BE USED. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR FOR INFORMATIONAL -C PURPOSES -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL READDX (LUNIT, LUN, LUNDX) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C BEING READ, WRITTEN, INITIALIZED OR APPENDED -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) -C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING -C DICTIONARY TABLE INFORMATION TO BE USED IN READING/ -C WRITING FROM/TO LUNIT (DEPENDING ON THE CASE); MAY BE -C SET EQUAL TO LUNIT IF DICTIONARY TABLE INFORMATION IS -C ALREADY EMBEDDED IN LUNIT (BUT ONLY IF LUNIT IS BEING -C READ) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CPBFDX ERRWRT MAKESTAB -C RDBFDX RDUSDX STATUS -C THIS ROUTINE IS CALLED BY: OPENBF WRITDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /QUIET/ IPRT - - CHARACTER*128 ERRSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C GET THE BUFR STATUS OF UNIT LUNDX -C --------------------------------- - - CALL STATUS(LUNDX,LUD,ILDX,IMDX) - -C READ A DICTIONARY TABLE FROM THE INDICATED SOURCE -C ------------------------------------------------- - - IF (LUNIT.EQ.LUNDX) THEN -c .... Source is input BUFR file in LUNIT - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A)' ) - . 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', - . 'INPUT BUFR FILE IN UNIT ', LUNDX, ' INTO INTERNAL ARRAYS' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - CALL ERRWRT(' ') - ENDIF - REWIND LUNIT - CALL RDBFDX(LUNIT,LUN) - ELSEIF(ILDX.EQ.-1) THEN -c .... Source is input BUFR file in LUNDX -c .... BUFR file in LUNIT may be input or output - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A,A,I3)' ) - . 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', - . 'ARRAYS ASSOC. W/ INPUT UNIT ', LUNDX, ' TO THOSE ASSOC. ', - . 'W/ UNIT ', LUNIT - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - CALL ERRWRT(' ') - ENDIF - CALL CPBFDX(LUD,LUN) - CALL MAKESTAB - ELSEIF(ILDX.EQ.1) THEN -c .... Source is output BUFR file in LUNDX -c .... BUFR file in LUNIT may be input or output - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A,A,I3)' ) - . 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', - . 'ARRAYS ASSOC. W/ OUTPUT UNIT ', LUNDX, ' TO THOSE ASSOC. ', - . 'W/ UNIT ', LUNIT - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - CALL ERRWRT(' ') - ENDIF - CALL CPBFDX(LUD,LUN) - CALL MAKESTAB - ELSEIF(ILDX.EQ.0) THEN -c .... Source is user-supplied character table in LUNDX -c .... BUFR file in LUNIT may be input or output - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A)' ) - . 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', - . 'USER-SUPPLIED TEXT FILE IN UNIT ', LUNDX, - . ' INTO INTERNAL ARRAYS' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') - CALL ERRWRT(' ') - ENDIF - REWIND LUNDX - CALL RDUSDX(LUNDX,LUN) - ELSE - GOTO 900 - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: READDX - CANNOT DETERMINE SOURCE OF '// - . 'INPUT DICTIONARY TABLE') - END diff --git a/src/bufr/readerme.f b/src/bufr/readerme.f deleted file mode 100644 index c9186394db..0000000000 --- a/src/bufr/readerme.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE READERME(MESG,LUNIT,SUBSET,JDATE,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READERME -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1995-06-28 -C -C ABSTRACT: THIS SUBROUTINE READS INFORMATION FROM A BUFR DATA MESSAGE -C ALREADY IN MEMORY, PASSED IN AS AN INPUT ARGUMENT. IT IS SIMILAR -C TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG EXCEPT, INSTEAD OF -C READING BUFR MESSAGES DIRECTLY FROM A BUFR FILE THAT IS PHYSICALLY -C STORED ON THE LOCAL SYSTEM AND INTERFACED TO THE SOFTWARE VIA A -C LOGICAL UNIT NUMBER, IT READS BUFR MESSAGES DIRECTLY FROM A MEMORY -C ARRAY WITHIN THE APPLICATION PROGRAM ITSELF. THIS PROVIDES USERS -C WITH GREATER FLEXIBILITY FROM AN INPUT/OUTPUT PERSPECTIVE. -C READERME CAN BE USED IN ANY CONTEXT IN WHICH READMG MIGHT OTHERWISE -C BE USED. IF THIS MESSAGE IS NOT A BUFR MESSAGE, THEN AN -C APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1995-06-28 J. WOOLLEN -- ORIGINAL AUTHOR (FOR ERS DATA) -C 1997-07-29 J. WOOLLEN -- MODIFIED TO PROCESS GOES SOUNDINGS FROM -C NESDIS -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT; IMPROVED MACHINE PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI); INCREASED THE -C MAXIMUM NUMBER OF POSSIBLE DESCRIPTORS IN A -C SUBSET FROM 1000 TO 3000 -C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD -C BEEN REPLICATED IN THIS AND OTHER READ -C ROUTINES AND CONSOLIDATED IT INTO A NEW -C ROUTINE CKTABA, CALLED HERE, WHICH IS -C ENHANCED TO ALLOW COMPRESSED AND STANDARD -C BUFR MESSAGES TO BE READ (ROUTINE UNCMPS, -C WHICH HAD BEEN CALLED BY THIS AND OTHER -C ROUTINES IS NOW OBSOLETE AND HAS BEEN -C REMOVED FROM THE BUFRLIB; MAXIMUM MESSAGE -C LENGTH INCREASED FROM 10,000 TO 20,000 -C BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY -C TO EBCDIC MACHINES; MAXIMUM MESSAGE LENGTH -C INCREASED FROM 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE ICHKSTR -C 2009-03-23 D. KEYSER -- CALL BORT IN CASE OF MBAY OVERFLOW -C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; -C ADD LOGIC TO PROCESS DICTIONARY MESSAGES -C 2012-06-07 J. ATOR -- DON'T RESPOND TO DX TABLE MESSAGES IF -C SECTION 3 DECODING IS BEING USED -C -C USAGE: CALL READERME (MESG, LUNIT, SUBSET, JDATE, IRET) -C INPUT ARGUMENT LIST: -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = unrecognized Table A message type -C 11 = this is a BUFR table (dictionary) message -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CKTABA DXINIT ERRWRT -C ICHKSTR IDXMSG IUPBS3 LMSG -C MAKESTAB READS3 STATUS STBFDX -C WTSTAT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - COMMON /QUIET/ IPRT - - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*8 SUBSET,SEC0,TAMNEM - CHARACTER*1 CEC0(8) - - DIMENSION MESG(*),IEC0(2) - - DIMENSION IDRDM(NFILES) - - LOGICAL ENDTBL - - EQUIVALENCE (SEC0,IEC0,CEC0) - - DATA IDRDM/NFILES*0/ - SAVE IDRDM - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - CALL WTSTAT(LUNIT,LUN,IL, 1) - -C COPY THE INPUT MESSAGE INTO THE INTERNAL MESSAGE BUFFER -C ------------------------------------------------------- - - IEC0(1) = MESG(1) - IEC0(2) = MESG(2) - LNMSG = LMSG(SEC0) - IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 902 - DO I=1,LNMSG - MBAY(I,LUN) = MESG(I) - ENDDO - -C Confirm that the first 4 bytes of SEC0 contain 'BUFR' encoded in -C CCITT IA5 (i.e. ASCII). - - IF(ICHKSTR('BUFR',CEC0,4).NE.0) GOTO 903 - -C PARSE THE MESSAGE SECTION CONTENTS -C ---------------------------------- - - IF(ISC3(LUN).NE.0) CALL READS3(LUN) - - CALL CKTABA(LUN,SUBSET,JDATE,IRET) - - IF(ISC3(LUN).NE.0) RETURN - -C CHECK FOR A DX DICTIONARY MESSAGE -C --------------------------------- - -C A new DX dictionary table can be passed in as a consecutive set of -C DX dictionary messages. Each message should be passed in one at a -C time, via input argument MESG during consecutive calls to this -C subroutine, and will be processed as a single dictionary table up -C until the next message is passed in which either contains no data -C subsets or else is a non-DX dictionary message. - - ENDTBL = .FALSE. - - IF(IDXMSG(MBAY(1,LUN)).EQ.1) THEN - -C This is a DX dictionary message that was generated by the -C BUFRLIB archive library software. - - IF(IUPBS3(MBAY(1,LUN),'NSUB').EQ.0) THEN - -C But it doesn't contain any actual dictionary information, so -C assume we've reached the end of the dictionary table. - - IF(IDRDM(LUN).GT.0) THEN - ENDTBL = .TRUE. - ENDIF - ELSE - IF(IDRDM(LUN).EQ.0) THEN - -C This is the first DX dictionary message that is part of a -C new dictionary table. - - CALL DXINIT(LUN,0) - ENDIF - IDRDM(LUN) = IDRDM(LUN) + 1 - CALL STBFDX(LUN,MBAY(1,LUN)) - ENDIF - ELSE IF(IDRDM(LUN).GT.0) THEN - -C This is the first non-DX dictionary message received following a -C string of DX dictionary messages, so assume we've reached the -C end of the dictionary table. - - ENDTBL = .TRUE. - ENDIF - - IF(ENDTBL) THEN - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) - . 'BUFRLIB: READERME - STORED NEW DX TABLE CONSISTING OF (', - . IDRDM(LUN), ') MESSAGES;' - CALL ERRWRT(ERRSTR) - ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA '// - . 'MESSAGES UNTIL NEXT DX TABLE IS PASSED IN' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - IDRDM(LUN) = 0 - CALL MAKESTAB - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 WRITE(BORT_STR,'("BUFRLIB: READERME - INPUT BUFR MESSAGE LENGTH", - . 1X,I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")') - . LNMSG*NBYTW,MXMSGL - CALL BORT(BORT_STR) -903 CALL BORT('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD'// - . ' NOT "BUFR", DOES NOT CONTAIN BUFR DATA') - END diff --git a/src/bufr/readlc.f b/src/bufr/readlc.f deleted file mode 100644 index 2799cce5ec..0000000000 --- a/src/bufr/readlc.f +++ /dev/null @@ -1,193 +0,0 @@ - SUBROUTINE READLC(LUNIT,CHR,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READLC -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER DATA ELEMENT ASSOCIATED -C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER -C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS DESIGNED TO BE USED -C TO RETURN CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT -C BYTES. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY OR UNUSUAL THINGS HAPPEN -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C 2009-03-23 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES; -C ADDED CHECK FOR OVERFLOW OF CHR; ADDED '#' -C OPTION FOR MORE THAN ONE OCCURRENCE OF STR -C 2009-04-21 J. ATOR -- USE ERRWRT -C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS -C WHEN USED WITH '#' OCCURRENCE CODE -C -C USAGE: CALL READLC (LUNIT, CHR, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C STR - CHARACTER*(*): STRING (I.E., MNEMONIC) -C -C OUTPUT ARGUMENT LIST: -C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., -C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT PARSTR PARUTG -C STATUS UPC -C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP WRTREE -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST) - COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) - COMMON /UNPTYP/ MSGUNP(NFILES) - COMMON /QUIET / IPRT - - CHARACTER*(*) CHR,STR - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*10 TAG,CTAG,CRTAG - CHARACTER*14 TGS(10) - CHARACTER*3 TYP - REAL*8 VAL - - DATA MAXTG /10/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CHR = ' ' - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE) -C ------------------------------------------------------------------ - - CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) - IF(NTG.GT.1) GOTO 903 - -C Check if a specific occurrence of the input string was requested; -C if not, then the default is to return the first occurrence. - - CALL PARUTG(LUN,0,TGS(1),NNOD,KON,ROID) - IF(KON.EQ.6) THEN - IOID=NINT(ROID) - IF(IOID.LE.0) IOID = 1 - CTAG = ' ' - II = 1 - DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#')) - CTAG(II:II)=TGS(1)(II:II) - II = II + 1 - ENDDO - ELSE - IOID = 1 - CTAG = TGS(1)(1:10) - ENDIF - -C LOCATE AND DECODE THE LONG CHARACTER STRING -C ------------------------------------------- - - IF(MSGUNP(LUN).EQ.0.OR.MSGUNP(LUN).EQ.1) THEN - -C The message is uncompressed - - ITAGCT = 0 - DO N=1,NVAL(LUN) - NOD = INV(N,LUN) - IF(CTAG.EQ.TAG(NOD)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IOID) THEN - IF(ITP(NOD).NE.3) GOTO 904 - NCHR = NBIT(N)/8 - IF(NCHR.GT.LEN(CHR)) GOTO 905 - KBIT = MBIT(N) - CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT) - GOTO 100 - ENDIF - ENDIF - ENDDO - ELSEIF(MSGUNP(LUN).EQ.2) THEN - -C The message is compressed - - IF(NRST.GT.0) THEN - ITAGCT = 0 - DO II=1,NRST - IF(CTAG.EQ.CRTAG(II)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IOID) THEN - NCHR = IRNCH(II) - IF(NCHR.GT.LEN(CHR)) GOTO 905 - KBIT = IRBIT(II) - CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT) - GOTO 100 - ENDIF - ENDIF - ENDDO - ENDIF - ELSE - GOTO 906 - ENDIF - -C If we made it here, then we couldn't find the requested string. - - IF(IPRT.GE.0) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - ERRSTR = 'BUFRLIB: READLC - MNEMONIC ' // TGS(1) // - . ' NOT LOCATED IN REPORT SUBSET - RETURN WITH BLANK' // - . ' STRING FOR CHARACTER DATA ELEMENT' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 WRITE(BORT_STR,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// - . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'// - . 'I3,")")') STR,NTG - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// - . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') TGS(1),ITP(NOD) - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// - . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '// - . 'FOR ONLY",I4, " CHARACTERS")') TGS(1),NCHR,LEN(CHR) - CALL BORT(BORT_STR) -906 WRITE(BORT_STR,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'// - . '" IS NOT RECOGNIZED")') MSGUNP - CALL BORT(BORT_STR) - END diff --git a/src/bufr/readmg.f b/src/bufr/readmg.f deleted file mode 100644 index db14ddf738..0000000000 --- a/src/bufr/readmg.f +++ /dev/null @@ -1,184 +0,0 @@ - SUBROUTINE READMG(LUNXX,SUBSET,JDATE,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READMG -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL -C UNIT NUMBER ABS(LUNXX) INTO AN INTERNAL MESSAGE BUFFER (I.E. ARRAY -C MBAY IN COMMON BLOCK /BITBUF/). ABS(LUNXX) SHOULD ALREADY BE OPENED -C FOR INPUT OPERATIONS. IF LUNXX < 0, THEN A READ ERROR FROM -C ABS(LUNXX) IS TREATED THE SAME AS THE END-OF-FILE (EOF) CONDITION; -C OTHERWISE, BUFR ARCHIVE LIBRARY SUBROUTINE BORT IS NORMALLY CALLED -C IN SUCH SITUATIONS. ANY DX DICTIONARY MESSAGES ENCOUNTERED WITHIN -C ABS(LUNXX) ARE AUTOMATICALLY PROCESSED AND STORED INTERNALLY, SO A -C SUCCESSFUL RETURN FROM THIS SUBROUTINE WILL ALWAYS RESULT IN A BUFR -C MESSAGE CONTAINING ACTUAL DATA VALUES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-11-25 J. WOOLLEN -- MODIFIED TO EXIT GRACEFULLY WHEN THE BUFR -C FILE IS POSITIONED AFTER AN "END-OF-FILE" -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; MODIFIED TO MAKE Y2K -C COMPLIANT -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI); MODIFIED WITH -C SEMANTIC ADJUSTMENTS TO AMELIORATE COMPILER -C COMPLAINTS FROM LINUX BOXES (INCREASES -C PORTABILITY) -C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD -C BEEN REPLICATED IN THIS AND OTHER READ -C ROUTINES AND CONSOLIDATED IT INTO A NEW -C ROUTINE CKTABA, CALLED HERE, WHICH IS -C ENHANCED TO ALLOW COMPRESSED AND STANDARD -C BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE -C LENGTH INCREASED FROM 10,000 TO 20,000 -C BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT DATELEN (IT BECAME A -C SEPARATE ROUTINE IN THE BUFRLIB TO INCREASE -C PORTABILITY TO OTHER PLATFORMS) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- ADDED RDMSGW AND RDMSGB CALLS TO SIMULATE -C READIBM; ADDED LUNXX < 0 OPTION TO SIMULATE -C READFT -C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; -C ADD LOGIC TO PROCESS INTERNAL DICTIONARY -C MESSAGES -C 2012-06-07 J. ATOR -- DON'T RESPOND TO INTERNAL DICTIONARY -C MESSAGES IF SECTION 3 DECODING IS BEING USED -C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE; -C REMOVE CODE TO REREAD MESSAGE AS BYTES; -C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR -C -C USAGE: CALL READMG (LUNXX, SUBSET, JDATE, IRET) -C INPUT ARGUMENT LIST: -C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE (IF LUNXX IS LESS THAN ZERO, THEN READ -C ERRORS FROM ABS(LUNXX) ARE TREATED THE SAME AS EOF) -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more BUFR mesages in ABS(LUNXX) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CKTABA ERRWRT IDXMSG -C RDBFDX RDMSGW READS3 STATUS -C WTSTAT BACKBUFR -C THIS ROUTINE IS CALLED BY: IREADMG READNS RDMGSB REWNBF -C UFBINX UFBPOS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /QUIET / IPRT - - CHARACTER*128 ERRSTR - CHARACTER*8 SUBSET,TAMNEM - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - LUNIT = ABS(LUNXX) - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - CALL WTSTAT(LUNIT,LUN,IL,1) - -C READ A MESSAGE INTO THE INTERNAL MESSAGE BUFFER -C ----------------------------------------------- - -1 CALL RDMSGW(LUNIT,MBAY(1,LUN),IER) - IF(IER.EQ.-1) GOTO 200 - -C PARSE THE MESSAGE SECTION CONTENTS -C ---------------------------------- - - IF(ISC3(LUN).NE.0) CALL READS3(LUN) - CALL CKTABA(LUN,SUBSET,JDATE,IRET) - -C LOOK FOR A DICTIONARY MESSAGE -C ----------------------------- - - IF(IDXMSG(MBAY(1,LUN)).NE.1) RETURN - -C This is an internal dictionary message that was -C generated by the BUFRLIB archive library software. - - IF(ISC3(LUN).NE.0) RETURN - -C Section 3 decoding isn't being used, so backspace the -C file pointer and then use subroutine RDBFDX to read in -C all such dictionary messages (they should be stored -C consecutively!) and reset the internal tables. - - CALL BACKBUFR(LUN) - CALL RDBFDX(LUNIT,LUN) - - IF(IPRT.GE.1) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - ERRSTR = 'BUFRLIB: READMG - INTERNAL DICTIONARY MESSAGE READ;'// - .' ACCOUNT FOR IT THEN READ IN NEXT MESSAGE WITHOUT RETURNING' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C Now go read another message. - - GOTO 1 - -C EOF ON ATTEMPTED READ -C --------------------- - -200 CALL WTSTAT(LUNIT,LUN,IL,0) - INODE(LUN) = 0 - IDATE(LUN) = 0 - SUBSET = ' ' - JDATE = 0 - IRET = -1 - RETURN - -C EXITS -C ----- - -900 CALL BORT('BUFRLIB: READMG - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: READMG - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: READMG - ERROR READING A BUFR MESSAGE') - END diff --git a/src/bufr/readmm.f b/src/bufr/readmm.f deleted file mode 100644 index 8755075233..0000000000 --- a/src/bufr/readmm.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE READMM(IMSG,SUBSET,JDATE,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READMM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 -C -C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM -C INTERNAL MEMORY (ARRAY MSGS IN COMMON BLOCK /MSGMEM/) INTO A -C MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS -C IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE RDMEMM EXCEPT IT -C ADVANCES THE VALUE OF IMSG BY ONE PRIOR TO RETURNING TO CALLING -C PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2009-03-23 J. ATOR -- REWROTE TO CALL RDMEMM -C -C USAGE: CALL READMM (IMSG, SUBSET, JDATE, IRET) -C INPUT ARGUMENT LIST: -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C STORAGE -C -C OUTPUT ARGUMENT LIST: -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C STORAGE -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = IMSG is either zero or greater than the -C number of messages in memory -C -C REMARKS: -C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: RDMEMM -C THIS ROUTINE IS CALLED BY: IREADMM -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*8 SUBSET - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) - - IMSG = IMSG+1 - - RETURN - END diff --git a/src/bufr/readmt.f b/src/bufr/readmt.f deleted file mode 100644 index 708dfd79e1..0000000000 --- a/src/bufr/readmt.f +++ /dev/null @@ -1,256 +0,0 @@ - SUBROUTINE READMT ( IMT, IMTV, IOGCE, IMTVL ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READMT -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE OPENS AND READS BUFR MASTER TABLES AS -C SPECIFIED BY THE INPUT ARGUMENTS AND USING ADDITIONAL INFORMATION -C AS WAS DEFINED IN THE MOST RECENT CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE MTINFO (OR AS WAS DEFINED WITHIN BUFR ARCHIVE LIBRARY -C SUBROUTINE BFRINI, IF SUBROUTINE MTINFO WAS NEVER CALLED). -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL READMT ( IMT, IMTV, IOGCE, IMTVL ) -C INPUT ARGUMENT LIST: -C IMT - INTEGER: MASTER TABLE NUMBER -C IMTV - INTEGER: MASTER TABLE VERSION NUMBER -C IOGCE - INTEGER: ORIGINATING CENTER -C IMTVL - INTEGER: LOCAL TABLE VERSION NUMBER -C -C INPUT FILES: -C UNITS 98,99 - IF SUBROUTINE MTINFO WAS NEVER CALLED, THEN THESE -C LOGICAL UNIT NUMBERS ARE USED BY THIS ROUTINE FOR -C OPENING AND READING THE BUFR MASTER TABLES. -C ALTERNATIVELY, IF SUBROUTINE MTINFO WAS CALLED, -C THEN THE LOGICAL UNIT NUMBERS SPECIFIED IN THE -C MOST RECENT CALL TO MTINFO (ARGUMENTS LUNMT1 AND -C LUNMT2) ARE USED INSTEAD. -C REMARKS: -C THIS ROUTINE CALLS: BORT2 ERRWRT ICVIDX IGETTDI -C RDMTBB RDMTBD -C THIS ROUTINE IS CALLED BY: READS3 -C Not normally called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET/ IPRT - COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR - COMMON /MSTABS/ NMTB, IBFXYN(MXMTBB), CBSCL(MXMTBB), - . CBSREF(MXMTBB), CBBW(MXMTBB), - . CBUNIT(MXMTBB), CBMNEM(MXMTBB), - . CBELEM(MXMTBB), - . NMTD, IDFXYN(MXMTBD), CDSEQ(MXMTBD), - . CDMNEM(MXMTBD), NDELEM(MXMTBD), - . IDEFXY(MXMTBD*MAXCD), - . CDELEM(MXMTBD*MAXCD) - - DIMENSION IMFXYB(MXMTBB), IMFXYD(MXMTBD), - . NMELEM(MXMTBD), IEFXYN(MXMTBD,MAXCD) - CHARACTER*4 CMDSCB(MXMTBB), CMDSCD(MXMTBD), - . CBSCL, CMSCL(MXMTBB), - . CBBW, CMBW(MXMTBB) - CHARACTER*8 CBMNEM, CMMNMB(MXMTBB), - . CDMNEM, CMMNMD(MXMTBD) - CHARACTER*12 CBSREF, CMSREF(MXMTBB) - CHARACTER*14 CBUNIT, CMUNIT(MXMTBB) - CHARACTER*20 FMTF - CHARACTER*100 MTDIR - CHARACTER*120 CBELEM, CMELEM(MXMTBB), - . CDSEQ, CMSEQ(MXMTBD), - . CDELEM, CEELEM(MXMTBD,MAXCD) - CHARACTER*128 BORT_STR - CHARACTER*132 TBLFIL,STDFIL,LOCFIL1,LOCFIL2 - LOGICAL FOUND - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C* Reset the scratch table D index for this master table. - - ITMP = IGETTDI ( 0 ) - - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT(' ') - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT('BUFRLIB: READMT - OPENING/READING MASTER TABLES') - ENDIF - -C* Locate and open the master Table B files. There should be one -C* file of standard descriptors and one file of local descriptors. - -C* First locate and open the file of standard Table B descriptors. - - IF ( ( IMT .EQ. 0 ) .AND. ( IMTV .LE. 13 ) ) THEN - -C* For master table 0, version 13 is a superset of all earlier -C* versions. - - STDFIL = MTDIR(1:LMTD) // '/' // 'bufrtab.TableB_STD_0_13' - ELSE - WRITE ( FMTF, '(A,I1,A,I1,A)' ) - . '(2A,I', ISIZE(IMT), ',A,I', ISIZE(IMTV), ')' - WRITE ( STDFIL, FMTF ) MTDIR(1:LMTD), '/bufrtab.TableB_STD_', - . IMT, '_', IMTV - ENDIF - TBLFIL = STDFIL - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('Standard Table B:') - CALL ERRWRT(TBLFIL) - ENDIF - INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) - IF ( .NOT. FOUND ) GOTO 900 - OPEN ( UNIT = LUN1, FILE = TBLFIL, IOSTAT = IER ) - IF ( IER .NE. 0 ) GOTO 901 - -C* Now locate and open the file of local Table B descriptors. - -C* Use the local table corresponding to the originating center -C* and local table version number of the current message, if such -C* a table exists. Otherwise use the NCEP local table B. - - LOCFIL2 = MTDIR(1:LMTD) // '/' // 'bufrtab.TableB_LOC_0_7_1' - WRITE ( FMTF, '(A,I1,A,I1,A,I1,A)' ) - . '(2A,I', ISIZE(IMT), ',A,I', ISIZE(IOGCE), - . ',A,I', ISIZE(IMTVL), ')' - WRITE ( LOCFIL1, FMTF ) MTDIR(1:LMTD), '/bufrtab.TableB_LOC_', - . IMT, '_', IOGCE, '_', IMTVL - TBLFIL = LOCFIL1 - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('Local Table B:') - CALL ERRWRT(TBLFIL) - ENDIF - INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) - IF ( .NOT. FOUND ) THEN - -C* Use the NCEP local table B. - - TBLFIL = LOCFIL2 - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('Local Table B not found, so using:') - CALL ERRWRT(TBLFIL) - ENDIF - INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) - IF ( .NOT. FOUND ) GOTO 900 - ENDIF - OPEN ( UNIT = LUN2, FILE = TBLFIL, IOSTAT = IER ) - IF ( IER .NE. 0 ) GOTO 901 - -C* Read the master Table B files. - - CALL RDMTBB ( LUN1, LUN2, MXMTBB, - . IBMT, IBMTV, IBOGCE, IBLTV, - . NMTBB, IMFXYB, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNMB, CMDSCB, CMELEM ) - -C* Save the output into COMMON /MSTABS/. - - NMTB = NMTBB - DO I = 1, NMTB - IBFXYN(I) = IMFXYB(I) - CBSCL(I) = CMSCL(I) - CBSREF(I) = CMSREF(I) - CBBW(I) = CMBW(I) - CBUNIT(I) = CMUNIT(I) - CBMNEM(I) = CMMNMB(I) - CBELEM(I) = CMELEM(I) - ENDDO - -C* Close the master Table B files. - - CLOSE ( UNIT = LUN1 ) - CLOSE ( UNIT = LUN2 ) - -C* Locate and open the master Table D files. There should be one -C* file of standard descriptors and one file of local descriptors. - -C* First locate and open the file of standard Table D descriptors. - - TBLFIL = STDFIL - TBLFIL(LMTD+15:LMTD+15) = 'D' - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('Standard Table D:') - CALL ERRWRT(TBLFIL) - ENDIF - INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) - IF ( .NOT. FOUND ) GOTO 900 - OPEN ( UNIT = LUN1, FILE = TBLFIL, IOSTAT = IER ) - IF ( IER .NE. 0 ) GOTO 901 - -C* Now locate and open the file of local Table D descriptors. - -C* Use the local table corresponding to the originating center -C* and local table version number of the current message, if such -C* a table exists. Otherwise use the NCEP local table D. - - TBLFIL = LOCFIL1 - TBLFIL(LMTD+15:LMTD+15) = 'D' - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('Local Table D:') - CALL ERRWRT(TBLFIL) - ENDIF - INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) - IF ( .NOT. FOUND ) THEN - -C* Use the NCEP local table D. - - TBLFIL = LOCFIL2 - TBLFIL(LMTD+15:LMTD+15) = 'D' - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('Local Table D not found, so using:') - CALL ERRWRT(TBLFIL) - ENDIF - INQUIRE ( FILE = TBLFIL, EXIST = FOUND ) - IF ( .NOT. FOUND ) GOTO 900 - ENDIF - OPEN ( UNIT = LUN2, FILE = TBLFIL, IOSTAT = IER ) - IF ( IER .NE. 0 ) GOTO 901 - -C* Read the master Table D files. - - CALL RDMTBD ( LUN1, LUN2, MXMTBD, MAXCD, - . IDMT, IDMTV, IDOGCE, IDLTV, - . NMTBD, IMFXYD, CMMNMD, CMDSCD, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - -C* Save the output into COMMON /MSTABS/. - - NMTD = NMTBD - DO I = 1, NMTD - IDFXYN(I) = IMFXYD(I) - CDMNEM(I) = CMMNMD(I) - CDSEQ(I) = CMSEQ(I) - NDELEM(I) = NMELEM(I) - DO J = 1, NDELEM(I) - IDX = ICVIDX ( I-1, J-1, MAXCD ) + 1 - IDEFXY(IDX) = IEFXYN(I,J) - CDELEM(IDX) = CEELEM(I,J) - ENDDO - ENDDO - -C* Close the master Table D files. - - CLOSE ( UNIT = LUN1 ) - CLOSE ( UNIT = LUN2 ) - - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - RETURN -900 BORT_STR = 'BUFRLIB: READMT - COULD NOT FIND FILE:' - CALL BORT2(BORT_STR,TBLFIL) -901 BORT_STR = 'BUFRLIB: READMT - COULD NOT OPEN FILE:' - CALL BORT2(BORT_STR,TBLFIL) - END diff --git a/src/bufr/readns.f b/src/bufr/readns.f deleted file mode 100644 index 58b9b92e6c..0000000000 --- a/src/bufr/readns.f +++ /dev/null @@ -1,102 +0,0 @@ - SUBROUTINE READNS(LUNIT,SUBSET,JDATE,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READNS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT READS THE NEXT -C SUBSET FROM LOGICAL UNIT NUMBER LUNIT INTO INTERNAL SUBSET ARRAYS. -C BUFR MESSAGES IN LUNIT MAY BE EITHER COMPRESSED OR UNCOMPRESSED. -C THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY -C SUBROUTINES READMG AND READSB. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C -C USAGE: CALL READNS (LUNIT, SUBSET, JDATE, IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE -C CONTAINING SUBSET BEING READ -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE CONTAINING SUBSET BEING READ, IN FORMAT OF -C EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON DATELEN() -C VALUE -C IREADNS - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the BUFR file -C -C REMARKS: -C THIS ROUTINE CALLS: BORT READMG READSB STATUS -C THIS ROUTINE IS CALLED BY: IREADNS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - CHARACTER*10 TAG - CHARACTER*8 SUBSET - CHARACTER*3 TYP - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C REFRESH THE SUBSET AND JDATE PARAMETERS -C --------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - SUBSET = TAG(INODE(LUN)) - JDATE = IDATE(LUN) - -C READ THE NEXT SUBSET IN THE BUFR FILE -C ------------------------------------- - -1 CALL READSB(LUNIT,IRET) - IF(IRET.NE.0) THEN - CALL READMG(LUNIT,SUBSET,JDATE,IRET) - IF(IRET.EQ.0) GOTO 1 - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: READNS - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: READNS - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') - END diff --git a/src/bufr/reads3.f b/src/bufr/reads3.f deleted file mode 100644 index 760d4c75d7..0000000000 --- a/src/bufr/reads3.f +++ /dev/null @@ -1,243 +0,0 @@ - SUBROUTINE READS3 ( LUN ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READS3 -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE READS THE SECTION 3 DESCRIPTORS FROM THE -C BUFR MESSAGE IN MBAY(1,LUN). IT THEN USES THE BUFR MASTER TABLES -C TO GENERATE THE NECESSARY INFORMATION FOR THESE DESCRIPTORS WITHIN -C THE INTERNAL BUFR TABLE ARRAYS. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL READS3 (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT DXINIT ERRWRT -C IGETNTBI IGETTDI ISTDESC IUPBS01 -C MAKESTAB READMT STNTBIA STSEQ -C UPDS3 -C THIS ROUTINE IS CALLED BY: READERME READMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /QUIET/ IPRT - COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES),IRDMT - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM), - . IDCACH(MXCNEM,MAXNC) - - DIMENSION IDS3(MAXNC) - CHARACTER*6 CDS3(MAXNC),NUMB,ADN30 - - CHARACTER*8 CNEM,TAMNEM - CHARACTER*55 CSEQ - - CHARACTER*128 ERRSTR - - LOGICAL INCACH, ALLSTD - -C* Initializing the following value ensures that new master tables -C* are read during the first call to this subroutine. - - DATA LMT /-99/ - - SAVE LMT, LMTV, LOGCE, LMTVL, IREPCT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C* Unpack some Section 1 information from the message. - - IMT = IUPBS01 ( MBAY(1,LUN), 'BMT' ) - IMTV = IUPBS01 ( MBAY(1,LUN), 'MTV' ) - IOGCE = IUPBS01 ( MBAY(1,LUN), 'OGCE' ) - IMTVL = IUPBS01 ( MBAY(1,LUN), 'MTVL' ) - -C* Unpack the list of Section 3 descriptors from the message. - - CALL UPDS3 ( MBAY(1,LUN), MAXNC, CDS3, NCDS3 ) - DO II = 1, NCDS3 - IDS3(II) = IFXY( CDS3(II) ) - ENDDO - -C* Compare the master table and master table version numbers from -C* this message to those from the message that was processed during -C* the previous call to this subroutine. - - IF ( ( IMT .NE. LMT ) - . .OR. - . ( ( IMT .NE. 0 ) .AND. ( IMTV .NE. LMTV ) ) - . .OR. - . ( ( IMT .EQ. 0 ) .AND. ( IMTV .NE. LMTV ) .AND. - . ( ( IMTV .GT. 13 ) .OR. ( LMTV .GT. 13 ) ) ) ) - . THEN - -C* Either the master table number has changed -C* .OR. -C* The master table number hasn't changed, but it isn't 0, and -C* the table version number has changed -C* .OR. -C* The master table number hasn't changed and is 0, but the table -C* version number has changed, and at least one of the table -C* version numbers (i.e. the current or the previous) is greater -C* than 13 (which is the last version that was a superset of all -C* earlier versions of master table 0!) - -C* In any of these cases, we need to read in new tables and reset -C* the internal tables and local descriptor cache, since the -C* meanings of one or more Section 3 descriptors may have changed. - - CALL READMT ( IMT, IMTV, IOGCE, IMTVL ) - LMT = IMT - LMTV = IMTV - LOGCE = IOGCE - LMTVL = IMTVL - CALL DXINIT ( LUN, 0 ) - IREPCT = 0 - NCNEM = 0 - ELSE - -C* Check whether all of the Section 3 descriptors are standard. -C* If so, then the originating center and local table version -C* numbers are irrelevant as far as Section 3 is concerned. - - II = 1 - ALLSTD = .TRUE. - DO WHILE ( (ALLSTD) .AND. (II.LE.NCDS3) ) - IF ( ISTDESC(IDS3(II)) .EQ. 0 ) THEN - ALLSTD = .FALSE. - ELSE - II = II + 1 - ENDIF - ENDDO - IF ( .NOT. ALLSTD ) THEN - -C* There was at least one local (i.e. non-standard) descriptor, -C* so check whether the originating center and/or local table -C* version number are different than those from the message -C* that was processed during the previous call to this -C* subroutine. If so, then read in new tables and reset the -C* internal tables and local descriptor cache, since the -C* meanings of one or more local descriptors in Section 3 may -C* have changed. - - IF ( ( IOGCE .NE. LOGCE ) .OR. ( IMTVL .NE. LMTVL ) ) THEN - CALL READMT ( IMT, IMTV, IOGCE, IMTVL ) - LMT = IMT - LMTV = IMTV - LOGCE = IOGCE - LMTVL = IMTVL - CALL DXINIT ( LUN, 0 ) - IREPCT = 0 - NCNEM = 0 - ENDIF - ENDIF - ENDIF - -C* Is the list of Section 3 descriptors already in the cache? - -C* The cache is a performance-enhancing device which saves -C* time when the same descriptor sequences are encountered -C* over and over within the calling program. Time is saved -C* because the below calls to subroutines STSEQ and MAKESTAB -C* are bypassed whenever a list is already in the cache. - - INCACH = .FALSE. - IF ( NCNEM .GT. 0 ) THEN - II = 1 - DO WHILE ( (.NOT.INCACH) .AND. (II.LE.NCNEM) ) - IF ( NCDS3 .EQ. NDC(II) ) THEN - JJ = 1 - INCACH = .TRUE. - DO WHILE ( (INCACH) .AND. (JJ.LE.NCDS3) ) - IF ( IDS3(JJ) .EQ. IDCACH(II,JJ) ) THEN - JJ = JJ + 1 - ELSE - INCACH = .FALSE. - ENDIF - ENDDO - IF (INCACH) THEN - -C* The list is already in the cache, so store the -C* corresponding Table A mnemonic into COMMON /SC3BFR/ -C* and return. - - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // CNEM(II) - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - TAMNEM(LUN) = CNEM(II) - RETURN - ENDIF - ENDIF - II = II + 1 - ENDDO - ENDIF - -C* Get the next available index within the internal Table A. - - N = IGETNTBI ( LUN, 'A' ) - -C* Generate a Table A mnemonic and sequence description. - - WRITE ( TAMNEM(LUN), '(A5,I3.3)') 'MSTTB', N - CSEQ = 'TABLE A MNEMONIC ' // TAMNEM(LUN) - -C* Store the Table A mnemonic and sequence into the cache. - - NCNEM = NCNEM + 1 - IF ( NCNEM .GT. MXCNEM ) GOTO 900 - CNEM(NCNEM) = TAMNEM(LUN) - NDC(NCNEM) = NCDS3 - DO JJ = 1, NCDS3 - IDCACH(NCNEM,JJ) = IDS3(JJ) - ENDDO - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' // - . CNEM(NCNEM) - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C* Get an FXY value to use with this Table A mnemonic. - - IDN = IGETTDI ( LUN ) - NUMB = ADN30 ( IDN, 6 ) - -C* Store all of the information for this mnemonic within the -C* internal Table A. - - CALL STNTBIA ( N, LUN, NUMB, TAMNEM(LUN), CSEQ ) - -C* Store all of the information for this sequence within the -C* internal Tables B and D. - - CALL STSEQ ( LUN, IREPCT, IDN, TAMNEM(LUN), CSEQ, IDS3, NCDS3 ) - -C* Update the jump/link table. - - CALL MAKESTAB - - RETURN -900 CALL BORT('BUFRLIB: READS3 - MXCNEM OVERFLOW') - END diff --git a/src/bufr/readsb.f b/src/bufr/readsb.f deleted file mode 100644 index 421ea781a4..0000000000 --- a/src/bufr/readsb.f +++ /dev/null @@ -1,130 +0,0 @@ - SUBROUTINE READSB(LUNIT,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: READSB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT READS A SUBSET FROM -C A BUFR MESSAGE INTO INTERNAL SUBSET ARRAYS. THE BUFR MESSAGE MUST -C HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE -C LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED -C OR UNCOMPRESSED. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- ADDED CALL TO NEW ROUTINE RDCMPS ALLOWING -C SUBSETS TO NOW BE DECODED FROM COMPRESSED -C BUFR MESSAGES; MAXIMUM MESSAGE LENGTH -C INCREASED FROM 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- CORRECTED ERROR RELATING TO CERTAIN -C FOREIGN FILE TYPES; REMOVED OLD CRAY -C COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C -C USAGE: CALL READSB (LUNIT, IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the BUFR -C message -C -C REMARKS: -C THIS ROUTINE CALLS: BORT RDCMPS RDTREE STATUS -C UPB -C THIS ROUTINE IS CALLED BY: COPYSB IREADSB RDMEMS READNS -C RDMSGB UFBINX UFBPOS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /UNPTYP/ MSGUNP(NFILES) - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) THEN - IRET = -1 - GOTO 100 - ENDIF - -C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE -C --------------------------------------------- - - IF(NSUB(LUN).EQ.MSUB(LUN)) THEN - IRET = -1 - GOTO 100 - ELSE - NSUB(LUN) = NSUB(LUN) + 1 - ENDIF - -C READ THE NEXT SUBSET AND RESET THE POINTERS -C ------------------------------------------- - - IF(MSGUNP(LUN).EQ.0) THEN - IBIT = MBYT(LUN)*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - CALL RDTREE(LUN) - MBYT(LUN) = MBYT(LUN) + NBYT - ELSEIF(MSGUNP(LUN).EQ.1) THEN -c .... message with "standard" Section 3 - IBIT = MBYT(LUN) - CALL RDTREE(LUN) - MBYT(LUN) = IBIT - ELSEIF(MSGUNP(LUN).EQ.2) THEN -c .... compressed message - CALL RDCMPS(LUN) - ELSE - GOTO 902 - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') -902 WRITE(BORT_STR,'("BUFRLIB: READSB - MESSAGE UNPACK TYPE",I3,"IS'// - . ' NOT RECOGNIZED")') MSGUNP - CALL BORT(BORT_STR) - END diff --git a/src/bufr/restd.c b/src/bufr/restd.c deleted file mode 100644 index 300ea8c340..0000000000 --- a/src/bufr/restd.c +++ /dev/null @@ -1,139 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RESTD -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF A LOCAL -C (I.E. NON-STANDARD) TABLE D DESCRIPTOR, THIS ROUTINE RETURNS -C AN EQUIVALENT LIST OF STANDARDIZED CHILD DESCRIPTORS. ANY CHILD -C DESCRIPTORS WHICH ARE THEMSELVES LOCAL TABLE D DESCRIPTORS ARE -C AUTOMATICALLY RESOLVED VIA A RECURSIVE CALL TO THIS SAME ROUTINE. -C THE RECURSIVE PROCESS CONTINUES UNTIL ALL CHILD DESCRIPTORS ARE -C EITHER WMO-STANDARD DESCRIPTORS (I.E. FROM TABLE B, TABLE C, OR -C TABLE D, OR REPLICATION DESCRIPTORS) OR ELSE ARE LOCAL TABLE B -C DESCRIPTORS, IN WHICH CASE THEY ARE PRECEDED WITH AN APPROPRIATE -C 206YYY TABLE C OPERATOR IN THE OUTPUT LIST. IN ANY EVENT, THE -C FINAL OUTPUT LIST OF EQUIVALENT CHILD DESCRIPTORS IS USABLE BY -C ANY STANDARD BUFR DECODER PROGRAM IN ORDER TO INTERPRET THE SAME -C DATA VALUES AS WERE REPRESENTED BY THE INITIAL LOCAL TABLE D -C DESCRIPTOR THAT WAS INPUT. -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C 2012-04-30 J. ATOR -- USE LONG CAST FOR IBIT IN SPRINTF STMT -C -C USAGE: CALL RESTD( LUN, TDDESC, NCTDDESC, CTDDESC ) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C TDDESC - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE FOR -C LOCAL TABLE D DESCRIPTOR -C -C OUTPUT ARGUMENT LIST: -C NCTDDESC - INTEGER: NUMBER OF STANDARDIZED CHILD DESCRIPTORS -C RETURNED IN CTDDESC -C CTDDESC - INTEGER: ARRAY OF STANDARDIZED CHILD DESCRIPTORS -C -C REMARKS: -C THIS ROUTINE CALLS: RESTD NUMTBD NEMTBB IFXY -C CADN30 ISTDESC WRDESC UPTDD -C THIS ROUTINE IS CALLED BY: RESTD STNDRD -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -void restd( f77int *lun, f77int *tddesc, f77int *nctddesc, f77int ctddesc[] ) -{ - f77int i0 = 0; - - f77int desc, ncdesc, cdesc[MAXNC]; - f77int i, j, inum, itbd, ictbd; - f77int iscl, iref, ibit; - - char tab, nemo[9], adn[7], cunit[25]; - -/* -** How many child descriptors does *tddesc have? -*/ - numtbd( lun, tddesc, nemo, &tab, &itbd, 9, 1 ); - uptdd( &itbd, lun, &i0, &inum ); - - *nctddesc = 0; -/* -** Examine each child descriptor one at a time. -*/ - for ( i = 1; i <= inum; i++ ) { - uptdd( &itbd, lun, &i, &desc ); - if (! istdesc( &desc ) ) { -/* -** desc is a local descriptor. -*/ - numtbd( lun, &desc, nemo, &tab, &ictbd, 9, 1 ); - if ( tab == 'D' ) { -/* -** desc is itself a local Table D descriptor, so resolve -** it now via a recursive call to this same routine. -*/ - restd( lun, &desc, &ncdesc, cdesc ); - - if ( ( *nctddesc > 0 ) && - ( ctddesc[(*nctddesc)-1] > ifxy( "101000", 6 ) ) && - ( ctddesc[(*nctddesc)-1] <= ifxy( "101255", 6 ) ) ) { -/* -** desc is replicated using fixed replication, so write -** the number of child descriptors into the X value of -** the replication descriptor ctddesc[(*nctddesc)-1] -*/ - cadn30( &ctddesc[(*nctddesc)-1], adn, 7 ); - sprintf( adn, "%c%02ld%c%c%c", - adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); - ctddesc[(*nctddesc)-1] = ifxy( adn, 7 ); - } - else if ( ( *nctddesc > 1 ) && - ( ctddesc[(*nctddesc)-2] == ifxy( "101000", 6 ) ) ) { -/* -** desc is replicated using delayed replication, so write -** the number of child descriptors into the X value of -** the replication descriptor ctddesc[(*nctddesc)-2] -*/ - cadn30( &ctddesc[(*nctddesc)-2], adn, 7 ); - sprintf( adn, "%c%02ld%c%c%c", - adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); - ctddesc[(*nctddesc)-2] = ifxy( adn, 7 ); - } -/* -** Add the child descriptors to the output list. -*/ - for ( j = 0; j < ncdesc; j++ ) { - wrdesc( cdesc[j], ctddesc, nctddesc ); - } - - } - else if ( tab == 'B' ) { -/* -** desc is a local Table B descriptor, so precede it with -** a 206YYY operator in the output list. -*/ - nemtbb( lun, &ictbd, cunit, &iscl, &iref, &ibit, 25 ); - sprintf( adn, "%c%c%c%03ld", '2', '0', '6', (long) ibit ); - wrdesc( ifxy( adn, 7 ), ctddesc, nctddesc ); - wrdesc( desc, ctddesc, nctddesc ); - } - } - else { -/* -** desc is a standard Table B, Table D, operator or replicator -** descriptor, so append it "as is" to the output list. -*/ - wrdesc( desc, ctddesc, nctddesc ); - } - } - - return; -} diff --git a/src/bufr/rewnbf.f b/src/bufr/rewnbf.f deleted file mode 100644 index 69cb463582..0000000000 --- a/src/bufr/rewnbf.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE REWNBF(LUNIT,ISR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: REWNBF -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE, DEPENDING ON THE VALUE OF ISR, WILL -C EITHER: -C 1) STORE THE CURRENT PARAMETERS ASSOCIATED WITH A BUFR FILE -C CONNECTED TO LUNIT (READ/WRITE POINTERS, ETC.), SET THE FILE STATUS -C TO READ, THEN REWIND THE BUFR FILE AND POSITION IT SUCH THAT THE -C NEXT BUFR MESSAGE READ WILL BE THE FIRST MESSAGE IN THE FILE -C CONTAINING ACTUAL SUBSETS WITH DATA; OR -C 2) RESTORE THE BUFR FILE CONNECTED TO LUNIT TO THE PARAMETERS -C IT HAD PRIOR TO 1) ABOVE USING THE INFORMATION SAVED IN 1) ABOVE. -C -C THIS ALLOWS INFORMATION TO BE EXTRACTED FROM A PARTICULAR SUBSET IN -C A BUFR FILE WHICH IS IN THE MIDST OF BEING READ FROM OR WRITTEN TO -C BY AN APPLICATION PROGRAM. NOTE THAT FOR A PARTICULAR BUFR FILE 1) -C ABOVE MUST PRECEDE 2) ABOVE. AN APPLICATION PROGRAM MIGHT FIRST -C CALL THIS SUBROUTINE WITH ISR = 0, THEN CALL EITHER BUFR ARCHIVE -C LIBRARY SUBROUTINE RDMGSB OR UFBINX TO GET INFO FROM A SUBSET, THEN -C CALL THIS ROUTINE AGAIN WITH ISR = 1 TO RESTORE THE POINTERS IN THE -C BUFR FILE TO THEIR ORIGINAL LOCATION. ALSO, BUFR ARCHIVE LIBRARY -C SUBROUTINE UFBTAB WILL CALL THIS ROUTINE IF THE BUFR FILE IT IS -C ACTING UPON IS ALREADY OPEN FOR INPUT OR OUTPUT. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION -C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION -C VERSION AT ONE TIME AND THEN REMOVED) -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE -C (DICTIONARY) MESSAGES -C 2011-09-26 J. WOOLLEN -- FIXED BUG TO PREVENT SKIP OF FIRST DATA -C MESSAGE AFTER REWIND -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C REPLACE FORTRAN REWIND WITH C CEWIND -C -C USAGE: CALL REWNBF (LUNIT, ISR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C ISR - INTEGER: SWITCH: -C 0 = store current parameters associated with -C BUFR file, set file status to read, rewind -C file such that next message read is first -C message containing subset data -C 1 = restore BUFR file with parameters saved -C from the previous call to this routine with -C ISR=0 -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT I4DY READMG STATUS -C WTSTAT CEWIND -C THIS ROUTINE IS CALLED BY: UFBINX UFBTAB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /BUFRSR/ JUNN,JILL,JIMM,JBIT,JBYT,JMSG,JSUB,KSUB,JNOD,JDAT, - . JSR(NFILES),JBAY(MXMSGLD4) - - CHARACTER*128 BORT_STR - - CHARACTER*8 SUBSET - - DIMENSION MESG(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C TRY TO TRAP BAD CALL PROBLEMS -C ----------------------------- - - IF(ISR.EQ.0) THEN - CALL STATUS(LUNIT,LUN,IL,IM) - IF(JSR(LUN).NE.0) GOTO 900 - IF(IL.EQ.0) GOTO 901 - ELSEIF(ISR.EQ.1) THEN - LUN = JUNN - IF(JSR(JUNN).NE.1) GOTO 902 - ELSE - GOTO 903 - ENDIF - -C STORE FILE PARAMETERS AND SET FOR READING -C ----------------------------------------- - - IF(ISR.EQ.0) THEN - JUNN = LUN - JILL = IL - JIMM = IM - JBIT = IBIT - JBYT = MBYT(LUN) - JMSG = NMSG(LUN) - JSUB = NSUB(LUN) - KSUB = MSUB(LUN) - JNOD = INODE(LUN) - JDAT = IDATE(LUN) - DO I=1,JBYT - JBAY(I) = MBAY(I,LUN) - ENDDO - CALL WTSTAT(LUNIT,LUN,-1,0) - ENDIF - -C REWIND THE FILE -C --------------- - - call cewind(lun) - -C RESTORE FILE PARAMETERS AND POSITION IT TO WHERE IT WAS SAVED -C ------------------------------------------------------------- - - IF(ISR.EQ.1) THEN - LUN = JUNN - IL = JILL - IM = JIMM - IBIT = JBIT - MBYT(LUN) = JBYT - NMSG(LUN) = JMSG - NSUB(LUN) = JSUB - MSUB(LUN) = KSUB - INODE(LUN) = JNOD - IDATE(LUN) = I4DY(JDAT) - DO I=1,JBYT - MBAY(I,LUN) = JBAY(I) - ENDDO - DO IMSG=1,JMSG - CALL READMG(LUNIT,SUBSET,KDATE,IER) - IF(IER.LT.0) GOTO 905 - ENDDO - CALL WTSTAT(LUNIT,LUN,IL,IM) - ENDIF - - JSR(LUN) = MOD(JSR(LUN)+1,2) - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// - . 'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED '// - . '(AND NOT YET RESTORED) (UNIT",I3,")")') LUNIT - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// - . 'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT'// - . ' OR OUTPUT) (UNIT",I3,")")') LUNIT - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// - . 'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') - . LUNIT - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '// - . 'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")') - . ISR,LUNIT - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// - . 'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE '// - . 'NO.",I5)') LUNIT,JMSG - CALL BORT(BORT_STR) - END diff --git a/src/bufr/rjust.f b/src/bufr/rjust.f deleted file mode 100644 index 003d166fa8..0000000000 --- a/src/bufr/rjust.f +++ /dev/null @@ -1,54 +0,0 @@ - FUNCTION RJUST(STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RJUST -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION RIGHT JUSTIFIES A CHARACTER STRING. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: RJUST (STR) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING TO BE RIGHT-JUSTIFED -C -C OUTPUT ARGUMENT LIST: -C STR - CHARACTER*(*): RIGHT-JUSTIFIED STRING -C RJUST - REAL: ALWAYS RETURNED AS 0 (DUMMY) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: SNTBBE UFBDMP UFDUMP VALX -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - RJUST = 0. - IF(STR.EQ.' ') GOTO 100 - LSTR = LEN(STR) - DO WHILE(STR(LSTR:LSTR).EQ.' ') - DO I=LSTR,2,-1 - STR(I:I) = STR(I-1:I-1) - ENDDO - STR(1:1) = ' ' - ENDDO - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/rsvfvm.f b/src/bufr/rsvfvm.f deleted file mode 100644 index bbb40d6aec..0000000000 --- a/src/bufr/rsvfvm.f +++ /dev/null @@ -1,67 +0,0 @@ - SUBROUTINE RSVFVM(NEM1,NEM2) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RSVFVM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE STEPS THROUGH THE "FOLLOWING VALUE" -C MNEMONIC NEM1 AND, FOR EACH "." CHARACTER ENCOUNTERED (EXCEPT FOR -C THE INITIAL ONE), OVERWRITES IT WITH THE NEXT CORRESPONDING -C CHARACTER FROM NEM2 (SEE REMARKS). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C -C USAGE: CALL RSVFVM (NEM1, NEM2) -C INPUT ARGUMENT LIST: -C NEM1 - CHARACTER*8: "FOLLOWING VALUE" MNEMONIC -C NEM2 - CHARACTER*8: MNEMONIC IMMEDIATELY FOLLOWING NEM1 -C WITHIN USER DICTIONARY TABLE -C -C OUTPUT ARGUMENT LIST: -C NEM1 - CHARACTER*8: COPY OF INPUT NEM1 WITH ALL "." -C CHARACTERS (EXCEPT INITIAL ONE) OVERWRITTEN WITH -C CORRESPONDING CHARACTERS FROM NEM2 -C -C REMARKS: -C FOR EXAMPLE: -C if, on input: NEM1 = ".DTH...." -C NEM2 = "MXTM " -C then, on output: NEM1 = ".DTHMXTM" -C -C -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: NEMTBD SEQSDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*8 NEM1,NEM2 - - DO I=1,LEN(NEM1) - IF(I.EQ.1) THEN - -C Skip initial "." and initialize J. - - J = 1 - ELSE - IF(NEM1(I:I).EQ.'.') THEN - NEM1(I:I) = NEM2(J:J) - J = J+1 - ENDIF - ENDIF - ENDDO - - RETURN - END diff --git a/src/bufr/rtrcpt.f b/src/bufr/rtrcpt.f deleted file mode 100644 index 507f5dfe5c..0000000000 --- a/src/bufr/rtrcpt.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE RTRCPT(LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: RTRCPT -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE RETURNS THE TANK RECEIPT TIME STORED WITHIN -C SECTION 1 OF THE BUFR MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO -C BUFR ARCHIVE LIBRARY SUBROUTINE READMG, READMM OR EQUIVALENT. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL RTRCPT (LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C IYR - INTEGER: TANK RECEIPT YEAR -C IMO - INTEGER: TANK RECEIPT MONTH -C IDY - INTEGER: TANK RECEIPT DAY -C IHR - INTEGER: TANK RECEIPT HOUR -C IMI - INTEGER: TANK RECEIPT MINUTE -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = no tank receipt time was present within the -C BUFR message currently open for input -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IUPB IUPBS01 STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = -1 - -C Check the file status. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C Check whether the message contains a tank receipt time. - - IF(IUPBS01(MBAY(1,LUN),'BEN').EQ.4) THEN - IS1BYT = 23 - ELSE - IS1BYT = 19 - ENDIF - IF( (IS1BYT+5) .GT. IUPBS01(MBAY(1,LUN),'LEN1') ) RETURN - -C Unpack the tank receipt time. - -C Note that IS1BYT is a starting byte number relative to the -C beginning of Section 1, so we still need to account for -C Section 0 when specifying the actual byte numbers to unpack -C within the overall message. - - IMGBYT = IS1BYT + IUPBS01(MBAY(1,LUN),'LEN0') - - IYR = IUPB(MBAY(1,LUN),IMGBYT,16) - IMO = IUPB(MBAY(1,LUN),IMGBYT+2,8) - IDY = IUPB(MBAY(1,LUN),IMGBYT+3,8) - IHR = IUPB(MBAY(1,LUN),IMGBYT+4,8) - IMI = IUPB(MBAY(1,LUN),IMGBYT+5,8) - - IRET = 0 - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT; IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE; NONE ARE') - END diff --git a/src/bufr/seqsdx.f b/src/bufr/seqsdx.f deleted file mode 100644 index e95e5af09b..0000000000 --- a/src/bufr/seqsdx.f +++ /dev/null @@ -1,253 +0,0 @@ - SUBROUTINE SEQSDX(CARD,LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SEQSDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION -C FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A -C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY -C BUFR ARCHIVE LIBRARY SUBROUTINE RDUSDX. THESE ARE THEN ADDED TO -C THE ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX) -C WITHIN THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN COMMON BLOCK -C /TABABD/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C -C USAGE: CALL SEQSDX (CARD, LUN) -C INPUT ARGUMENT LIST: -C CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ -C FROM A USER-SUPPLIED BUFR DICTIONARY TABLE -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT2 NEMOCK NEMTAB -C PARSTR PKTDD RSVFVM STRNUM -C THIS ROUTINE IS CALLED BY: RDUSDX -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) - - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*80 CARD,SEQS - CHARACTER*12 ATAG,TAGS(250) - CHARACTER*8 NEMO,NEMA,NEMB - CHARACTER*6 ADN30,CLEMON - CHARACTER*3 TYPS - CHARACTER*1 REPS,TAB - - DATA MAXTGS /250/ - DATA MAXTAG /12/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING -C -------------------------------------------------------------- - - NEMO = CARD( 3:10) - SEQS = CARD(14:78) - -C Note that an entry for this mnemonic should already exist within -C the internal BUFR Table D array TABD(*,LUN); this entry should -C have been created by subroutine RDUSDX when the mnemonic and its -C associated FXY value and description were initially defined -C within a card read from the "Descriptor Definition" section at -C the top of the user-supplied BUFR dictionary table in character -C format. Now, we need to retrieve the positional index for that -C entry within TABD(*,LUN) so that we can access the entry and then -C add the decoded sequence information to it. - - CALL NEMTAB(LUN,NEMO,IDN,TAB,ISEQ) - IF(TAB.NE.'D') GOTO 900 - CALL PARSTR(SEQS,TAGS,MAXTGS,NTAG,' ',.TRUE.) - IF(NTAG.EQ.0 ) GOTO 901 - - DO N=1,NTAG - ATAG = TAGS(N) - IREP = 0 - -C CHECK FOR REPLICATOR -C -------------------- - - DO I=1,5 - IF(ATAG(1:1).EQ.REPS(I,1)) THEN - -C Note that REPS(*,*), which contains all of the symbols used to -C denote all of the various replication schemes that are -C possible within a user-supplied BUFR dictionary table in -C character format, was previously defined within subroutine -C BFRINI. - - DO J=2,MAXTAG - IF(ATAG(J:J).EQ.REPS(I,2)) THEN - IF(J.EQ.MAXTAG) GOTO 902 - -C Note that subroutine STRNUM will return NUMR = 0 if the -C string passed to it contains all blanks (as *should* be the -C case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or -C 5 '<' '>'). - -C However, when I = 1 '"' '"', then subroutine STRNUM will -C return NUMR = (the number of replications for the mnemonic -C using F=1 "regular" (i.e. non-delayed) replication). - - CALL STRNUM(ATAG(J+1:MAXTAG),NUMR) - IF(I.EQ.1 .AND. NUMR.LE.0 ) GOTO 903 - IF(I.EQ.1 .AND. NUMR.GT.255) GOTO 904 - IF(I.NE.1 .AND. NUMR.NE.0 ) GOTO 905 - ATAG = ATAG(2:J-1) - IREP = I - GOTO 1 - ENDIF - ENDDO - GOTO 902 - ENDIF - ENDDO - -C CHECK FOR VALID TAG -C ------------------- - -1 IRET=NEMOCK(ATAG) - IF(IRET.EQ.-1) GOTO 906 - IF(IRET.EQ.-2) GOTO 907 - CALL NEMTAB(LUN,ATAG,IDN,TAB,IRET) - IF(IRET.GT.0) THEN - -C Note that the next code line checks that we are not trying to -C replicate a Table B mnemonic (which is currently not allowed). -C The logic works because, for replicated mnemonics, IREP = I = -C (the index within REPS(*,*) of the symbol associated with the -C type of replication in question (e.g. "{, "<", etc.)) - - IF(TAB.EQ.'B' .AND. IREP.NE.0) GOTO 908 - IF(ATAG(1:1).EQ.'.') THEN - -C This mnemonic is a "following value" mnemonic -C (i.e. it relates to the mnemonic that immediately -C follows it within the user-supplied character-format BUFR -C dictionary table sequence), so confirm that it contains, as -C a substring, this mnemonic that immediately follows it. - - NEMB = TAGS(N+1) -c .... get NEMA from IDN - CALL NUMTAB(LUN,IDN,NEMA,TAB,ITAB) - CALL NEMTAB(LUN,NEMB,JDN,TAB,IRET) - CALL RSVFVM(NEMA,NEMB) - IF(NEMA.NE.ATAG) GOTO 909 -c .... DK: I don't think the next test can ever be satisfied -c .... should probably be IF(N.EQ.NTAG ) GOTO 910 - IF(N.GT.NTAG ) GOTO 910 - IF(TAB.NE.'B') GOTO 911 - ENDIF - ELSE - GOTO 912 - ENDIF - -C WRITE THE DESCRIPTOR STRING INTO TABD ARRAY -C ------------------------------------------- -c .... first look for a replication descriptor - IF(IREP.GT.0) CALL PKTDD(ISEQ,LUN,IDNR(IREP,1)+NUMR,IRET) - IF(IRET.LT.0) GOTO 913 - CALL PKTDD(ISEQ,LUN,IDN,IRET) - IF(IRET.LT.0) GOTO 914 - - ENDDO - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '// - . '(UNDEFINED, TAB=",A,")")') NEMO,TAB - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// - . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') NEMO - CALL BORT2(BORT_STR1,BORT_STR2) -902 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// - . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') NEMO,TAGS(N) - CALL BORT2(BORT_STR1,BORT_STR2) -903 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// - . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'// - . ' 2ND QUOTE")') NEMO,TAGS(N),NUMR - CALL BORT2(BORT_STR1,BORT_STR2) -904 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// - . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '// - . '255")') NEMO,TAGS(N),NUMR - CALL BORT2(BORT_STR1,BORT_STR2) -905 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'// - . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'// - . 'NO")') NEMO,TAGS(N),NUMR - CALL BORT2(BORT_STR1,BORT_STR2) -906 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// - .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")') - . NEMO,TAGS(N) - CALL BORT2(BORT_STR1,BORT_STR2) -907 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// - . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') NEMO,TAGS(N) - CALL BORT2(BORT_STR1,BORT_STR2) -908 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// - . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")') - . NEMO,TAGS(N) - CALL BORT2(BORT_STR1,BORT_STR2) -909 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '// - . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")') - . NEMO,TAGS(N),NEMA - CALL BORT2(BORT_STR1,BORT_STR2) -910 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '// - . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '// - . 'STRING")') NEMO,NEMA - CALL BORT2(BORT_STR1,BORT_STR2) -911 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'// - . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '// - . 'ENTRY")') NEMO,NEMB - CALL BORT2(BORT_STR1,BORT_STR2) -912 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// - . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")') - . NEMO,TAGS(N) - CALL BORT2(BORT_STR1,BORT_STR2) -913 CLEMON = ADN30(IDNR(IREP,1)+NUMR,6) - WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// - . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '// - . 'WARNING MSG")') NEMO,CLEMON - CALL BORT2(BORT_STR1,BORT_STR2) -914 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD - WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// - . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '// - . 'WARNING MSG")') NEMO,TAGS(N) - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/setblock.f b/src/bufr/setblock.f deleted file mode 100644 index ac5ede8900..0000000000 --- a/src/bufr/setblock.f +++ /dev/null @@ -1,47 +0,0 @@ - SUBROUTINE SETBLOCK(IBLK) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SETBLOCK -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 -C -C ABSTRACT: SUBROUTINE SETBLOCK ALLOWS APPLICATIONS TO DEFINE WHAT -C SORT OF OUTPUT FILE BLOCKING (IEEE RECORD CONTROL WORDS) -C ARE APPLIED TO BUFR RECORDS WRITTEN FROM THE BUFRLIB -C ROUTINES. THE DEFAULT IS NONE (PURE BUFR). OTHER OPTIONS -C ARE BIG OR LITTLE ENDIAN. -C -C PROGRAM HISTORY LOG: -C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR -C -C USAGE: CALL SETBLOCK(IBLK) -C -C INPUT ARGUMENTS: -C IBLK - INTEGER BLOCK TYPE INDICATOR -C -1 LITTLE ENDIAN RECORD CONTROL WORDS -C 0 NO RECORD CONTROL WORDS (PURE BUFR) -C 1 BIG ENDIAN RECORD CONTROL WORDS -C -C OUTPUT ARGUMENTS: -C -C REMARKS: -C THIS ROUTINE CALLS: OPENBF -C -C THIS ROUTINE IS CALLED BY: USER -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) - -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- - - CALL OPENBF(0,'FIRST',0) - IBLOCK=IBLK - - RETURN - END diff --git a/src/bufr/setbmiss.f b/src/bufr/setbmiss.f deleted file mode 100644 index 5000f84f7b..0000000000 --- a/src/bufr/setbmiss.f +++ /dev/null @@ -1,48 +0,0 @@ - SUBROUTINE SETBMISS(XMISS) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SETBMISS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 -C -C ABSTRACT: SETBMISS WILL ALLOW AN APPLICATION TO DEFINE THE SPECIAL -C VALUE "BMISS" WHICH DENOTES MISSING VALUES BOTH FOR READING -C FROM BUFR FILES AND FOR WRITING TO BUFR FILES. THE DEFAULT -C BUFRLIB MISSING VALUE IS SET TO 10E10 IN SUBROUTINE BFRINI. -C -C PROGRAM HISTORY LOG: -C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR -C -C USAGE: CALL SETBMISS(XMISS) -C -C INPUT ARGUMENTS: -C XMISS - REAL*8 MISSING VALUE TO BE USED -C -C OUTPUT ARGUMENTS: -C -C REMARKS: -C THIS ROUTINE CALLS: OPENBF -C -C THIS ROUTINE IS CALLED BY: None -C (Normally called only by application -C programs) -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - REAL*8 XMISS - -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- - - CALL OPENBF(0,'FIRST',0) - - BMISS = XMISS - - RETURN - END diff --git a/src/bufr/sntbbe.f b/src/bufr/sntbbe.f deleted file mode 100644 index c274ea092e..0000000000 --- a/src/bufr/sntbbe.f +++ /dev/null @@ -1,161 +0,0 @@ - SUBROUTINE SNTBBE ( IFXYN, LINE, MXMTBB, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SNTBBE -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE PARSES AN ENTRY THAT WAS PREVIOUSLY READ -C FROM AN ASCII MASTER TABLE B FILE AND THEN STORES THE OUTPUT INTO -C THE MERGED ARRAYS. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL SNTBBE ( IFXYN, LINE, MXMTBB, -C NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, -C CMUNIT, CMMNEM, CMDSC, CMELEM ) -C INPUT ARGUMENT LIST: -C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR -C TABLE ENTRY; THIS FXY NUMBER IS THE ELEMENT DESCRIPTOR -C LINE - CHARACTER*(*): TABLE ENTRY -C MXMTBB - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN -C MERGED MASTER TABLE B ARRAYS; THIS SHOULD BE THE SAME -C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN -C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE -C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS -C -C OUTPUT ARGUMENT LIST: -C NMTBB - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE B -C ARRAYS -C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE -C REPRESENTATIONS OF FXY NUMBERS (I.E. ELEMENT -C DESCRIPTORS) -C CMSCL(*) - CHARACTER*4: MERGED ARRAY CONTAINING SCALE FACTORS -C CMSREF(*)- CHARACTER*12: MERGED ARRAY CONTAINING REFERENCE VALUES -C CMBW(*) - CHARACTER*4: MERGED ARRAY CONTAINING BIT WIDTHS -C CMUNIT(*)- CHARACTER*14: MERGED ARRAY CONTAINING UNITS -C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS -C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES -C CMELEM(*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES -C -C REMARKS: -C THIS ROUTINE CALLS: BORT BORT2 JSTCHR NEMOCK -C PARSTR RJUST -C THIS ROUTINE IS CALLED BY: RDMTBB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) LINE - CHARACTER*200 TAGS(10), WKTAG - CHARACTER*128 BORT_STR1, BORT_STR2 - CHARACTER*120 CMELEM(*) - CHARACTER*14 CMUNIT(*) - CHARACTER*12 CMSREF(*) - CHARACTER*8 CMMNEM(*) - CHARACTER*4 CMSCL(*), CMBW(*), CMDSC(*) - - INTEGER IMFXYN(*) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF ( NMTBB .GE. MXMTBB ) GOTO 900 - NMTBB = NMTBB + 1 - -C Store the FXY number. This is the element descriptor. - - IMFXYN ( NMTBB ) = IFXYN - -C Parse the table entry. - - CALL PARSTR ( LINE, TAGS, 10, NTAG, '|', .FALSE. ) - IF ( NTAG .LT. 4 ) THEN - BORT_STR2 = ' HAS TOO FEW FIELDS' - GOTO 901 - ENDIF - -C Scale factor. - - CALL JSTCHR ( TAGS(2), IRET ) - IF ( IRET .NE. 0 ) THEN - BORT_STR2 = ' HAS MISSING SCALE FACTOR' - GOTO 901 - ENDIF - CMSCL ( NMTBB ) = TAGS(2)(1:4) - RJ = RJUST ( CMSCL ( NMTBB ) ) - -C Reference value. - - CALL JSTCHR ( TAGS(3), IRET ) - IF ( IRET .NE. 0 ) THEN - BORT_STR2 = ' HAS MISSING REFERENCE VALUE' - GOTO 901 - ENDIF - CMSREF ( NMTBB ) = TAGS(3)(1:12) - RJ = RJUST ( CMSREF ( NMTBB ) ) - -C Bit width. - - CALL JSTCHR ( TAGS(4), IRET ) - IF ( IRET .NE. 0 ) THEN - BORT_STR2 = ' HAS MISSING BIT WIDTH' - GOTO 901 - ENDIF - CMBW ( NMTBB ) = TAGS(4)(1:4) - RJ = RJUST ( CMBW ( NMTBB ) ) - -C Units. Note that this field is allowed to be blank. - - IF ( NTAG .GT. 4 ) THEN - CALL JSTCHR ( TAGS(5), IRET ) - CMUNIT ( NMTBB ) = TAGS(5)(1:14) - ELSE - CMUNIT ( NMTBB ) = ' ' - ENDIF - -C Comment (additional) fields. Any of these fields may be blank. - - CMMNEM ( NMTBB ) = ' ' - CMDSC ( NMTBB ) = ' ' - CMELEM ( NMTBB ) = ' ' - IF ( NTAG .GT. 5 ) THEN - WKTAG = TAGS(6) - CALL PARSTR ( WKTAG, TAGS, 10, NTAG, ';', .FALSE. ) - IF ( NTAG .GT. 0 ) THEN -C The first additional field contains the mnemonic. - CALL JSTCHR ( TAGS(1), IRET ) -C If there is a mnemonic, then make sure it's legal. - IF ( ( IRET .EQ. 0 ) .AND. - . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN - BORT_STR2 = ' HAS ILLEGAL MNEMONIC' - GOTO 901 - ENDIF - CMMNEM ( NMTBB ) = TAGS(1)(1:8) - ENDIF - IF ( NTAG .GT. 1 ) THEN -C The second additional field contains descriptor codes. - CALL JSTCHR ( TAGS(2), IRET ) - CMDSC ( NMTBB ) = TAGS(2)(1:4) - ENDIF - IF ( NTAG .GT. 2 ) THEN -C The third additional field contains the element name. - CALL JSTCHR ( TAGS(3), IRET ) - CMELEM ( NMTBB ) = TAGS(3)(1:120) - ENDIF - ENDIF - - RETURN - 900 CALL BORT('BUFRLIB: SNTBBE - OVERFLOW OF MERGED ARRAYS') - 901 BORT_STR1 = 'BUFRLIB: SNTBBE - CARD BEGINNING WITH: ' // - . LINE(1:20) - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/sntbde.f b/src/bufr/sntbde.f deleted file mode 100644 index 4ecc12027f..0000000000 --- a/src/bufr/sntbde.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SNTBDE -C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 -C -C ABSTRACT: THIS SUBROUTINE PARSES THE FIRST LINE OF AN ENTRY THAT WAS -C PREVIOUSLY READ FROM AN ASCII MASTER TABLE D FILE AND STORES THE -C OUTPUT INTO THE MERGED ARRAYS. IT THEN READS AND PARSES ALL -C REMAINING LINES FOR THAT SAME ENTRY AND THEN LIKEWISE STORES THAT -C OUTPUT INTO THE MERGED ARRAYS. THE RESULT IS THAT, UPON OUTPUT, -C THE MERGED ARRAYS NOW CONTAIN ALL OF THE INFORMATION FOR THE -C CURRENT TABLE ENTRY. -C -C PROGRAM HISTORY LOG: -C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, -C NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, -C NMELEM, IEFXYN, CEELEM ) -C INPUT ARGUMENT LIST: -C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE -C CONTAINING MASTER TABLE D INFORMATION -C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR -C TABLE ENTRY; THIS FXY NUMBER IS THE SEQUENCE DESCRIPTOR -C LINE - CHARACTER*(*): FIRST LINE OF TABLE ENTRY -C MXMTBD - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN -C MERGED MASTER TABLE D ARRAYS; THIS SHOULD BE THE SAME -C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN -C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE -C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS -C MXELEM - INTEGER: MAXIMUM NUMBER OF ELEMENTS TO BE STORED PER -C ENTRY WITHIN THE MERGED MASTER TABLE D ARRAYS; THIS -C SHOULD BE THE SAME NUMBER AS WAS USED TO DIMENSION THE -C OUTPUT ARRAYS IN THE CALLING PROGRAM, AND IT IS USED -C BY THIS SUBROUTINE TO ENSURE THAT IT DOESN'T OVERFLOW -C THESE ARRAYS -C -C OUTPUT ARGUMENT LIST: -C NMTBD - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE D -C ARRAYS -C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE -C REPRESENTATIONS OF FXY NUMBERS (I.E. SEQUENCE -C DESCRIPTORS) -C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS -C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES -C CMSEQ(*) - CHARACTER*120: MERGED ARRAY CONTAINING SEQUENCE NAMES -C NMELEM(*)- INTEGER: MERGED ARRAY CONTAINING NUMBER OF ELEMENTS -C STORED FOR EACH ENTRY -C IEFXYN(*,*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE -C REPRESENTATIONS OF ELEMENT FXY NUMBERS -C CEELEM(*,*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT BORT2 IFXY -C IGETFXY IGETNTBL JSTCHR NEMOCK -C PARSTR -C THIS ROUTINE IS CALLED BY: RDMTBD -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) LINE - CHARACTER*200 TAGS(10), CLINE - CHARACTER*128 BORT_STR1, BORT_STR2 - CHARACTER*120 CMSEQ(*), CEELEM(MXMTBD,MXELEM) - CHARACTER*8 CMMNEM(*) - CHARACTER*6 ADN30, ADSC, CLEMON - CHARACTER*4 CMDSC(*) - - INTEGER IMFXYN(*), NMELEM(*), - . IEFXYN(MXMTBD,MXELEM) - - LOGICAL DONE - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF ( NMTBD .GE. MXMTBD ) GOTO 900 - NMTBD = NMTBD + 1 - -C Store the FXY number. This is the sequence descriptor. - - IMFXYN ( NMTBD ) = IFXYN - -C Is there any other information within the first line of the -C table entry? If so, it follows a "|" separator. - - CMMNEM ( NMTBD ) = ' ' - CMDSC ( NMTBD ) = ' ' - CMSEQ ( NMTBD ) = ' ' - IPT = INDEX ( LINE, '|' ) - IF ( IPT .NE. 0 ) THEN - -C Parse the rest of the line. Any of the fields may be blank. - - CALL PARSTR ( LINE(IPT+1:), TAGS, 10, NTAG, ';', .FALSE. ) - IF ( NTAG .GT. 0 ) THEN -C The first additional field contains the mnemonic. - CALL JSTCHR ( TAGS(1), IRET ) -C If there is a mnemonic, then make sure it's legal. - IF ( ( IRET .EQ. 0 ) .AND. - . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN - BORT_STR2 = ' HAS ILLEGAL MNEMONIC' - GOTO 901 - ENDIF - CMMNEM ( NMTBD ) = TAGS(1)(1:8) - ENDIF - IF ( NTAG .GT. 1 ) THEN -C The second additional field contains descriptor codes. - CALL JSTCHR ( TAGS(2), IRET ) - CMDSC ( NMTBD ) = TAGS(2)(1:4) - ENDIF - IF ( NTAG .GT. 2 ) THEN -C The third additional field contains the sequence name. - CALL JSTCHR ( TAGS(3), IRET ) - CMSEQ ( NMTBD ) = TAGS(3)(1:120) - ENDIF - ENDIF - -C Now, read and parse all remaining lines from this table entry. -C Each line should contain an element descriptor for the sequence -C represented by the current sequence descriptor. - - NELEM = 0 - DONE = .FALSE. - DO WHILE ( .NOT. DONE ) - IF ( IGETNTBL ( LUNT, CLINE ) .NE. 0 ) THEN - BORT_STR2 = ' IS INCOMPLETE' - GOTO 901 - ENDIF - CALL PARSTR ( CLINE, TAGS, 10, NTAG, '|', .FALSE. ) - IF ( NTAG .LT. 2 ) THEN - BORT_STR2 = ' HAS BAD ELEMENT CARD' - GOTO 901 - ENDIF - -C The second field contains the FXY number for this element. - - IF ( IGETFXY ( TAGS(2), ADSC ) .NE. 0 ) THEN - BORT_STR2 = ' HAS BAD OR MISSING' // - . ' ELEMENT FXY NUMBER' - GOTO 901 - ENDIF - IF ( NELEM .GE. MXELEM ) GOTO 900 - NELEM = NELEM + 1 - IEFXYN ( NMTBD, NELEM ) = IFXY ( ADSC ) - -C The third field (if it exists) contains the element name. - - IF ( NTAG .GT. 2 ) THEN - CALL JSTCHR ( TAGS(3), IRET ) - CEELEM ( NMTBD, NELEM ) = TAGS(3)(1:120) - ELSE - CEELEM ( NMTBD, NELEM ) = ' ' - ENDIF - -C Is this the last line for this table entry? - - IF ( INDEX ( TAGS(2), ' >' ) .EQ. 0 ) DONE = .TRUE. - ENDDO - NMELEM ( NMTBD ) = NELEM - - RETURN - - 900 CALL BORT('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') - 901 CLEMON = ADN30 ( IFXYN, 6 ) - WRITE(BORT_STR1,'("BUFRLIB: SNTBDE - TABLE D ENTRY FOR' // - . ' SEQUENCE DESCRIPTOR: ",5A)') - . CLEMON(1:1), '-', CLEMON(2:3), '-', CLEMON(4:6) - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/status.f b/src/bufr/status.f deleted file mode 100644 index 35d61cd6bb..0000000000 --- a/src/bufr/status.f +++ /dev/null @@ -1,155 +0,0 @@ - SUBROUTINE STATUS(LUNIT,LUN,IL,IM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STATUS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CHECKS WHETHER LOGICAL UNIT NUMBER LUNIT -C (AND ITS ASSOCIATED BUFR FILE) IS CURRENTLY CONNECTED TO THE -C BUFR ARCHIVE LIBRARY SOFTWARE. IF SO, IT RETURNS THE I/O STREAM -C INDEX (LUN) ASSOCIATED WITH THE LOGICAL UNIT NUMBER, THE LOGICAL -C UNIT STATUS INDICATOR (IL), AND THE BUFR MESSAGE STATUS INDICATOR -C (IM) FOR THAT I/O STREAM INDEX. OTHERWISE, IT CHECKS WHETHER THERE -C IS SPACE FOR A NEW I/O STREAM INDEX AND, IF SO, RETURNS THE NEXT -C AVAILABLE I/O STREAM INDEX IN LUN IN ORDER TO DEFINE LUNIT (IL AND -C IM ARE RETURNED AS ZERO, THEY ARE LATER DEFINED VIA CALLS TO BUFR -C ARCHIVE LIBRARY SUBROUTINE WTSTAT IN THIS CASE). IF THERE IS NO -C SPACE FOR A NEW I/O STREAM INDEX, LUN IS RETURNED AS ZERO (AS WELL -C AS IL AND IM) MEANING LUNIT COULD NOT BE CONNECTED TO THE BUFR -C ARCHIVE LIBRARY SOFTWARE. LUN IS USED TO IDENTIFY UP TO "NFILES" -C UNIQUE BUFR FILES IN THE VARIOUS INTERNAL ARRAYS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-12-11 J. WOOLLEN -- FIXED A LONG STANDING BUG WHICH OCCURS IN -C UNUSUAL SITUATIONS, VERY LOW IMPACT -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL STATUS ( LUNIT, LUN, IL, IM ) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX ASSOCIATED WITH LOGICAL UNIT -C LUNIT -C 0 = LUNIT is not currently connected to the -C BUFR Archive Library software and there is -C no space for a new I/O stream index -C IL - INTEGER: LOGICAL UNIT STATUS INDICATOR: -C 0 = LUNIT is not currently connected to the -C BUFR Archive Library software or it was -C just connected in this call to STATUS -C 1 = LUNIT is connected to the BUFR Archive -C Library software as an output file -C -1 = LUNIT is connected to the BUFR Archive -C Library software as an input file -C IM - INTEGER: INDICATOR AS TO WHETHER THERE IS A BUFR -C MESSAGE CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT: -C 0 = no or LUNIT was just connected to the -C BUFR Archive Library software in this call -C to STATUS -C 1 = yes -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: CLOSBF CLOSMG COPYBF COPYMG -C COPYSB CPYMEM DATEBF DRFINI -C DUMPBF DXDUMP GETABDB GETTAGPR -C GETVALNB IFBGET IGETSC INVMRG -C IUPVS01 LCMGDF MESGBC MINIMG -C MSGWRT NMSUB OPENBF OPENMB -C OPENMG POSAPX RDMEMM RDMEMS -C RDMGSB READDX READERME READLC -C READMG READNS READSB REWNBF -C RTRCPT STNDRD UFBCNT UFBCPY -C UFBCUP UFBDMP UFBEVN UFBGET -C UFBIN3 UFBINT UFBINX UFBMMS -C UFBOVR UFBPOS UFBQCD UFBQCP -C UFBREP UFBRMS UFBSEQ UFBSTP -C UFBTAB UFBTAM UFDUMP UPFTBV -C WRCMPS WRDXTB WRITLC WRITSA -C WRITSB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /STBFR/ IOLUN(NFILES),IOMSG(NFILES) - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(LUNIT.LE.0 .OR. LUNIT.GT.99) GOTO 900 - -C CLEAR THE STATUS INDICATORS -C --------------------------- - - LUN = 0 - IL = 0 - IM = 0 - -C SEE IF UNIT IS ALREADY CONNECTED TO BUFR ARCHIVE LIBRARY SOFTWARE -C ----------------------------------------------------------------- - - DO I=1,NFILES - IF(ABS(IOLUN(I)).EQ.LUNIT) LUN = I - ENDDO - -C IF NOT, TRY TO DEFINE IT SO AS TO CONNECT IT TO BUFR ARCHIVE LIBRARY -C SOFTWARE -C -------------------------------------------------------------------- - - IF(LUN.EQ.0) THEN - DO I=1,NFILES - IF(IOLUN(I).EQ.0) THEN - -C File space is available, return with LUN > 0, IL and IM remain 0 -C ---------------------------------------------------------------- - - LUN = I - GOTO 100 - ENDIF - ENDDO - -C File space is NOT available, return with LUN, IL and IM all 0 -C ------------------------------------------------------------- - - GOTO 100 - ENDIF - -C IF THE UNIT WAS ALREADY CONNECTED TO THE BUFR ARCHIVE LIBRARY -C SOFTWARE PRIOR TO THIS CALL, RETURN STATUSES -C ------------------------------------------------------------- - - IL = SIGN(1,IOLUN(LUN)) - IM = IOMSG(LUN) - -C EXITS -C ---- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") '// - . 'OUTSIDE LEGAL RANGE OF 1-99")') LUNIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/stbfdx.f b/src/bufr/stbfdx.f deleted file mode 100644 index 5bbcc9d05d..0000000000 --- a/src/bufr/stbfdx.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE STBFDX(LUN,MESG) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STBFDX -C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE -C FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN -C COMMON BLOCK /TABABD/. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC COPIED -C FROM PREVIOUS VERSION OF RDBFDX -C -C USAGE: CALL STBFDX (LUN,MESG) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING -C BUFR TABLE (DICTIONARY) MESSAGE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CAPIT CHRTRN CHRTRNA -C GETLENS IGETNTBI IDN30 IFXY -C IUPBS01 IUPM NENUBD NMWRD -C PKTDD STNTBIA -C THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM READERME -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR - CHARACTER*128 TABB,TABB1,TABB2 - CHARACTER*128 TABA - CHARACTER*56 DXSTR - CHARACTER*55 CSEQ - CHARACTER*50 DXCMP - CHARACTER*24 UNIT - CHARACTER*8 NEMO - CHARACTER*6 NUMB,CIDN - CHARACTER*1 MOCT(MXMSGL) - DIMENSION MBAY(MXMSGLD4),LDXBD(10),LDXBE(10) - - DIMENSION MESG(*) - - EQUIVALENCE (MBAY(1),MOCT(1)) - - DATA LDXBD /38,70,8*0/ - DATA LDXBE /42,42,8*0/ - -C----------------------------------------------------------------------- - JA(I) = IA+1+LDA*(I-1) - JB(I) = IB+1+LDB*(I-1) -C----------------------------------------------------------------------- - -C MAKE A LOCAL COPY OF THE MESSAGE (SO IT CAN BE EQUIVALENCED!) -C ------------------------------------------------------------- - - DO II = 1,NMWRD(MESG) - MBAY(II) = MESG(II) - ENDDO - -C GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE -C ------------------------------------------------- - - IDXS = IUPBS01(MBAY,'MSBT')+1 - IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MBAY,'MTVL')+1 - IF(LDXA(IDXS).EQ.0) GOTO 901 - IF(LDXB(IDXS).EQ.0) GOTO 901 - IF(LDXD(IDXS).EQ.0) GOTO 901 - - CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) - I3 = LEN0+LEN1+LEN2 - DXCMP = ' ' - CALL CHRTRN(DXCMP,MOCT(I3+8),NXSTR(IDXS)) - IF(DXCMP.NE.DXSTR(IDXS)) GOTO 902 - -C SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D -C -------------------------------------------------- - - LDA = LDXA (IDXS) - LDB = LDXB (IDXS) - LDD = LDXD (IDXS) - LDBD = LDXBD(IDXS) - LDBE = LDXBE(IDXS) - L30 = LD30 (IDXS) - - IA = I3+LEN3+5 - LA = IUPM(MOCT(IA),8) - IB = JA(LA+1) - LB = IUPM(MOCT(IB),8) - ID = JB(LB+1) - LD = IUPM(MOCT(ID),8) - -C TABLE A -C ------- - - DO I=1,LA - N = IGETNTBI(LUN,'A') - CALL CHRTRNA(TABA(N,LUN),MOCT(JA(I)),LDA) - NUMB = ' '//TABA(N,LUN)(1:3) - NEMO = TABA(N,LUN)(4:11) - CSEQ = TABA(N,LUN)(13:67) - CALL STNTBIA(N,LUN,NUMB,NEMO,CSEQ) - ENDDO - -C TABLE B -C ------- - - DO I=1,LB - N = IGETNTBI(LUN,'B') - CALL CHRTRNA(TABB1,MOCT(JB(I) ),LDBD) - CALL CHRTRNA(TABB2,MOCT(JB(I)+LDBD),LDBE) - TABB(N,LUN) = TABB1(1:LDXBD(IDXV+1))//TABB2(1:LDXBE(IDXV+1)) - NUMB = TABB(N,LUN)(1:6) - NEMO = TABB(N,LUN)(7:14) - CALL NENUBD(NEMO,NUMB,LUN) - IDNB(N,LUN) = IFXY(NUMB) - UNIT = TABB(N,LUN)(71:94) - CALL CAPIT(UNIT) - TABB(N,LUN)(71:94) = UNIT - NTBB(LUN) = N - ENDDO - -C TABLE D -C ------- - - DO I=1,LD - N = IGETNTBI(LUN,'D') - CALL CHRTRNA(TABD(N,LUN),MOCT(ID+1),LDD) - NUMB = TABD(N,LUN)(1:6) - NEMO = TABD(N,LUN)(7:14) - CALL NENUBD(NEMO,NUMB,LUN) - IDND(N,LUN) = IFXY(NUMB) - ND = IUPM(MOCT(ID+LDD+1),8) - IF(ND.GT.MAXCD) GOTO 903 - DO J=1,ND - NDD = ID+LDD+2 + (J-1)*L30 - CALL CHRTRNA(CIDN,MOCT(NDD),L30) - IDN = IDN30(CIDN,L30) - CALL PKTDD(N,LUN,IDN,IRET) - IF(IRET.LT.0) GOTO 904 - ENDDO - ID = ID+LDD+1 + ND*L30 - IF(IUPM(MOCT(ID+1),8).EQ.0) ID = ID+1 - NTBD(LUN) = N - ENDDO - -C EXITS -C ----- - - RETURN -901 CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '// - . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '// - . 'KNOWN)') -902 CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '// - . 'CONTENTS') -903 WRITE(BORT_STR,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '// - . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '// - . ' (",I4,")")') NEMO,ND,MAXCD - CALL BORT(BORT_STR) -904 CALL BORT('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '// - . 'PKTDD, SEE PREVIOUS WARNING MESSAGE') - END diff --git a/src/bufr/stdmsg.f b/src/bufr/stdmsg.f deleted file mode 100644 index 444a2963bb..0000000000 --- a/src/bufr/stdmsg.f +++ /dev/null @@ -1,60 +0,0 @@ - SUBROUTINE STDMSG(CF) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STDMSG -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT BUFR -C MESSAGES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR -C ARCHIVE LIBRARY SUBROUTINES WHICH CREATE SUCH MESSAGES (E.G. WRITCP, -C WRITSB, COPYMG, WRITSA, ETC.) ARE TO BE "STANDARDIZED". SEE THE -C DOCUMENTATION BLOCK WITHIN BUFR ARCHIVE LIBRARY SUBROUTINE STNDRD -C FOR AN EXPLANATION OF WHAT "STANDARDIZATION" MEANS. THIS SUBROUTINE -C CAN BE CALLED AT ANY TIME AFTER THE FIRST CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF, AND THE POSSIBLE VALUES FOR CF ARE 'N' -C (= 'NO', WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL STDMSG (CF) -C INPUT ARGUMENT LIST: -C CF - CHARACTER*1: FLAG INDICATING WHETHER BUFR MESSAGES -C OUTPUT BY FUTURE CALLS TO WRITCP, WRITSB, COPYMG, ETC. -C SHOULD BE "STANDARDIZED": -C 'N' = 'NO' (THE DEFAULT) -C 'Y' = 'YES' -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CAPIT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /MSGSTD/ CSMF - - CHARACTER*128 BORT_STR - CHARACTER*1 CSMF, CF - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL CAPIT(CF) - IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - CSMF = CF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,'// - . '", IT MUST BE EITHER Y OR N")') CF - CALL BORT(BORT_STR) - END diff --git a/src/bufr/stndrd.f b/src/bufr/stndrd.f deleted file mode 100644 index 73d6b95450..0000000000 --- a/src/bufr/stndrd.f +++ /dev/null @@ -1,293 +0,0 @@ - SUBROUTINE STNDRD(LUNIT,MSGIN,LMSGOT,MSGOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STNDRD -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: THIS SUBROUTINE READS AN INPUT NCEP BUFR MESSAGE CONTAINED -C WITHIN ARRAY MSGIN AND, USING THE BUFR TABLES INFORMATION ASSOCIATED -C WITH LOGICAL UNIT LUNIT, OUTPUTS A "STANDARDIZED" VERSION OF THIS -C SAME MESSAGE WITHIN ARRAY MSGOT. THIS "STANDARDIZATION" INVOLVES -C REMOVING ALL OCCURRENCES OF NCEP BUFRLIB-SPECIFIC BYTE COUNTERS AND -C BIT PADS IN SECTION 4 AS WELL AS REPLACING THE TOP-LEVEL TABLE A FXY -C NUMBER IN SECTION 3 WITH AN EQUIVALENT SEQUENCE OF LOWER-LEVEL -C TABLE B, TABLE C, TABLE D AND/OR REPLICATION FXY NUMBERS WHICH -C DIRECTLY CONSTITUTE THAT TABLE A FXY NUMBER AND WHICH THEMSELVES ARE -C ALL WMO-STANDARD. THE RESULT IS THAT THE OUTPUT MESSAGE IN MSGOT IS -C NOW ENTIRELY COMPLIANT WITH WMO FM-94 BUFR REGULATIONS (I.E. IT IS -C NOW "STANDARD"). IT IS IMPORTANT TO NOTE THAT THE SEQUENCE EXPANSION -C WITHIN SECTION 3 MAY CAUSE THE FINAL "STANDARDIZED" BUFR MESSAGE TO -C BE LONGER THAN THE ORIGINAL INPUT NCEP BUFR MESSAGE BY AS MANY AS -C (MAXNC*2) BYTES (SEE 'bufrlib.prm' FOR AN EXPLANATION OF MAXNC), SO -C THE USER MUST ALLOW FOR ENOUGH SPACE TO ACCOMODATE SUCH AN EXPANSION -C WITHIN THE MSGOT ARRAY. -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C THIS SUBROUTINE IS MODELED AFTER SUBROUTINE -C STANDARD; HOWEVER, IT USES SUBROUTINE RESTD -C TO EXPAND SECTION 3 AS MANY LEVELS AS -C NECESSARY IN ORDER TO ATTAIN TRUE WMO -C STANDARDIZATION (WHEREAS STANDARD ONLY -C EXPANDED THE TOP-LEVEL TABLE A FXY NUMBER -C ONE LEVEL DEEP), AND IT ALSO CONTAINS AN -C EXTRA INPUT ARGUMENT LMSGOT WHICH PREVENTS -C OVERFLOW OF THE MSGOT ARRAY -C 2005-11-29 J. ATOR -- USE GETLENS AND IUPBS01; ENSURE THAT BYTE 4 -C OF SECTION 4 IS ZEROED OUT IN MSGOT; CHECK -C EDITION NUMBER OF BUFR MESSAGE BEFORE -C PADDING TO AN EVEN BYTE COUNT -C 2009-03-23 J. ATOR -- USE IUPBS3 AND NEMTBAX; DON'T ASSUME THAT -C COMPRESSED MESSAGES ARE ALREADY FULLY -C STANDARDIZED WITHIN SECTION 3 -C -C USAGE: CALL STNDRD (LUNIT, MSGIN, LMSGOT, MSGOT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE IN NCEP -C BUFR -C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; -C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT -C OVERFLOW THE MSGOT ARRAY -C -C OUTPUT ARGUMENT LIST: -C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE -C NOW IN STANDARDIZED BUFR -C -C REMARKS: -C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. -C -C THIS ROUTINE CALLS: BORT GETLENS ISTDESC IUPB -C IUPBS01 IUPBS3 MVB NEMTBAX -C NUMTAB PKB PKC RESTD -C STATUS UPB UPC -C THIS ROUTINE IS CALLED BY: MSGWRT -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - DIMENSION ICD(MAXNC) - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION MSGIN(*),MSGOT(*) - - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - CHARACTER*4 SEVN - CHARACTER*1 TAB - - LOGICAL FOUND - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C LUNIT MUST POINT TO AN OPEN BUFR FILE -C ------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - -C IDENTIFY THE SECTION LENGTHS AND ADDRESSES IN MSGIN -C --------------------------------------------------- - - CALL GETLENS(MSGIN,5,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) - - IAD3 = LEN0+LEN1+LEN2 - IAD4 = IAD3+LEN3 - - LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5 - - LENM = IUPBS01(MSGIN,'LENM') - - IF(LENN.NE.LENM) GOTO 901 - - MBIT = (LENN-4)*8 - CALL UPC(SEVN,4,MSGIN,MBIT) - IF(SEVN.NE.'7777') GOTO 902 - -C COPY SECTIONS 0 THROUGH PART OF SECTION 3 INTO MSGOT -C ---------------------------------------------------- - - MXBYTO = (LMSGOT*NBYTW) - 8 - - LBYTO = IAD3+7 - IF(LBYTO.GT.MXBYTO) GOTO 905 - CALL MVB(MSGIN,1,MSGOT,1,LBYTO) - -C REWRITE NEW SECTION 3 IN A "STANDARD" FORM -C ------------------------------------------ - -C LOCATE THE TOP-LEVEL TABLE A DESCRIPTOR - - FOUND = .FALSE. - II = 10 - DO WHILE ((.NOT.FOUND).AND.(II.GE.8)) - ISUB = IUPB(MSGIN,IAD3+II,16) - CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) - IF((ITAB.NE.0).AND.(TAB.EQ.'D')) THEN - CALL NEMTBAX(LUN,SUBSET,MTYP,MSBT,INOD) - IF(INOD.NE.0) FOUND = .TRUE. - ENDIF - II = II - 2 - ENDDO - IF(.NOT.FOUND) GOTO 903 - - IF (ISTDESC(ISUB).EQ.0) THEN - -C ISUB IS A NON-STANDARD TABLE A DESCRIPTOR AND NEEDS -C TO BE EXPANDED INTO AN EQUIVALENT STANDARD SEQUENCE - - CALL RESTD(LUN,ISUB,NCD,ICD) - ELSE - -C ISUB IS ALREADY A STANDARD DESCRIPTOR, SO JUST COPY -C IT "AS IS" INTO THE NEW SECTION 3 (I.E. NO EXPANSION -C IS NECESSARY!) - - NCD = 1 - ICD(NCD) = ISUB - ENDIF - -C USE THE EDITION NUMBER TO DETERMINE THE LENGTH OF THE -C NEW SECTION 3 - - LEN3 = 7+(NCD*2) - IBEN = IUPBS01(MSGIN,'BEN') - IF(IBEN.LT.4) THEN - LEN3 = LEN3+1 - ENDIF - LBYTO = LBYTO + LEN3 - 7 - IF(LBYTO.GT.MXBYTO) GOTO 905 - -C STORE THE DESCRIPTORS INTO THE NEW SECTION 3 - - IBIT = (IAD3+7)*8 - DO N=1,NCD - CALL PKB(ICD(N),16,MSGOT,IBIT) - ENDDO - -C DEPENDING ON THE EDITION NUMBER, PAD OUT THE NEW SECTION 3 WITH AN -C ADDITIONAL ZEROED-OUT BYTE IN ORDER TO ENSURE AN EVEN BYTE COUNT - - IF(IBEN.LT.4) THEN - CALL PKB(0,8,MSGOT,IBIT) - ENDIF - -C STORE THE LENGTH OF THE NEW SECTION 3 - - IBIT = IAD3*8 - CALL PKB(LEN3,24,MSGOT,IBIT) - -C NOW THE TRICKY PART - NEW SECTION 4 -C ----------------------------------- - - IF(IUPBS3(MSGIN,'ICMP').EQ.1) THEN - -C THE DATA IN SECTION 4 IS COMPRESSED AND IS THEREFORE ALREADY -C STANDARDIZED, SO COPY IT "AS IS" INTO THE NEW SECTION 4 - - IF((LBYTO+LEN4+4).GT.MXBYTO) GOTO 905 - - CALL MVB(MSGIN,IAD4+1,MSGOT,LBYTO+1,LEN4) - - JBIT = (LBYTO+LEN4)*8 - - ELSE - - NAD4 = IAD3+LEN3 - - IBIT = (IAD4+4)*8 - JBIT = (NAD4+4)*8 - - LBYTO = LBYTO + 4 - -C COPY THE SUBSETS, MINUS THE BYTE COUNTERS AND BIT PADS, INTO -C THE NEW SECTION 4 - - NSUB = IUPBS3(MSGIN,'NSUB') - - DO 10 I=1,NSUB - CALL UPB(LSUB,16,MSGIN,IBIT) - DO L=1,LSUB-2 - CALL UPB(NVAL,8,MSGIN,IBIT) - LBYTO = LBYTO + 1 - IF(LBYTO.GT.MXBYTO) GOTO 905 - CALL PKB(NVAL,8,MSGOT,JBIT) - ENDDO - DO K=1,8 - KBIT = IBIT-K-8 - CALL UPB(KVAL,8,MSGIN,KBIT) - IF(KVAL.EQ.K) THEN - JBIT = JBIT-K-8 - GOTO 10 - ENDIF - ENDDO - GOTO 904 -10 ENDDO - -C FROM THIS POINT ON, WE WILL NEED (AT MOST) 6 MORE BYTES OF -C SPACE WITHIN MSGOT IN ORDER TO BE ABLE TO STORE THE ENTIRE -C STANDARDIZED MESSAGE (I.E. WE WILL NEED (AT MOST) 2 MORE -C ZEROED-OUT BYTES IN SECTION 4 PLUS THE 4 BYTES '7777' IN -C SECTION 5), SO DO A FINAL MSGOT OVERFLOW CHECK NOW. - - IF(LBYTO+6.GT.MXBYTO) GOTO 905 - -C PAD THE NEW SECTION 4 WITH ZEROES UP TO THE NEXT WHOLE BYTE -C BOUNDARY. - - DO WHILE(.NOT.(MOD(JBIT,8).EQ.0)) - CALL PKB(0,1,MSGOT,JBIT) - ENDDO - -C DEPENDING ON THE EDITION NUMBER, WE MAY NEED TO FURTHER PAD -C THE NEW SECTION 4 WITH AN ADDITIONAL ZEROED-OUT BYTE IN ORDER -C TO ENSURE THAT THE PADDING IS UP TO AN EVEN BYTE BOUNDARY. - - IF( (IBEN.LT.4) .AND. (MOD(JBIT/8,2).NE.0) ) THEN - CALL PKB(0,8,MSGOT,JBIT) - ENDIF - - IBIT = NAD4*8 - LEN4 = JBIT/8 - NAD4 - CALL PKB(LEN4,24,MSGOT,IBIT) - CALL PKB(0,8,MSGOT,IBIT) - ENDIF - -C FINISH THE NEW MESSAGE WITH AN UPDATED SECTION 0 BYTE COUNT -C ----------------------------------------------------------- - - IBIT = 32 - LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5 - CALL PKB(LENN,24,MSGOT,IBIT) - - CALL PKC('7777',4,MSGOT,JBIT) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') -901 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM'// - . ' SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL SECTION'// - . ' LENGTHS (",I6,")")') LENM,LENN - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT '// - . 'END WITH ""7777"" (ENDS WITH ",A)') SEVN - CALL BORT(BORT_STR) -903 CALL BORT('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR '// - . 'NOT FOUND') -904 CALL BORT('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 '// - . 'FROM INPUT TO OUTPUT (STANDARD) MESSAGE') -905 CALL BORT('BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) '// - . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END diff --git a/src/bufr/stntbi.f b/src/bufr/stntbi.f deleted file mode 100644 index f525b12562..0000000000 --- a/src/bufr/stntbi.f +++ /dev/null @@ -1,69 +0,0 @@ - SUBROUTINE STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STNTBI -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR -C TABLE B OR D, DEPENDING ON THE VALUE OF NUMB. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) -C INPUT ARGUMENT LIST: -C N - INTEGER: STORAGE INDEX INTO INTERNAL TABLE B OR D -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL TABLE B OR D -C NUMB - CHARACTER*6: FXY NUMBER FOR NEW TABLE B OR D ENTRY -C (IN FORMAT FXXYYY) -C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO NUMB -C CELSQ - CHARACTER*55: ELEMENT OR SEQUENCE DESCRIPTION -C CORRESPONDING TO NUMB -C -C REMARKS: -C THIS ROUTINE CALLS: IFXY NENUBD -C THIS ROUTINE IS CALLED BY: RDUSDX STSEQ -C Not normally called by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABA, TABB - - CHARACTER*(*) NUMB, NEMO, CELSQ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL NENUBD ( NEMO, NUMB, LUN ) - - IF ( NUMB(1:1) .EQ. '0') THEN - IDNB(N,LUN) = IFXY(NUMB) - TABB(N,LUN)( 1: 6) = NUMB(1:6) - TABB(N,LUN)( 7:14) = NEMO(1:8) - TABB(N,LUN)(16:70) = CELSQ(1:55) - NTBB(LUN) = N - ELSE IF ( NUMB(1:1) .EQ. '3') THEN - IDND(N,LUN) = IFXY(NUMB) - TABD(N,LUN)( 1: 6) = NUMB(1:6) - TABD(N,LUN)( 7:14) = NEMO(1:8) - TABD(N,LUN)(16:70) = CELSQ(1:55) - NTBD(LUN) = N - ENDIF - - RETURN - END diff --git a/src/bufr/stntbia.f b/src/bufr/stntbia.f deleted file mode 100644 index 710a8d3f56..0000000000 --- a/src/bufr/stntbia.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STNTBIA -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR -C TABLE A. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) -C INPUT ARGUMENT LIST: -C N - INTEGER: STORAGE INDEX INTO INTERNAL TABLE A -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL TABLE A -C NUMB - CHARACTER*6: FXY NUMBER FOR NEW TABLE A ENTRY (IN -C FORMAT FXXYYY) -C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO NUMB -C CELSQ - CHARACTER*55: SEQUENCE DESCRIPTION CORRESPONDING -C TO NUMB -C -C REMARKS: -C THIS ROUTINE CALLS: BORT DIGIT -C THIS ROUTINE IS CALLED BY: RDUSDX READS3 STBFDX -C Not normally called by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABA, TABB - CHARACTER*128 BORT_STR - - CHARACTER*(*) NUMB, NEMO, CELSQ - - LOGICAL DIGIT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Confirm that neither NEMO nor NUMB has already been defined -C within the internal BUFR Table A (in COMMON /TABABD/) for -C the given LUN. - - DO N=1,NTBA(LUN) - IF(NUMB(4:6).EQ.TABA(N,LUN)(1: 3)) GOTO 900 - IF(NEMO(1:8).EQ.TABA(N,LUN)(4:11)) GOTO 901 - ENDDO - -C Store the values within the internal BUFR Table A. - - TABA(N,LUN)( 1: 3) = NUMB(4:6) - TABA(N,LUN)( 4:11) = NEMO(1:8) - TABA(N,LUN)(13:67) = CELSQ(1:55) - -C Decode and store the message type and subtype. - - IF ( DIGIT ( NEMO(3:8) ) ) THEN -c .... Message type & subtype obtained directly from Table A mnemonic - READ ( NEMO,'(2X,2I3)') MTYP, MSBT - IDNA(N,LUN,1) = MTYP - IDNA(N,LUN,2) = MSBT - ELSE -c .... Message type obtained from Y value of Table A seq. descriptor - READ ( NUMB(4:6),'(I3)') IDNA(N,LUN,1) -c .... Message subtype hardwired to ZERO - IDNA(N,LUN,2) = 0 - ENDIF - -C Update the count of internal Table A entries. - - NTBA(LUN) = N - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A FXY VALUE (",A,") ' - . //'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A MNEMONIC (",A,") ' - . //'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/strcln.f b/src/bufr/strcln.f deleted file mode 100644 index 3c4f198e25..0000000000 --- a/src/bufr/strcln.f +++ /dev/null @@ -1,47 +0,0 @@ - SUBROUTINE STRCLN - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STRCLN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE RESETS THE MNEMONIC STRING CACHE IN THE -C BUFR INTERFACE (ARRAYS IN COMMON BLOCK /STCACH/). THE MNEMONIC -C STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES TIME -C WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A PROGRAM, OVER -C AND OVER AGAIN (THE TYPICAL SCENARIO). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-04-02 J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50 -C ELEMENTS TO 1000, MAXIMUM -C 1998-07-08 J. WOOLLEN -- CORRECTED SOME MINOR ERRORS -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: CALL STRCLN -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: MAKESTAB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /STCACH/ MSTR,NSTR,LSTR,LUNS(MXS,2),USRS(MXS),ICON(52,MXS) - CHARACTER*80 USRS - - MSTR = MXS - NSTR = 0 - LSTR = 0 - RETURN - END diff --git a/src/bufr/strcpt.f b/src/bufr/strcpt.f deleted file mode 100644 index 84a0a4ee29..0000000000 --- a/src/bufr/strcpt.f +++ /dev/null @@ -1,76 +0,0 @@ - SUBROUTINE STRCPT(CF,IYR,IMO,IDY,IHR,IMI) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STRCPT -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE CAN BE CALLED AT ANY TIME AFTER THE FIRST -C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. WHEN CF IS SET TO -C 'Y' (= 'YES'), THIS SUBROUTINE IS USED TO SPECIFY A TANK RECEIPT -C TIME THAT WILL BE APPENDED TO SECTION 1 OF ALL FUTURE BUFR MESSAGES -C OUTPUT BY ANY OF THE BUFR ARCHIVE LIBRARY SUBROUTINES WHICH WRITE -C SUCH MESSAGES (E.G. WRITSB, COPYMG, WRITSA, ETC.). WHEN CF IS SET -C TO 'N' (= 'NO', WHICH IS THE DEFAULT), THIS CAPABILITY IS TURNED OFF -C (IF IT WAS PREVIOUSLY TURNED ON) AND THE VALUES IN ALL OF THE OTHER -C INPUT ARGUMENTS ARE IGNORED. THE TANK RECEIPT TIME IS A LOCAL -C EXTENSION TO SECTION 1; HOWEVER, ITS INCLUSION IN A MESSAGE IS -C STILL FULLY COMPLIANT WITH THE WMO FM-94 BUFR REGULATIONS. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL STRCPT (CF,IYR,IMO,IDY,IHR,IMI) -C INPUT ARGUMENT LIST: -C CF - CHARACTER*1: FLAG INDICATING WHETHER FUTURE CALLS TO -C BUFRLIB MESSAGE WRITING ROUTINES (E.G. WRITSB, COPYMG, -C WRITSA, ETC.) SHOULD APPEND THE GIVEN TANK RECEIPT -C TIME TO SECTION 1 OF SUCH MESSAGES: -C 'N' = 'NO' (THE DEFAULT) -C 'Y' = 'YES' -C IYR - INTEGER: TANK RECEIPT YEAR TO BE STORED -C IMO - INTEGER: TANK RECEIPT MONTH TO BE STORED -C IDY - INTEGER: TANK RECEIPT DAY TO BE STORED -C IHR - INTEGER: TANK RECEIPT HOUR TO BE STORED -C IMI - INTEGER: TANK RECEIPT MINUTE TO BE STORED -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CAPIT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT - - CHARACTER*128 BORT_STR - CHARACTER*1 CTRT, CF - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL CAPIT(CF) - IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - - CTRT = CF - IF(CTRT.EQ.'Y') THEN - ITRYR = IYR - ITRMO = IMO - ITRDY = IDY - ITRHR = IHR - ITRMI = IMI - ENDIF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: STRCPT - INPUT ARGUMENT IS ",A1,'// - . '", IT MUST BE EITHER Y OR N")') CF - CALL BORT(BORT_STR) - END diff --git a/src/bufr/string.f b/src/bufr/string.f deleted file mode 100644 index 6280a680b4..0000000000 --- a/src/bufr/string.f +++ /dev/null @@ -1,152 +0,0 @@ - SUBROUTINE STRING(STR,LUN,I1,IO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STRING -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CHECKS TO SEE IF A USER-SPECIFIED CHARACTER -C STRING IS IN THE STRING CACHE (ARRAYS IN COMMON BLOCKS /STCACH/ AND -C /STORDS/). IF IT IS NOT IN THE CACHE, IT MUST CALL THE BUFR -C ARCHIVE LIBRARY PARSING SUBROUTINE PARUSR TO PERFORM THE TASK OF -C SEPARATING AND CHECKING THE INDIVIDUAL "PIECES" (I.E., MNEMONICS) -C SO THAT IT CAN THEN BE ADDED TO THE CACHE. IF IT IS ALREADY IN THE -C CACHE, THEN THIS EXTRA WORK DOES NOT NEED TO BE PERFORMED. THE -C MNEMONIC STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES -C TIME WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A USER -C PROGRAM, OVER AND OVER AGAIN (THE TYPICAL SCENARIO). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-04-02 J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50 -C ELEMENTS TO 1000, MAXIMUM; OPTIMIZATION OF -C THE CACHE SEARCH ALGORITHM IN SUPPORT OF A -C BIGGER CACHE -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY; CHANGED CALL FROM -C BORT TO BORT2 -C -C USAGE: CALL STRING (STR, LUN, I1, IO) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C OUTPUT ARGUMENT LIST: -C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER -C OF BLANK-SEPARATED MNEMONICS IN STR -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUN: -C 0 = input file -C 1 = output file -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 PARUSR -C THIS ROUTINE IS CALLED BY: UFBEVN UFBGET UFBIN3 UFBINT -C UFBOVR UFBREP UFBSTP UFBTAB -C UFBTAM -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - PARAMETER (JCONS=52) - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /STCACH/ MSTR,NSTR,LSTR,LUX(MXS,2),USR(MXS),ICON(JCONS,MXS) - COMMON /USRSTR/ JCON(JCONS) - COMMON /STORDS/ IORD(MXS),IORX(MXS) - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*80 USR,UST - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - NXT = 0 - UST = STR - IND = INODE(LUN) - IF(LEN(STR).GT.80) GOTO 900 - -C Note that LSTR, MSTR and NSTR were initialized via a prior call to -C subroutine STRCLN, which itself was called by subroutine MAKESTAB. - -C SEE IF STRING IS IN THE CACHE -C ----------------------------- - - DO N=1,NSTR - IF(LUX(IORD(N),2).EQ.IND) THEN - IORX(NXT+1) = IORD(N) - NXT = NXT+1 - ENDIF - ENDDO - DO N=1,NXT - IF(UST.EQ.USR(IORX(N)))GOTO1 - ENDDO - GOTO2 - -C IF IT IS IN THE CACHE, COPY PARAMETERS FROM THE CACHE -C ----------------------------------------------------- - -1 DO J=1,JCONS - JCON(J) = ICON(J,IORX(N)) - ENDDO - GOTO 100 - -C IF IT IS NOT IN THE CACHE, PARSE IT AND PUT IT THERE -C ---------------------------------------------------- - -2 CALL PARUSR(STR,LUN,I1,IO) - LSTR = MAX(MOD(LSTR+1,MSTR+1),1) - NSTR = MIN(NSTR+1,MSTR) -c .... File - LUX(LSTR,1) = LUN -c .... Table A entry - LUX(LSTR,2) = IND - USR(LSTR) = STR - DO J=1,JCONS - ICON(J,LSTR) = JCON(J) - ENDDO - -C REARRANGE THE CACHE ORDER AFTER AN UPDATE -C ----------------------------------------- - - DO N=NSTR,2,-1 - IORD(N) = IORD(N-1) - ENDDO - IORD(1) = LSTR - -100 IF(JCON(1).GT.I1) GOTO 901 - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR1,'("BUFRLIB: STRING - INPUT STRING (",A,") HAS")') - . STR - WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') - . LEN(STR) - CALL BORT2(BORT_STR1,BORT_STR2) -901 WRITE(BORT_STR1,'("BUFRLIB: STRING - INPUT STRING (",A,")")') STR - WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// - . 'LIMIT (THIRD INPUT ARGUMENT) IS",I5)') JCON(1),I1 - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/strnum.f b/src/bufr/strnum.f deleted file mode 100644 index 127739f155..0000000000 --- a/src/bufr/strnum.f +++ /dev/null @@ -1,88 +0,0 @@ - SUBROUTINE STRNUM(STR,NUM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STRNUM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE DECODES AN INTEGER FROM A CHARACTER STRING. -C THE INPUT STRING SHOULD CONTAIN ONLY DIGITS AND (OPTIONAL) TRAILING -C BLANKS AND SHOULD NOT CONTAIN ANY SIGN CHARACTERS (E.G. '+', '-') -C NOR LEADING BLANKS NOR EMBEDDED BLANKS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL STRNUM (STR, NUM) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE -C -C OUTPUT ARGUMENT LIST: -C NUM - INTEGER: DECODED VALUE -C -1 = decode was unsuccessful -C -C REMARKS: -C THIS ROUTINE CALLS: ERRWRT STRSUC -C THIS ROUTINE IS CALLED BY: JSTNUM PARUTG SEQSDX STSEQ -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR - CHARACTER*20 STR2 - - COMMON /QUIET / IPRT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - NUM = 0 - K = 0 - -C Note that, in the following call to subroutine STRSUC, the output -C string STR2 is not used anywhere else in this routine. In fact, -C the only reason that subroutine STRSUC is being called here is to -C determine NUM, which, owing to the fact that the input string STR -C cannot contain any leading blanks, is equal to the number of -C digits to be decoded from the beginning of STR. - - CALL STRSUC(STR,STR2,NUM) - IF(NUM.EQ.-1) GOTO 100 - - DO I=1,NUM - READ(STR(I:I),'(I1)',ERR=99) J - IF(J.EQ.0 .AND. STR(I:I).NE.'0') GOTO 99 - K = K*10+J - ENDDO - - NUM = K - GOTO 100 - -C Note that NUM = -1 unambiguously indicates a bad decode since -C the input string cannot contain sign characters; thus, NUM is -C always positive if the decode is successful. - -99 NUM = -1 - IF(IPRT.GE.0) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT('BUFRLIB: STRNUM - BAD DECODE; RETURN WITH NUM = -1') - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/strsuc.f b/src/bufr/strsuc.f deleted file mode 100644 index ead6e1f486..0000000000 --- a/src/bufr/strsuc.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE STRSUC(STR1,STR2,LENS) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STRSUC -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A -C STRING. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; ADDED MORE COMPLETE -C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL STRSUC (STR1, STR2, LENS) -C INPUT ARGUMENT LIST: -C STR1 - CHARACTER*(*): STRING -C -C OUTPUT ARGUMENT LIST: -C STR2 - CHARACTER*(*): COPY OF STR1 WITH LEADING AND TRAILING -C BLANKS REMOVED -C LENS - INTEGER: LENGTH OF STR2: -C -1 = STR1 contained embedded blanks -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: DXDUMP ERRWRT MTINFO STRNUM -C UFDUMP -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) STR1,STR2 - - COMMON /QUIET / IPRT - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LENS = 0 - LSTR = LEN(STR1) - -C FIND THE FIRST NON-BLANK IN THE INPUT STRING -C -------------------------------------------- - - DO I=1,LSTR - IF(STR1(I:I).NE.' ') GOTO 2 - ENDDO - GOTO 100 - -C Now, starting with the first non-blank in the input string, -C copy characters from the input string into the output string -C until reaching the next blank in the input string. - -2 DO J=I,LSTR - IF(STR1(J:J).EQ.' ') GOTO 3 - LENS = LENS+1 - STR2(LENS:LENS) = STR1(J:J) - ENDDO - GOTO 100 - -C Now, continuing on within the input string, make sure that -C there are no more non-blank characters. If there are, then -C the blank at which we stopped copying from the input string -C into the output string was an embedded blank. - -3 DO I=J,LSTR - IF(STR1(I:I).NE.' ') LENS = -1 - ENDDO - - IF(LENS.EQ.-1 .AND. IPRT.GE.0) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT('BUFRLIB: STRSUC - INPUT STRING:') - CALL ERRWRT(STR1) - CALL ERRWRT('CONTAINS ONE OR MORE EMBEDDED BLANKS') - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/stseq.c b/src/bufr/stseq.c deleted file mode 100644 index 931f10c9e4..0000000000 --- a/src/bufr/stseq.c +++ /dev/null @@ -1,407 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: STSEQ -C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: USING THE BUFR MASTER TABLES, THIS ROUTINE STORES ALL -C OF THE INFORMATION FOR SEQUENCE IDN WITHIN THE INTERNAL BUFR -C TABLES B AND D. ANY DESCRIPTORS IN IDN WHICH ARE THEMSELVES -C SEQUENCES ARE IMMEDIATELY RESOLVED VIA A RECURSIVE CALL TO THIS -C SAME ROUTINE. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR -C 2010-03-19 J. ATOR -- ADDED PROCESSING FOR 2-04 ASSOCIATED FIELDS -C 2010-04-05 J. ATOR -- ADDED PROCESSING FOR 2-2X, 2-3X AND 2-4X -C NON-MARKER OPERATORS -C -C USAGE: CALL STSEQ( LUN, IREPCT, IDN, NEMO, CSEQ, CDESC, NCDESC ) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IREPCT - INTEGER: REPLICATION SEQUENCE COUNTER FOR THE CURRENT -C MASTER TABLE; USED INTERNALLY TO KEEP TRACK OF WHICH -C SEQUENCE NAMES HAVE ALREADY BEEN DEFINED AND THEREBY -C AVOID CONTENTION WITHIN THE INTERNAL BUFR TABLE D -C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE FOR -C SEQUENCE TO BE STORED -C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO IDN -C CSEQ - CHARACTER*55: DESCRIPTION CORRESPONDING TO IDN -C CDESC - INTEGER: ARRAY OF BIT-WISE REPRESENTATIONS OF FXY -C VALUES CORRESPONDING TO DESCRIPTORS WHICH CONSTITUTE -C THE IDN SEQUENCE -C NCDESC - INTEGER: NUMBER OF VALUES IN CDESC -C -C OUTPUT ARGUMENT LIST: -C IREPCT - INTEGER: REPLICATION SEQUENCE COUNTER FOR THE CURRENT -C MASTER TABLE; USED INTERNALLY TO KEEP TRACK OF WHICH -C SEQUENCE NAMES HAVE ALREADY BEEN DEFINED AND THEREBY -C AVOID CONTENTION WITHIN THE INTERNAL BUFR TABLE D -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CADN30 ELEMDX ICVIDX -C IFXY IGETNTBI IGETTDI NEMTAB -C NUMMTB NUMTBD PKTDD STNTBI -C STRNUM STSEQ -C THIS ROUTINE IS CALLED BY: READS3 STSEQ -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#define COMMON_MSTABS -#include "bufrlib.h" - -void stseq( f77int *lun, f77int *irepct, f77int *idn, char nemo[8], - char cseq[55], f77int cdesc[], f77int *ncdesc ) -{ - f77int i, j, nb, nd, ipt, ix, iy, iret, nbits; - f77int i0 = 0, imxcd = MAXCD; - f77int rpdesc[MAXCD], rpidn, pkint; - - char tab, adn[7], adn2[7], nemo2[9], units[10], errstr[129]; - char rpseq[56], card[80], cblk = ' '; - -/* -** The following variables are declared as static so that they -** automatically initialize to zero and remain unchanged between -** recursive calls to this subroutine. -*/ - static f77int naf, iafpk[MXNAF]; - -/* -** Is *idn already listed as an entry in the internal Table D? -** If so, then there's no need to proceed any further. -*/ - numtbd( lun, idn, nemo2, &tab, &iret, sizeof( nemo2 ), sizeof( tab ) ); - if ( ( iret > 0 ) && ( tab == 'D' ) ) return; - -/* -** Start a new Table D entry for *idn. -*/ - tab = 'D'; - nd = igetntbi( lun, &tab, sizeof ( tab ) ); - cadn30( idn, adn, sizeof( adn ) ); - stntbi( &nd, lun, adn, nemo, cseq, sizeof( adn ), 8, 55 ); - -/* -** Now, go through the list of child descriptors corresponding to *idn. -*/ - for ( i = 0; i < *ncdesc; i++ ) { - cadn30( &cdesc[i], adn, sizeof( adn ) ); - if ( adn[0] == '3' ) { -/* -** cdesc[i] is itself a Table D descriptor, so search for it within the -** master table D and then, if found, immediately store it within the -** internal Table D via a recursive call to this same routine. -*/ - nummtb( &cdesc[i], &tab, &ipt ); - stseq( lun, irepct, &cdesc[i], &mstabs.cdmnem[ipt][0], - &mstabs.cdseq[ipt][0], - &mstabs.idefxy[icvidx(&ipt,&i0,&imxcd)], - &mstabs.ndelem[ipt] ); - pkint = cdesc[i]; - } - else if ( adn[0] == '2' ) { -/* -** cdesc[i] is an operator descriptor. -*/ - strnum( &adn[3], &iy, 3 ); - - if ( ( adn[1] == '0' ) && - ( ( adn[2] >= '4' ) && ( adn[2] <= '6' ) ) ) { -/* -** This is a 204YYY, 205YYY or 206YYY operator. Using the YYY -** value, generate a Table B mnemonic to hold the corresponding -** data. -*/ - strncpy( nemo2, "20", 2 ); - strncpy( &nemo2[2], &adn[2], 1 ); - strncpy( &nemo2[3], &adn[3], 3 ); - memset( &nemo2[6], (int) cblk, 2 ); - - if ( ( adn[2] == '4' ) && ( iy == 0 ) ) { -/* -** Cancel the most-recently added associated field. -*/ - if ( naf-- <= 0 ) { - sprintf( errstr, "BUFRLIB: STSEQ - TOO MANY ASSOCIATED" - " FIELD CANCELLATION OPERATORS" ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - } - else { -/* -** Is nemo2 already listed as an entry within the internal -** Table B? -*/ - nemtab( lun, nemo2, &pkint, &tab, &iret, 8, sizeof( tab ) ); - if ( ( iret == 0 ) || ( tab != 'B' ) ) { -/* -** No, so create and store a new Table B entry for nemo2. -*/ - tab = 'B'; - nb = igetntbi( lun, &tab, sizeof( tab ) ); - - if ( adn[2] == '4' ) { - sprintf( rpseq, "ASSOCIATED FIELD OF %3lu BITS", - ( unsigned long ) iy ); - memset( &rpseq[28], (int) cblk, 27 ); - nbits = iy; - strcpy( units, "NUMERIC" ); - } - else if ( adn[2] == '5' ) { - sprintf( rpseq, "TEXT STRING OF %3lu BYTES", - ( unsigned long ) iy ); - memset( &rpseq[24], (int) cblk, 31 ); - nbits = iy*8; - strcpy( units, "CCITT IA5" ); - } - else { - sprintf( rpseq, "LOCAL DESCRIPTOR OF %3lu BITS", - ( unsigned long ) iy ); - memset( &rpseq[28], (int) cblk, 27 ); - nbits = iy; - if ( nbits > 32 ) { - strcpy( units, "CCITT IA5" ); - } - else { - strcpy( units, "NUMERIC" ); - } - } -/* -** Note that 49152 = 3*(2**14), so subtracting 49152 in the -** following statement changes a Table D bitwise FXY value into -** a Table B bitwise FXY value. -*/ - pkint = ( igettdi( lun ) - 49152 ); - cadn30( &pkint, adn2, sizeof( adn2 ) ); - - stntbi( &nb, lun, adn2, nemo2, rpseq, - sizeof( adn2 ), 8, 55 ); - - /* Initialize card to all blanks. */ - memset( card, (int) cblk, sizeof( card ) ); - - strncpy( &card[2], nemo2, 8 ); - strncpy( &card[16], "0", 1 ); - strncpy( &card[30], "0", 1 ); - sprintf( &card[33], "%4lu", ( unsigned long ) nbits ); - strncpy( &card[40], units, strlen( units ) ); - elemdx( card, lun, sizeof( card ) ); - } - if ( adn[2] == '4' ) { -/* -** Add an associated field. -*/ - if ( naf >= MXNAF ) { - sprintf( errstr, "BUFRLIB: STSEQ - TOO MANY ASSOCIATED" - " FIELDS ARE IN EFFECT AT THE SAME TIME" ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - iafpk[naf++] = pkint; - } - } - if ( adn[2] == '6' ) { -/* -** Skip over the local descriptor placeholder. -*/ - if ( ++i >= *ncdesc ) { - sprintf( errstr, "BUFRLIB: STSEQ - COULD NOT FIND LOCAL" - " DESCRIPTOR PLACEHOLDER FOR %s", adn ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - } - } - else if ( ( adn[1] >= '2' ) && ( adn[1] <= '4' ) ) { -/* -** This is a 22XYYY, 23XYYY or 24XYYY operator. -*/ - strnum( &adn[1], &ix, 2 ); - if ( ( iy == 255 ) && - ( ( ix == 23 ) || ( ix == 24 ) || - ( ix == 25 ) || ( ix == 32 ) ) ) { - sprintf( errstr, "BUFRLIB: STSEQ - UNKNOWN OPERATOR" - " DESCRIPTOR %s", adn ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - else { - continue; /* skip to next child descriptor for *idn */ - } - } - else { /* for any operator descriptor other than 204YYY, 205YYY, - 206YYY, 22XYYY, 23XYYY or 24XYYY */ - pkint = cdesc[i]; - } - } - else if ( adn[0] == '1' ) { -/* -** cdesc[i] is a replication descriptor, so create a sequence -** consisting of the set of replicated descriptors and then immediately -** store that sequence within the internal Table D via a recursive call -** to this same routine. -*/ - adn[6] = '\0'; - - strnum( &adn[3], &iy, 3 ); -/* -** See subroutine BFRINI and COMMON /REPTAB/ for the source of the FXY -** values referenced in the following block. Note we are guaranteed -** that 0 <= iy <= 255 since adn was generated using subroutine CADN30. -*/ - if ( iy == 0 ) { /* delayed replication */ - if ( ( i+1 ) >= *ncdesc ) { - sprintf( errstr, "BUFRLIB: STSEQ - COULD NOT FIND DELAYED " - "DESCRIPTOR REPLICATION FACTOR FOR %s", adn ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - else if ( cdesc[i+1] == ifxy( "031002", 6 ) ) { - pkint = ifxy( "360001", 6 ); - } - else if ( cdesc[i+1] == ifxy( "031001", 6 ) ) { - pkint = ifxy( "360002", 6 ); - } - else if ( cdesc[i+1] == ifxy( "031000", 6 ) ) { - pkint = ifxy( "360004", 6 ); - } - else { - sprintf( errstr, "BUFRLIB: STSEQ - UNKNOWN DELAYED " - "DESCRIPTOR REPLICATION FACTOR FOR %s", adn ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - i += 2; - } - else { /* regular replication */ - pkint = ifxy( "101000", 6 ) + iy; - i++; - } -/* -** Store this replication descriptor within the table D entry for -** this parent. -*/ - pktdd( &nd, lun, &pkint, &iret ); - if ( iret < 0 ) { - strncpy( nemo2, nemo, 8 ); - nemo2[8] = '\0'; - sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD WHEN " - "STORING REPLICATOR FOR PARENT MNEMONIC %s", nemo2 ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - - strnum( &adn[1], &ix, 2 ); -/* -** Note we are guaranteed that 0 < ix <= 63 since adn was generated -** using subroutine CADN30. -*/ - if ( ix > ( *ncdesc - i ) ) { - sprintf( errstr, "BUFRLIB: STSEQ - NOT ENOUGH REMAINING CHILD " - "DESCRIPTORS TO COMPLETE REPLICATION FOR %s", adn ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - else if ( ( ix == 1 ) && ( cdesc[i] >= ifxy ( "300000", 6 ) ) ) { -/* -** The only thing being replicated is a single Table D descriptor, -** so there's no need to invent a new sequence for this replication -** (this is a special case!) -*/ - nummtb( &cdesc[i], &tab, &ipt ); - stseq( lun, irepct, &cdesc[i], &mstabs.cdmnem[ipt][0], - &mstabs.cdseq[ipt][0], - &mstabs.idefxy[icvidx(&ipt,&i0,&imxcd)], - &mstabs.ndelem[ipt] ); - pkint = cdesc[i]; - } - else { -/* -** Store the ix descriptors to be replicated in a local list, then -** get an FXY value to use with this list and generate a unique -** mnemonic and description as well. -*/ - for ( j = 0; j < ix; j++ ) { - rpdesc[j] = cdesc[i+j]; - } - - rpidn = igettdi( lun ); - - sprintf( rpseq, "REPLICATION SEQUENCE %.3lu", - ( unsigned long ) ++(*irepct) ); - memset( &rpseq[24], (int) cblk, 31 ); - sprintf( nemo2, "RPSEQ%.3lu", ( unsigned long ) *irepct ); - - stseq( lun, irepct, &rpidn, nemo2, rpseq, rpdesc, &ix ); - - pkint = rpidn; - i += ix - 1; - } - } - else { -/* -** cdesc[i] is a Table B descriptor. -** -** Is cdesc[i] already listed as an entry in the internal Table B? -*/ - numtbd( lun, &cdesc[i], nemo2, &tab, &iret, sizeof( nemo2 ), - sizeof( tab ) ); - if ( ( iret == 0 ) || ( tab != 'B' ) ) { -/* -** No, so search for it within the master table B. -*/ - nummtb( &cdesc[i], &tab, &ipt ); -/* -** Start a new Table B entry for cdesc[i]. -*/ - nb = igetntbi( lun, &tab, sizeof( tab ) ); - cadn30( &cdesc[i], adn2, sizeof( adn2 ) ); - stntbi( &nb, lun, adn2, &mstabs.cbmnem[ipt][0], - &mstabs.cbelem[ipt][0], sizeof( adn2 ), 8, 55 ); - - /* Initialize card to all blanks. */ - memset( card, (int) cblk, sizeof( card ) ); - - strncpy( &card[2], &mstabs.cbmnem[ipt][0], 8 ); - strncpy( &card[13], &mstabs.cbscl[ipt][0], 4 ); - strncpy( &card[19], &mstabs.cbsref[ipt][0], 12 ); - strncpy( &card[33], &mstabs.cbbw[ipt][0], 4 ); - strncpy( &card[40], &mstabs.cbunit[ipt][0], 14 ); - elemdx( card, lun, sizeof( card ) ); - } - pkint = cdesc[i]; - } - if ( strncmp( adn, "204", 3 ) != 0 ) { -/* -** Store this child descriptor within the table D entry for this -** parent, preceding it with any associated fields that are currently -** in effect. -** -** Note that associated fields are only applied to Table B descriptors, -** except for those in Class 31. -*/ - if ( ( naf > 0 ) && ( pkint < ifxy( "100000", 6 ) ) && - ( ( pkint < ifxy( "031000", 6 ) ) || - ( pkint > ifxy( "031255", 6 ) ) ) ) { - for ( j = 0; j < naf; j++ ) { - pktdd( &nd, lun, &iafpk[j], &iret ); - if ( iret < 0 ) { - sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD " - "WHEN STORING ASSOCIATED FIELDS" ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - } - } -/* -** Store the child descriptor. -*/ - pktdd( &nd, lun, &pkint, &iret ); - if ( iret < 0 ) { - strncpy( nemo2, nemo, 8 ); - nemo2[8] = '\0'; - sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD WHEN " - "STORING CHILD FOR PARENT MNEMONIC %s", nemo2 ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - } - } -} diff --git a/src/bufr/tabent.f b/src/bufr/tabent.f deleted file mode 100644 index cf8d90e065..0000000000 --- a/src/bufr/tabent.f +++ /dev/null @@ -1,184 +0,0 @@ - SUBROUTINE TABENT(LUN,NEMO,TAB,ITAB,IREP,IKNT,JUM0) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: TABENT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE BUILDS AND STORES AN ENTRY FOR A TABLE B OR -C TABLE D MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS -C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 OPERATOR -C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR -C -C USAGE: CALL TABENT (LUN, NEMO, TAB, ITAB, IREP, IKNT, JUM0) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C NEMO - CHARACTER*8: TABLE B OR D MNEMONIC TO STORE IN JUMP/ -C LINK TABLE -C TAB - CHARACTER*1: INTERNAL BUFR TABLE ARRAY ('B' OR 'D') IN -C WHICH NEMO IS DEFINED -C ITAB - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB -C IREP - INTEGER: POSITIONAL INDEX WITHIN COMMON /REPTAB/ -C ARRAYS, FOR USE WHEN NEMO IS REPLICATED: -C 0 = NEMO is not replicated -C IKNT - INTEGER: NUMBER OF REPLICATIONS, FOR USE WHEN NEMO IS -C REPLICATED USING F=1 REGULAR (I.E., NON-DELAYED) -C REPLICATION: -C 0 = NEMO is not replicated using F=1 regular -C (i.e., non-delayed) replication -C JUM0 - INTEGER: INDEX VALUE TO BE STORED FOR NEMO WITHIN -C INTERNAL JUMP/LINK TABLE ARRAY JMPB(*) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT INCTAB NEMTBB -C THIS ROUTINE IS CALLED BY: TABSUB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - -C Note that the values within the COMMON /REPTAB/ arrays were -C initialized within subroutine BFRINI. - - COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW - COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), - . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV - - CHARACTER*128 BORT_STR - CHARACTER*24 UNIT - CHARACTER*10 TAG,RTAG - CHARACTER*8 NEMO,TAGNRV - CHARACTER*3 TYP,TYPS,TYPT - CHARACTER*1 REPS,TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C MAKE A JUMP/LINK TABLE ENTRY FOR A REPLICATOR -C --------------------------------------------- - - IF(IREP.NE.0) THEN - RTAG = REPS(IREP,1)//NEMO - DO I=1,10 - IF(RTAG(I:I).EQ.' ') THEN - RTAG(I:I) = REPS(IREP,2) - CALL INCTAB(RTAG,TYPS(IREP,1),NODE) - JUMP(NODE) = NODE+1 - JMPB(NODE) = JUM0 - LINK(NODE) = 0 - IBT (NODE) = LENS(IREP) - IRF (NODE) = 0 - ISC (NODE) = 0 - IF(IREP.EQ.1) IRF(NODE) = IKNT - JUM0 = NODE - GOTO 1 - ENDIF - ENDDO - GOTO 900 - ENDIF - -C MAKE AN JUMP/LINK ENTRY FOR AN ELEMENT OR A SEQUENCE -C ---------------------------------------------------- - -1 IF(TAB.EQ.'B') THEN - - CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) - IF(UNIT(1:5).EQ.'CCITT') THEN - TYPT = 'CHR' - ELSE - TYPT = 'NUM' - ENDIF - CALL INCTAB(NEMO,TYPT,NODE) - JUMP(NODE) = 0 - JMPB(NODE) = JUM0 - LINK(NODE) = 0 - IBT (NODE) = IBIT - IRF (NODE) = IREF - ISC (NODE) = ISCL - IF(UNIT(1:4).EQ.'CODE') THEN - TYPT = 'COD' - ELSEIF(UNIT(1:4).EQ.'FLAG') THEN - TYPT = 'FLG' - ENDIF - - IF( (TYPT.EQ.'NUM') .AND. (IBTNRV.NE.0) ) THEN - -C This node contains a new (redefined) reference value. - - IF(NNRV+1.GT.MXNRV) GOTO 902 - NNRV = NNRV+1 - TAGNRV(NNRV) = NEMO - INODNRV(NNRV) = NODE - ISNRV(NNRV) = NODE+1 - IBT(NODE) = IBTNRV - IF(IPFNRV.EQ.0) IPFNRV = NNRV - ELSEIF( (TYPT.EQ.'NUM') .AND. (NEMO(1:3).NE.'204') ) THEN - IBT(NODE) = IBT(NODE) + ICDW - ISC(NODE) = ISC(NODE) + ICSC - IRF(NODE) = IRF(NODE) * ICRV - ELSEIF( (TYPT.EQ.'CHR') .AND. (INCW.GT.0) ) THEN - IBT(NODE) = INCW * 8 - ENDIF - - ELSEIF(TAB.EQ.'D') THEN - - IF(IREP.EQ.0) THEN - TYPT = 'SEQ' - ELSE - TYPT = TYPS(IREP,2) - ENDIF - CALL INCTAB(NEMO,TYPT,NODE) - JUMP(NODE) = NODE+1 - JMPB(NODE) = JUM0 - LINK(NODE) = 0 - IBT (NODE) = 0 - IRF (NODE) = 0 - ISC (NODE) = 0 - - ELSE - - GOTO 901 - - ENDIF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: TABENT - REPLICATOR ERROR FOR INPUT '// - . 'MNEMONIC ",A,", RTAG IS ",A)') NEMO,RTAG - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: TABENT - UNDEFINED TAG (",A,") FOR '// - . 'INPUT MNEMONIC ",A)') TAB,NEMO - CALL BORT(BORT_STR) -902 CALL BORT('BUFRLIB: TABENT - MXNRV OVERFLOW') - END diff --git a/src/bufr/tabsub.f b/src/bufr/tabsub.f deleted file mode 100644 index a181daa9e3..0000000000 --- a/src/bufr/tabsub.f +++ /dev/null @@ -1,460 +0,0 @@ - SUBROUTINE TABSUB(LUN,NEMO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: TABSUB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E., -C INCLUDING RECURSIVELY RESOLVING ALL "CHILD" MNEMONICS) FOR A TABLE -C A MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA -C USING THE OPERATOR DESCRIPTORS (BUFR TABLE -C C) FOR CHANGING WIDTH AND CHANGING SCALE -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS -C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR -C 2012-04-19 J. ATOR -- FIXED BUG FOR CASES WHERE A TABLE C OPERATOR -C IMMEDIATELY FOLLOWS A TABLE D SEQUENCE -C -C USAGE: CALL TABSUB (LUN, NEMO) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C NEMO - CHARACTER*8: TABLE A MNEMONIC -C -C REMARKS: -C ----------------------------------------------------------------- -C EXAMPLE SHOWING CONTENTS OF INTERNAL JUMP/LINK TABLE (WITHIN -C COMMON /TABLES/): -C -C INTEGER MAXTAB = maximum number of jump/link table entries -C -C INTEGER NTAB = actual number of jump/link table entries -C currently in use -C -C For I = 1, NTAB: -C -C CHARACTER*10 TAG(I) = mnemonic -C -C CHARACTER*3 TYP(I) = mnemonic type indicator: -C "SUB" if TAG(I) is a Table A mnemonic -C "SEQ" if TAG(I) is a Table D mnemonic using either short -C (i.e. 1-bit) delayed replication, F=1 regular (i.e. -C non-delayed) replication, or no replication at all -C "RPC" if TAG(I) is a Table D mnemonic using either medium -C (i.e. 8-bit) delayed replication or long (i.e. 16-bit) -C delayed replication -C "RPS" if TAG(I) is a Table D mnemonic using medium -C (i.e. 8-bit) delayed replication in a stack context -C "DRB" if TAG(I) denotes the short (i.e. 1-bit) delayed -C replication of a Table D mnemonic (which would then -C itself have its own separate entry in the jump/link -C table with a corresponding TAG value of "SEQ") -C "DRP" if TAG(I) denotes either the medium (i.e. 8-bit) or -C long (i.e. 16-bit) delayed replication of a Table D -C mnemonic (which would then itself have its own separate -C entry in the jump/link table with a corresponding TAG -C value of "RPC") -C "DRS" if TAG(I) denotes the medium (i.e. 8-bit) delayed -C replication, in a stack context, of a Table D mnemonic -C (which would then itself have its own separate entry -C in the jump/link table with a corresponding TAG value -C of "RPS") -C "REP" if TAG(I) denotes the F=1 regular (i.e. non-delayed) -C replication of a Table D mnemonic (which would then -C itself have its own separate entry in the jump/link -C table with a corresponding TAG value of "SEQ") -C "CHR" if TAG(I) is a Table B mnemonic with units "CCITT IA5" -C "NUM" if TAG(I) is a Table B mnemonic with any units other -C than "CCITT IA5" -C -C INTEGER JMPB(I): -C -C IF ( TYP(I) = "SUB" ) THEN -C JMPB(I) = 0 -C ELSE IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. -C 1-bit) delayed replication or F=1 regular (i.e. -C non-delayed) replication ) -C OR -C ( TYP(I) = "RPC" ) ) THEN -C JMPB(I) = the index of the jump/link table entry denoting -C the replication of TAG(I) -C ELSE -C JMPB(I) = the index of the jump/link table entry for the -C Table A or Table D mnemonic of which TAG(I) is a -C child -C END IF -C -C INTEGER JUMP(I): -C -C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN -C JUMP(I) = 0 -C ELSE IF ( ( TYP(I) = "DRB" ) OR -C ( TYP(I) = "DRP" ) OR -C ( TYP(I) = "REP" ) ) THEN -C JUMP(I) = the index of the jump/link table entry for the -C Table D mnemonic whose replication is denoted by -C TAG(I) -C ELSE -C JUMP(I) = the index of the jump/link table entry for the -C Table B or Table D mnemonic which, sequentially, -C is the first child of TAG(I) -C END IF -C -C INTEGER LINK(I): -C -C IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. -C 1-bit) delayed replication or F=1 regular (i.e. non- -C delayed) replication ) -C OR -C ( TYP(I) = "SUB" ) -C OR -C ( TYP(I) = "RPC" ) ) THEN -C LINK(I) = 0 -C ELSE IF ( TAG(I) is, sequentially, the last child Table B or -C Table D mnemonic of the parent Table A or Table D -C mnemonic indexed by JMPB(I) ) THEN -C LINK(I) = 0 -C ELSE -C LINK(I) = the index of the jump/link table entry for the -C Table B or Table D mnemonic which, sequentially, -C is the next (i.e. following TAG(I)) child mnemonic -C of the parent Table A or Table D mnemonic indexed -C by JMPB(I) -C END IF -C -C INTEGER IBT(I): -C -C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN -C IBT(I) = bit width of Table B mnemonic TAG(I) -C ELSE IF ( ( TYP(I) = "DRB" ) OR ( TYP(I) = "DRP" ) ) THEN -C IBT(I) = bit width of delayed descriptor replication factor -C (i.e. 1, 8, or 16, depending on the replication -C scheme denoted by TAG(I)) -C ELSE -C IBT(I) = 0 -C END IF -C -C INTEGER IRF(I): -C -C IF ( TYP(I) = "NUM" ) THEN -C IRF(I) = reference value of Table B mnemonic TAG(I) -C ELSE IF ( TYP(I) = "REP" ) THEN -C IRF(I) = number of F=1 regular (i.e. non-delayed) -C replications of Table D mnemonic TAG(JUMP(I)) -C ELSE -C IRF(I) = 0 -C END IF -C -C INTEGER ISC(I): -C -C IF ( TYP(I) = "NUM" ) THEN -C ISC(I) = scale factor of Table B mnemonic TAG(I) -C ELSE IF ( TYP(I) = "SUB" ) THEN -C ISC(I) = the index of the jump/link table entry which, -C sequentially, constitutes the last element of the -C jump/link tree for Table A mnemonic TAG(I) -C ELSE -C ISC(I) = 0 -C END IF -C -C ----------------------------------------------------------------- -C -C THE FOLLOWING VALUES ARE STORED WITHIN COMMON /NRV203/ BY THIS -C SUBROUTINE, FOR USE WITH ANY 2-03-YYY (CHANGE REFERENCE VALUE) -C OPERATORS PRESENT WITHIN THE ENTIRE JUMP/LINK TABLE: -C -C NNRV = number of nodes in the jump/link table which contain new -C reference values (as defined using the 2-03 operator) -C -C INODNRV(I=1,NNRV) = nodes within jump/link table which contain -C new reference values -C -C NRV(I=1,NNRV) = new reference value corresponding to INODNRV(I) -C -C TAGNRV(I=1,NNRV) = Table B mnemonic to which the new reference -C value in NRV(I) applies -C -C ISNRV(I=1,NNRV) = start of node range in jump/link table, -C within which the new reference value defined -C by NRV(I) will be applied to all occurrences -C of TAGNRV(I) -C -C IENRV(I=1,NNRV) = end of node range in jump/link table, -C within which the new reference value defined -C by NRV(I) will be applied to all occurrences -C of TAGNRV(I) -C -C IBTNRV = number of bits in Section 4 occupied by each new -C reference value for the current 2-03 operator -C (if IBTNRV = 0, then no 2-03 operator is currently -C in scope) -C -C IPFNRV = a number between 1 and NNRV, denoting the first entry -C within the above arrays which applies to the current -C Table A mnemonic NEMO (if IPFNRV = 0, then no 2-03 -C operators have been applied to NEMO) -C -C ----------------------------------------------------------------- -C -C THIS ROUTINE CALLS: BORT INCTAB NEMTAB NEMTBD -C TABENT -C THIS ROUTINE IS CALLED BY: MAKESTAB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW - COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), - . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV - - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*8 NEMO,NEMS,NEM,TAGNRV - CHARACTER*3 TYP - CHARACTER*1 TAB - DIMENSION NEM(MAXCD,10),IRP(MAXCD,10),KRP(MAXCD,10) - DIMENSION DROP(10),JMP0(10),NODL(10),NTAG(10,2) - LOGICAL DROP - - DATA MAXLIM /10/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE MNEMONIC -C ------------------ - -C Note that Table A mnemonics, in addition to being stored within -C internal BUFR Table A array TABA(*,LUN), are also stored as -C Table D mnemonics within internal BUFR Table D array TABD(*,LUN). -C Thus, the following test is valid. - - CALL NEMTAB(LUN,NEMO,IDN,TAB,ITAB) - IF(TAB.NE.'D') GOTO 900 - -C STORE A SUBSET NODE AND JUMP/LINK THE TREE -C ------------------------------------------ - - CALL INCTAB(NEMO,'SUB',NODE) - JUMP(NODE) = NODE+1 - JMPB(NODE) = 0 - LINK(NODE) = 0 - IBT (NODE) = 0 - IRF (NODE) = 0 - ISC (NODE) = 0 - - CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) - NTAG(1,1) = 1 - NTAG(1,2) = NSEQ - JMP0(1) = NODE - NODL(1) = NODE - LIMB = 1 - - ICDW = 0 - ICSC = 0 - ICRV = 1 - INCW = 0 - - IBTNRV = 0 - IPFNRV = 0 - -C THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION -C -------------------------------------------------------------- - -1 DO N=NTAG(LIMB,1),NTAG(LIMB,2) - - NTAG(LIMB,1) = N+1 - DROP(LIMB) = N.EQ.NTAG(LIMB,2) - - CALL NEMTAB(LUN,NEM(N,LIMB),IDN,TAB,ITAB) - NEMS = NEM(N,LIMB) - -C SPECIAL TREATMENT FOR CERTAIN OPERATOR DESCRIPTORS (TAB=C) -C ---------------------------------------------------------- - - IF(TAB.EQ.'C') THEN - READ(NEMS,'(3X,I3)') IYYY - IF(ITAB.EQ.1) THEN - IF(IYYY.NE.0) THEN - IF(ICDW.NE.0) GOTO 907 - ICDW = IYYY-128 - ELSE - ICDW = 0 - ENDIF - ELSEIF(ITAB.EQ.2) THEN - IF(IYYY.NE.0) THEN - IF(ICSC.NE.0) GOTO 908 - ICSC = IYYY-128 - ELSE - ICSC = 0 - ENDIF - ELSEIF(ITAB.EQ.3) THEN - IF(IYYY.EQ.0) THEN - -C Stop applying new reference values to subset nodes. -C Instead, revert to the use of standard Table B values. - - IF(IPFNRV.EQ.0) GOTO 911 - DO JJ=IPFNRV,NNRV - IENRV(JJ) = NTAB - ENDDO - IPFNRV = 0 - ELSEIF(IYYY.EQ.255) THEN - -C End the definition of new reference values. - - IBTNRV = 0 - ELSE - -C Begin the definition of new reference values. - - IF(IBTNRV.NE.0) GOTO 909 - IBTNRV = IYYY - ENDIF - ELSEIF(ITAB.EQ.7) THEN - IF(IYYY.GT.0) THEN - IF(ICDW.NE.0) GOTO 907 - IF(ICSC.NE.0) GOTO 908 - ICDW = ((10*IYYY)+2)/3 - ICSC = IYYY - ICRV = 10**IYYY - ELSE - ICSC = 0 - ICDW = 0 - ICRV = 1 - ENDIF - ELSEIF(ITAB.EQ.8) THEN - INCW = IYYY - ENDIF - ELSE - NODL(LIMB) = NTAB+1 - IREP = IRP(N,LIMB) - IKNT = KRP(N,LIMB) - JUM0 = JMP0(LIMB) - CALL TABENT(LUN,NEMS,TAB,ITAB,IREP,IKNT,JUM0) - ENDIF - - IF(TAB.EQ.'D') THEN - -C Note here how a new tree "LIMB" is created (and is then -C immediately recursively resolved) whenever a Table D mnemonic -C contains another Table D mnemonic as one of its children. - - LIMB = LIMB+1 - IF(LIMB.GT.MAXLIM) GOTO 901 - CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,LIMB),IRP(1,LIMB),KRP(1,LIMB)) - NTAG(LIMB,1) = 1 - NTAG(LIMB,2) = NSEQ - JMP0(LIMB) = NTAB - GOTO 1 - ELSEIF(DROP(LIMB)) THEN -2 LINK(NODL(LIMB)) = 0 - LIMB = LIMB-1 - IF(LIMB.EQ.0 ) THEN - IF(ICRV.NE.1) GOTO 904 - IF(ICDW.NE.0) GOTO 902 - IF(ICSC.NE.0) GOTO 903 - IF(INCW.NE.0) GOTO 905 - IF(IBTNRV.NE.0) GOTO 910 - IF(IPFNRV.NE.0) THEN - -C One or more new reference values were defined for this -C subset, but there was no subsequent 2-03-000 operator, -C so set all IENRV(*) values for this subset to point to -C the last element of the subset within the jump/link table. -C Note that, if there had been a subsequent 2-03-000 -C operator, then these IENRV(*) values would have already -C been properly set above. - - DO JJ=IPFNRV,NNRV - IENRV(JJ) = NTAB - ENDDO - ENDIF - GOTO 100 - ENDIF - IF(DROP(LIMB)) GOTO 2 - LINK(NODL(LIMB)) = NTAB+1 - GOTO 1 - ELSEIF(TAB.NE.'C') THEN - LINK(NODL(LIMB)) = NTAB+1 - ENDIF - - ENDDO - - GOTO 906 - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D '// - . '(TAB=",A,") FOR INPUT MNEMONIC ",A)') TAB,NEMO - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '// - . 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE '// - . 'LIMIT IS",I4)') NEMO,MAXLIM - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '// - . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '// - . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '// - . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '// - . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -906 WRITE(BORT_STR,'("BUFRLIB: TABSUB - ENTITIES WERE NOT '// - . 'SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '// - . 'DEFINED BY TBL A MNEM. ",A)') NEMO - CALL BORT(BORT_STR) -907 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// - . 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT ' // - . 'MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -908 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// - . 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT ' // - . 'MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -909 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// - . 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT ' // - . 'MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -910 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '// - . 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR '// - . 'INPUT MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) -911 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '// - . 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR '// - . 'INPUT MNEMONIC ",A)') NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/trybump.f b/src/bufr/trybump.f deleted file mode 100644 index 9c46988ba4..0000000000 --- a/src/bufr/trybump.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: TRYBUMP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CHECKS THE FIRST NODE ASSOCIATED WITH A -C CHARACTER STRING (PARSED INTO ARRAYS IN COMMON BLOCK /USRSTR/) IN -C ORDER TO DETERMINE IF IT REPRESENTS A DELAYED REPLICATION SEQUENCE. -C IF SO, THEN THE DELAYED REPLICATION SEQUENCE IS INITIALIZED AND -C EXPANDED (I.E. "BUMPED") TO THE VALUE OF INPUT ARGUMENT I2. -C A CALL IS THEN MADE TO SUBROUTINE UFBRW IN ORDER TO WRITE USER DATA -C INTO THE NEWLY EXPANDED REPLICATION SEQUENCE. -C -C TRYBUMP IS USUALLY CALLED FROM UFBINT AFTER UFBINT RECEIVES A -C NON-ZERO RETURN CODE FROM UFBRW. THE CAUSE OF A BAD RETURN FROM -C UFBRW IS USUALLY A DELAYED REPLICATION SEQUENCE WHICH ISN'T -C EXPANDED ENOUGH TO HOLD THE ARRAY OF DATA THE USER IS TRYING TO -C WRITE. SO TRYBUMP IS ONE LAST CHANCE TO RESOLVE THAT SITUATION. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE); OUTPUTS MORE -C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION -C -C USAGE: CALL TRYBUMP (LUNIT, LUN, USR, I1, I2, IO, IRET) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C (SEE REMARKS) -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) -C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES TO BE -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR -C I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE -C WRITTEN TO DATA SUBSET -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUNIT (SEE REMARKS): -C 0 = INPUT FILE (POSSIBLE FUTURE USE) -C 1 = OUTPUT FILE -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: RETURN CODE FROM CALL TO SUBROUTINE UFBRW -C -C REMARKS: -C ARGUMENT LUNIT IS NOT REFERENCED IN THIS SUBROUTINE. IT WAS -C INCLUDED ONLY FOR POTENTIAL FUTURE EXPANSION OF THE SUBROUTINE. -C -C ARGUMENT IO IS ALWAYS PASSED IN WITH A VALUE OF 1 AT THE PRESENT -C TIME. IN THE FUTURE THE SUBROUTINE MAY BE EXPANDED TO ALLOW IT -C TO OPERATE ON INPUT FILES. -C -C THIS ROUTINE CALLS: BORT INVWIN LSTJPB UFBRW -C USRTPL -C THIS ROUTINE IS CALLED BY: UFBINT UFBOVR -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - - REAL*8 USR(I1,I2),VAL - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C SEE IF THERE IS A DELAYED REPLICATION GROUP INVOLVED -C ---------------------------------------------------- - - NDRP = LSTJPB(NODS(1),LUN,'DRP') - IF(NDRP.LE.0) GOTO 100 - -C IF SO, CLEAN IT OUT AND BUMP IT TO I2 -C ------------------------------------- - - INVN = INVWIN(NDRP,LUN,1,NVAL(LUN)) - VAL(INVN,LUN) = 0 - JNVN = INVN+1 - DO WHILE(NINT(VAL(JNVN,LUN)).GT.0) - JNVN = JNVN+NINT(VAL(JNVN,LUN)) - ENDDO - DO KNVN=1,NVAL(LUN)-JNVN+1 - INV(INVN+KNVN,LUN) = INV(JNVN+KNVN-1,LUN) - VAL(INVN+KNVN,LUN) = VAL(JNVN+KNVN-1,LUN) - ENDDO - NVAL(LUN) = NVAL(LUN)-(JNVN-INVN-1) - CALL USRTPL(LUN,INVN,I2) - -C FINALLY, CALL THE MNEMONIC WRITER -C ---------------------------------------- - - CALL UFBRW(LUN,USR,I1,I2,IO,IRET) - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/ufbcnt.f b/src/bufr/ufbcnt.f deleted file mode 100644 index a0656c1715..0000000000 --- a/src/bufr/ufbcnt.f +++ /dev/null @@ -1,86 +0,0 @@ - SUBROUTINE UFBCNT(LUNIT,KMSG,KSUB) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBCNT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE RETURNS A COUNT OF THE CURRENT MESSAGE -C NUMBER AND SUBSET NUMBER, WHERE THE MESSAGE NUMBER IS RELATIVE TO -C ALL MESSAGES IN THE BUFR FILE AND THE SUBSET NUMBER IS RELATIVE TO -C ALL SUBSETS IN THE MESSAGE. IF THE MESSAGE/SUBSET ARE BEING READ, -C THE MESSAGE COUNT ADVANCES EACH TIME BUFR ARCHIVE LIBRARY -C SUBROUTINE READMG (OR EQUIVALENT) IS CALLED AND THE SUBSET COUNT -C ADVANCES EACH TIME BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR -C EQUIVALENT) IS CALLED FOR A PARTICULAR MESSAGE. IF THE MESSAGE/ -C SUBSET ARE BEING WRITTEN, THE MESSAGE COUNT ADVANCES EACH TIME -C BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG (OR EQUIVALENT) IS CALLED -C AND THE SUBSET COUNT ADVANCES EACH TIME BUFR ARCHIVE LIBRARY -C SUBROUTINE WRITSB (OR EQUIVALENT) IS CALLED. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: CALL UFBCNT (LUNIT, KMSG, KSUB) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C OUTPUT ARGUMENT LIST: -C KMSG - INTEGER: POINTER TO MESSAGE COUNT IN BUFR FILE -C (INCLUDING MESSAGE CURRENTLY OPEN FOR READING/WRITING) -C KSUB - INTEGER: POINTER TO SUBSET COUNT IN BUFR MESSAGE -C (INCLUDING SUBSET CURRENTLY OPEN FOR READING/WRITING) -C -C REMARKS: -C IF AN APPLICATION PROGRAM DESIRES TO KNOW THE NUMBER OF SUBSETS IN -C A BUFR MESSAGES JUST OPENED, IT MUST USE THE FUNCTION NMSUB RATHER -C THAN THIS SUBROUTINE BECAUSE KSUB ONLY INCREMENTS BY ONE FOR EACH -C CALL TO READSB (I.E., KSUB = 0 IMMEDIATELY AFTER READMG IS -C CALLED). -C -C THIS ROUTINE CALLS: BORT STATUS -C THIS ROUTINE IS CALLED BY: UFBPOS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS - RETURN THE MESSAGE AND SUBSET COUNTERS -C -------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - KMSG = NMSG(LUN) - KSUB = NSUB(LUN) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: STATUS - BUFR FILE IS CLOSED, IT MUST BE '// - . 'OPEN FOR EITHER INPUT OR OUTPUT') - END diff --git a/src/bufr/ufbcpy.f b/src/bufr/ufbcpy.f deleted file mode 100644 index 827f431807..0000000000 --- a/src/bufr/ufbcpy.f +++ /dev/null @@ -1,129 +0,0 @@ - SUBROUTINE UFBCPY(LUBIN,LUBOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBCPY -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE COPIES A COMPLETE SUBSET BUFFER, UNPACKED -C INTO INTERNAL MEMORY FROM LOGICAL UNIT LUBIN BY A PREVIOUS CALL -C TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR READNS, TO -C LOGICAL UNIT LUBOT. BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR -C OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A -C BUFR MESSAGE WITHIN MEMORY FOR LOGICAL UNIT LUBOU. BOTH FILES MUST -C HAVE BEEN OPENED TO THE INTERFACE (VIA A CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF) WITH IDENTICAL BUFR TABLES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2009-06-26 J. ATOR -- USE IOK2CPY -C 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO REMEMBER WHICH UNIT -C IS COPIED TO WHAT SUBSET BUFFER IN ORDER TO -C TRANSFER LONG STRINGS VIA UFBCPY AND WRTREE -C -C USAGE: CALL UFBCPY (LUBIN, LUBOT) -C INPUT ARGUMENT LIST: -C LUBIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT IOK2CPY STATUS -C THIS ROUTINE IS CALLED BY: COPYSB -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /UFBCPL/ LUNCPY(NFILES) - - CHARACTER*10 TAG - CHARACTER*3 TYP - - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C CHECK THE FILE STATUSES AND I-NODE -C ---------------------------------- - - CALL STATUS(LUBIN,LUI,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903 - - CALL STATUS(LUBOT,LUO,IL,IM) - IF(IL.EQ.0) GOTO 904 - IF(IL.LT.0) GOTO 905 - IF(IM.EQ.0) GOTO 906 - - IF(INODE(LUI).NE.INODE(LUO)) THEN - IF( (TAG(INODE(LUI)).NE.TAG(INODE(LUO))) .OR. - . (IOK2CPY(LUI,LUO).NE.1) ) GOTO 907 - ENDIF - -C EVERYTHING OKAY COPY USER ARRAY FROM LUI TO LUO -C ----------------------------------------------- - - NVAL(LUO) = NVAL(LUI) - - DO N=1,NVAL(LUI) - INV(N,LUO) = INV(N,LUI) - VAL(N,LUO) = VAL(N,LUI) - ENDDO - - LUNCPY(LUO)=LUBIN - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR '// - . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') -904 CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -905 CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -906 CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') -907 CALL BORT('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST '// - . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') - END diff --git a/src/bufr/ufbcup.f b/src/bufr/ufbcup.f deleted file mode 100644 index bd378b21d6..0000000000 --- a/src/bufr/ufbcup.f +++ /dev/null @@ -1,137 +0,0 @@ - SUBROUTINE UFBCUP(LUBIN,LUBOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBCUP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE MAKES ONE COPY OF EACH UNIQUE ELEMENT IN AN -C INPUT SUBSET BUFFER INTO THE IDENTICAL MNEMONIC SLOT IN THE OUTPUT -C SUBSET BUFFER. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C -C USAGE: CALL UFBCUP (LUBIN, LUBOT) -C INPUT ARGUMENT LIST: -C LUBIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR -C FILE -C LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR -C FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*10 TAG,TAGI(MAXJL),TAGO - CHARACTER*3 TYP - DIMENSION NINI(MAXJL) - REAL*8 VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C CHECK THE FILE STATUSES AND I-NODE -C ---------------------------------- - - CALL STATUS(LUBIN,LUI,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903 - - CALL STATUS(LUBOT,LUO,IL,IM) - IF(IL.EQ.0) GOTO 904 - IF(IL.LT.0) GOTO 905 - IF(IM.EQ.0) GOTO 906 - -C MAKE A LIST OF UNIQUE TAGS IN INPUT BUFFER -C ------------------------------------------ - - NTAG = 0 - - DO 5 NI=1,NVAL(LUI) - NIN = INV(NI,LUI) - IF(ITP(NIN).GE.2) THEN - DO NV=1,NTAG - IF(TAGI(NV).EQ.TAG(NIN)) GOTO 5 - ENDDO - NTAG = NTAG+1 - NINI(NTAG) = NI - TAGI(NTAG) = TAG(NIN) - ENDIF -5 ENDDO - - IF(NTAG.EQ.0) GOTO 907 - -C GIVEN A LIST MAKE ONE COPY OF COMMON ELEMENTS TO OUTPUT BUFFER -C -------------------------------------------------------------- - - DO 10 NV=1,NTAG - NI = NINI(NV) - DO NO=1,NVAL(LUO) - TAGO = TAG(INV(NO,LUO)) - IF(TAGI(NV).EQ.TAGO) THEN - VAL(NO,LUO) = VAL(NI,LUI) - GOTO 10 - ENDIF - ENDDO -10 ENDDO - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// - . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') -904 CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -905 CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -906 CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') -907 CALL BORT('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN '// - . 'INPUT SUBSET BUFFER') - END diff --git a/src/bufr/ufbdmp.f b/src/bufr/ufbdmp.f deleted file mode 100644 index c48d12684b..0000000000 --- a/src/bufr/ufbdmp.f +++ /dev/null @@ -1,290 +0,0 @@ - SUBROUTINE UFBDMP(LUNIN,LUPRT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBDMP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE -C CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE -C INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT -C ABS(LUNIN). ABS(LUNIN) MUST HAVE BEEN OPENED FOR INPUT VIA A -C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. THE DATA -C SUBSET MUST HAVE BEEN SUBSEQUENTLY READ INTO THE INTERNAL BUFR -C ARCHIVE LIBRARY ARRAYS VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE -C READMG OR READERME, FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE READNS!). FOR A PARTICULAR SUBSET, THE PRINT LISTING -C CONTAINS EACH MNEMONIC ACCOMPANIED BY ITS CORRESPONDING DATA VALUE -C (INCLUDING THE ACTUAL BITS THAT WERE SET FOR FLAG TABLE VALUES!) -C ALONG WITH OTHER POTENTIALLY USEFUL INFORMATION SUCH AS WHICH OTHER -C MNEMONIC(S) THAT MNEMONIC WAS A CONSTITUENT OF WITHIN THE OVERALL -C DATA SUBSET. HOWEVER, THE LISTING ALSO CONTAINS OTHER MORE ESOTERIC -C INFORMATION SUCH AS BUFR STORAGE CHARACTERISTICS AND A COPY OF THE -C JUMP/LINK TABLE USED INTERNALLY WITHIN THE BUFR ARCHIVE LIBRARY -C SOFTWARE. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE UFDUMP, EXCEPT THAT UFDUMP DOES NOT PRINT POINTERS, -C COUNTERS AND THE OTHER MORE ESOTERIC INFORMATION DESCRIBING THE -C INTERNAL SUBSET STRUCTURES. EACH SUBROUTINE, UFBDMP AND UFDUMP, -C IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP -C IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR -C FOR INFORMATIONAL PURPOSES; TEST FOR A -C MISSING VALUE NOW ALLOWS SOME FUZZINESS -C ABOUT 10E10 (RATHER THAN TRUE EQUALITY AS -C BEFORE) BECAUSE SOME MISSING VALUES (E.G., -C CHARACTER STRINGS < 8 CHARACTERS) WERE NOT -C GETTING STAMPED OUT AS "MISSING"; ADDED -C OPTION TO PRINT VALUES USING FORMAT EDIT -C DESCRIPTOR "F15.6" IF LUNIN IS < ZERO, -C IF LUNIN IS > ZERO EDIT DESCRIPTOR EXPANDED -C FROM "G10.3" TO "G15.6" {REGARDLESS OF -C LUNIN, ADDITIONAL VALUES -C "IB,IS,IR,ND,JP,LK,JB" NOW PRINTED (THEY -C WERE COMMENTED OUT)} -C 2004-08-18 J. ATOR -- MODIFIED FUZZINESS TEST;ADDED READLC OPTION; -C RESTRUCTURED SOME LOGIC FOR CLARITY -C 2006-04-14 D. KEYSER -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET -C ACTUAL BITS THAT WERE SET TO GENERATE VALUE -C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS -C -C USAGE: CALL UFBDMP (LUNIN, LUPRT) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE -C - IF LUNIN IS GREATER THAN ZERO, DATA VALUES ARE -C PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR -C "G15.6" (all values are printed since output -C format adapts to the magnitude of the data, but -C they are not lined up in columns according to -C decimal point) -C - IF LUNIN IS LESS THAN ZERO, DATA VALUES ARE -C PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR -C "F15.6" {values are lined up in columns according -C to decimal point, but data of large magnitude, -C (i.e., exceeding the format width of 15) get the -C overflow ("***************") print} -C LUPRT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT -C FILE -C 0 = LUPRT is set to 06 (standard output) and -C the subroutine will scroll the output, -C twenty elements at a time (see REMARKS) -C -C INPUT FILES: -C UNIT 05 - STANDARD INPUT (SEE REMARKS) -C -C OUTPUT FILES: -C IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT) -C IF LUPRT = 0: UNIT 06 - STANDARD OUTPUT PRINT (SEE REMARKS) -C -C -C REMARKS: -C THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS -C AT A TIME WHEN LUPRT IS INPUT AS "0". IN THIS CASE, THE EXECUTING -C SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND -C STANDARD OUTPUT. INITIALLY, THE FIRST TWENTY ELEMENTS OF THE -C CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL, -C FOLLOWED BY THE PROMPT "( for MORE, q to QUIT)". -C IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY -C "" (e.g., ""), THE NEXT TWENTY ELEMENTS WILL BE -C DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT. THIS CONTINUES -C UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL -C ENTERS "q" FOLLOWED BY "" AFTER THE PROMPT, IN WHICH CASE -C THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING -C PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE). -C -C THIS ROUTINE CALLS: BORT IBFMS ISIZE READLC -C RJUST STATUS UPFTBV -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - - CHARACTER*20 LCHR - CHARACTER*14 BITS - CHARACTER*10 TAG,TG,TG_RJ - CHARACTER*8 VC - CHARACTER*7 FMTF - CHARACTER*3 TYP,TP - CHARACTER*1 TAB,YOU - EQUIVALENCE (VL,VC) - REAL*8 VAL,VL - - PARAMETER (MXFV=31) - INTEGER IFV(MXFV) - - DATA YOU /'Y'/ - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IF(LUPRT.EQ.0) THEN - LUOUT = 6 - ELSE - LUOUT = LUPRT - ENDIF - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - LUNIT = ABS(LUNIN) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 - -C DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT ABS(LUNIN) -C -------------------------------------------------------- - - DO NV=1,NVAL(LUN) - IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN - -C When LUPRT=0, the output will be scrolled, 20 elements at a time -C ---------------------------------------------------------------- - - PRINT*,'( for MORE, q to QUIT)' - READ(5,'(A1)') YOU - -C If the terminal enters "q" followed by "" after the prompt -C "( for MORE, q to QUIT)", scrolling will end and the -C subroutine will return to the calling program -C ------------------------------------------------------------------- - - IF(YOU.EQ.'q') THEN - PRINT* - PRINT*,'==> You have chosen to stop the dumping of this subset' - PRINT* - GOTO 100 - ENDIF - ENDIF - ND = INV (NV,LUN) - VL = VAL (NV,LUN) - TG = TAG (ND) - TP = TYP (ND) - IT = ITP (ND) - IB = IBT (ND) - IS = ISC (ND) - IR = IRF (ND) - JP = JUMP(ND) - LK = LINK(ND) - JB = JMPB(ND) - TG_RJ = TG - RJ = RJUST(TG_RJ) - IF(TP.NE.'CHR') THEN - BITS = ' ' - IF(IT.EQ.2) THEN - CALL NEMTAB(LUN,TG,IDN,TAB,N) - IF(TABB(N,LUN)(71:75).EQ.'FLAG') THEN - -C Print a listing of the bits corresponding to -C this value. - - CALL UPFTBV(LUNIT,TG,VL,MXFV,IFV,NIFV) - IF(NIFV.GT.0) THEN - BITS(1:1) = '(' - IPT = 2 - DO II=1,NIFV - ISZ = ISIZE(IFV(II)) - WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)' - IF((IPT+ISZ).LE.14) THEN - WRITE(BITS(IPT:IPT+ISZ),FMTF) IFV(II), ',' - IPT = IPT + ISZ + 1 - ELSE - BITS(2:13) = 'MANY BITS ON' - IPT = 15 - ENDIF - ENDDO - BITS(IPT-1:IPT-1) = ')' - ENDIF - ENDIF - ENDIF - IF(IBFMS(VL).NE.0) THEN - LCHR = 'MISSING' - RJ = RJUST(LCHR) - WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB - ELSE - IF(LUNIT.EQ.LUNIN) THEN - WRITE(LUOUT,1) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK, - . JB - ELSE - WRITE(LUOUT,10) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK, - . JB - ENDIF - ENDIF - ELSE - IF(IB.GT.64) THEN - CALL READLC(LUNIT,LCHR,TG_RJ) - ELSE - LCHR = VC - ENDIF - IF(IBFMS(VL).NE.0) LCHR = 'MISSING' - RJ = RJUST(LCHR) - WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB - ENDIF - ENDDO - - WRITE(LUOUT,3) - -1 FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,G15.6,1X,A14,7(1X,I5)) -10 FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,F15.6,1X,A14,7(1X,I5)) -2 FORMAT(I5,1X,A3,'-',I1,1X,A10, A20, 15X, 7(1X,I5)) -3 FORMAT(/' >>> END OF SUBSET <<< '/) - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '// - . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') - END diff --git a/src/bufr/ufbevn.f b/src/bufr/ufbevn.f deleted file mode 100644 index 5111e98e3b..0000000000 --- a/src/bufr/ufbevn.f +++ /dev/null @@ -1,290 +0,0 @@ - SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBEVN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT -C BUFR DATA SUBSET WITHIN INTERNAL ARRAYS. THE DATA VALUES -C CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION -C SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE. THE INNER -C SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER -C SEQUENCE WITH DATA "EVENTS". THE BUFR FILE IN LOGICAL UNIT LUNIT -C MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF. IN ADDITION, THE DATA SUBSET MUST HAVE -C SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY -C ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR -C READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE -C READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE READNS). OTHER THAN THE ADDITION OF A THIRD -C DIMENSION AND THE READ ONLY RESTRICTION, THE CONTEXT AND USAGE OF -C UFBEVN IS EXACTLY THE SAME AS FOR BUFR ARCHIVE LIBRARY SUBROUTINES -C UFBINT, UFBREP AND UFBSEQ. THIS SUBROUTINE IS DESIGNED TO READ -C EVENT INFORMATION FROM "PREPBUFR" TYPE BUFR FILES. PREPBUFR FILES -C HAVE THE FOLLOWING BUFR TABLE EVENT STRUCTURE (NOTE SIXTEEN -C CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN TO ALLOW THE -C TABLE TO FIT IN THIS DOCBLOCK): -C -C | ADPUPA | HEADR {PLEVL} | -C | HEADR | SID XOB YOB DHR ELV TYP T29 TSB ITP SQN | -C | PLEVL | CAT | -C | PINFO | [PEVN] | -C | QINFO | [QEVN] TDO | -C | TINFO | [TEVN] TVO | -C | ZINFO | [ZEVN] | -C | WINFO | [WEVN] | -C | PEVN | POB PQM PPC PRC | -C | QEVN | QOB QQM QPC QRC | -C | TEVN | TOB TQM TPC TRC | -C | ZEVN | ZOB ZQM ZPC ZRC | -C | WEVN | UOB WQM WPC WRC VOB | -C | PBACKG | POE PFC | -C | QBACKG | QOE QFC | -C | TBACKG | TOE TFC | -C | ZBACKG | ZOE ZFC | -C | WBACKG | WOE UFC VFC | -C | PPOSTP | PAN | -C | QPOSTP | QAN | -C | TPOSTP | TAN | -C | ZPOSTP | ZAN | -C | WPOSTP | UAN VAN | -C -C NOTE THAT THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES "[xxxx]" -C ARE NESTED INSIDE ONE-BIT DELAYED REPLICATED SEQUENCES "". -C THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBIN3 DOES NOT WORK -C PROPERLY ON THIS TYPE OF EVENT STRUCTURE. IT WORKS ONLY ON THE -C EVENT STRUCTURE FOUND IN "PREPFITS" TYPE BUFR FILES (SEE UFBIN3 FOR -C MORE DETAILS). IN TURN, UFBEVN DOES NOT WORK PROPERLY ON THE EVENT -C STRUCTURE FOUND IN PREPFITS FILES (ALWAYS USE UFBIN3 IN THIS CASE). -C ONE OTHER DIFFERENCE BETWEEN UFBEVN AND UFBIN3 IS THAT UFBEVN -C STORES THE MAXIMUM NUMBER OF EVENTS FOUND FOR ALL DATA VALUES -C SPECIFIED AMONGST ALL LEVELS RETURNED INTERNALLY IN COMMON BLOCK -C /UFBN3C/. UFBIN3 RETURNS THIS VALUE AS AN ADDITIONAL OUTPUT -C ARGUMENT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; IMPROVED MACHINE -C PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. WOOLLEN -- SAVES THE MAXIMUM NUMBER OF EVENTS FOUND -C FOR ALL DATA VALUES SPECIFIED AMONGST ALL -C LEVELS RETURNED AS VARIABLE MAXEVN IN NEW -C COMMON BLOCK /UFBN3C/ -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); ADDED CALL TO BORT -C IF BUFR FILE IS OPEN FOR OUTPUT; UNIFIED/ -C PORTABLE FOR WRF; ADDED DOCUMENTATION -C (INCLUDING HISTORY); OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY OR UNUSUAL THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBEVN (LUNIT, USR, I1, I2, I3, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE .GE. LATTER) -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM -C VALUE IS 255) -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED -C TO TABLE B, THESE RETURN THE FOLLOWING -C INFORMATION IN CORRESPONDING USR LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C USR - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM -C DATA SUBSET (MUST BE NO LARGER THAN I2) -C -C REMARKS: -C APPLICATION PROGRAMS READING PREPFITS FILES SHOULD NOT CALL THIS -C ROUTINE. -C -C THIS ROUTINE CALLS: BORT CONWIN ERRWRT GETWIN -C NVNWIN NXTWIN STATUS STRING -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /UFBN3C/ MAXEVN - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 ERRSTR - DIMENSION INVN(255) - REAL*8 VAL,USR(I1,I2,I3) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - MAXEVN = 0 - IRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I3.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ENDIF - -C PARSE OR RECALL THE INPUT STRING -C -------------------------------- - - CALL STRING(STR,LUN,I1,0) - -C INITIALIZE USR ARRAY -C -------------------- - - DO K=1,I3 - DO J=1,I2 - DO I=1,I1 - USR(I,J,K) = BMISS - ENDDO - ENDDO - ENDDO - -C LOOP OVER COND WINDOWS -C ---------------------- - - INC1 = 1 - INC2 = 1 - -1 CALL CONWIN(LUN,INC1,INC2) - IF(NNOD.EQ.0) THEN - IRET = I2 - GOTO 100 - ELSEIF(INC1.EQ.0) THEN - GOTO 100 - ELSE - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INS2 = INC1 - CALL GETWIN(NODS(I),LUN,INS1,INS2) - IF(INS1.EQ.0) GOTO 100 - GOTO 2 - ENDIF - ENDDO - INS1 = INC1 - INS2 = INC2 - ENDIF - -C READ PUSH DOWN STACK DATA INTO 3D ARRAYS -C ---------------------------------------- - -2 IRET = IRET+1 - IF(IRET.LE.I2) THEN - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - NNVN = NVNWIN(NODS(I),LUN,INS1,INS2,INVN,I3) - MAXEVN = MAX(NNVN,MAXEVN) - DO N=1,NNVN - USR(I,IRET,N) = VAL(INVN(N),LUN) - ENDDO - ENDIF - ENDDO - ENDIF - -C DECIDE WHAT TO DO NEXT -C ---------------------- - - CALL NXTWIN(LUN,INS1,INS2) - IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 - IF(NCON.GT.0) GOTO 1 - - IF(IRET.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, ' // - . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// - . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') - END diff --git a/src/bufr/ufbget.f b/src/bufr/ufbget.f deleted file mode 100644 index 44fa7af383..0000000000 --- a/src/bufr/ufbget.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE UFBGET(LUNIT,TAB,I1,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBGET -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE VALUES FOR ONE- -C DIMENSIONAL DESCRIPTORS IN THE INPUT STRING WITHOUT ADVANCING THE -C SUBSET POINTER. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; IMPROVED MACHINE -C PORTABILITY -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2012-03-02 J. ATOR -- USE FUNCTION UPS -C -C USAGE: CALL UFBGET (LUNIT, TAB, I1, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C I1 - INTEGER: LENGTH OF TAB -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH THE WORDS -C IN THE ARRAY TAB -C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED -C TO TABLE B, THESE RETURN THE FOLLOWING -C INFORMATION IN CORRESPONDING TAB LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C TAB - REAL*8: (I1) STARTING ADDRESS OF DATA VALUES READ FROM -C DATA SUBSET -C IRET - INTEGER: RETURN CODE: -C 0 = normal return -C -1 = there are no more subsets in the BUFR -C message -C -C REMARKS: -C THIS ROUTINE CALLS: BORT INVWIN STATUS STRING -C UPBB UPC UPS USRTPL -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS) - - CHARACTER*(*) STR - CHARACTER*10 TAG - CHARACTER*8 CVAL - CHARACTER*3 TYP - EQUIVALENCE (CVAL,RVAL) - REAL*8 VAL,RVAL,TAB(I1),UPS - -C----------------------------------------------------------------------- - MPS(NODE) = 2**(IBT(NODE))-1 -C----------------------------------------------------------------------- - - IRET = 0 - - DO I=1,I1 - TAB(I) = BMISS - ENDDO - -C MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT -C ------------------------------------------ - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE -C --------------------------------------------- - - IF(NSUB(LUN).EQ.MSUB(LUN)) THEN - IRET = -1 - GOTO 100 - ENDIF - -C PARSE THE STRING -C ---------------- - - CALL STRING(STR,LUN,I1,0) - -C EXPAND THE TEMPLATE FOR THIS SUBSET AS LITTLE AS POSSIBLE -C --------------------------------------------------------- - - N = 1 - NBIT(N) = 0 - MBIT(N) = MBYT(LUN)*8 + 16 - CALL USRTPL(LUN,N,N) - -10 DO N=N+1,NVAL(LUN) - NODE = INV(N,LUN) - NBIT(N) = IBT(NODE) - MBIT(N) = MBIT(N-1)+NBIT(N-1) - IF(NODE.EQ.NODS(NNOD)) THEN - NVAL(LUN) = N - GOTO 20 - ELSEIF(ITP(NODE).EQ.1) THEN - CALL UPBB(IVAL,NBIT(N),MBIT(N),MBAY(1,LUN)) - CALL USRTPL(LUN,N,IVAL) - GOTO 10 - ENDIF - ENDDO -20 CONTINUE - -C UNPACK ONLY THE NODES FOUND IN THE STRING -C ----------------------------------------- - - DO I=1,NNOD - NODE = NODS(I) - INVN = INVWIN(NODE,LUN,1,NVAL(LUN)) - IF(INVN.GT.0) THEN - CALL UPBB(IVAL,NBIT(INVN),MBIT(INVN),MBAY(1,LUN)) - IF(ITP(NODE).EQ.1) THEN - TAB(I) = IVAL - ELSEIF(ITP(NODE).EQ.2) THEN - IF(IVAL.LT.MPS(NODE)) TAB(I) = UPS(IVAL,NODE) - ELSEIF(ITP(NODE).EQ.3) THEN - CVAL = ' ' - KBIT = MBIT(INVN) - CALL UPC(CVAL,NBIT(INVN)/8,MBAY(1,LUN),KBIT) - TAB(I) = RVAL - ENDIF - ELSE - TAB(I) = BMISS - ENDIF - ENDDO - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') - END diff --git a/src/bufr/ufbin3.f b/src/bufr/ufbin3.f deleted file mode 100644 index d37f8d70fe..0000000000 --- a/src/bufr/ufbin3.f +++ /dev/null @@ -1,263 +0,0 @@ - SUBROUTINE UFBIN3(LUNIT,USR,I1,I2,I3,IRET,JRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBIN3 -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT -C BUFR DATA SUBSET WITHIN INTERNAL ARRAYS. THE DATA VALUES -C CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION -C SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE. THE INNER -C SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER -C SEQUENCE WITH DATA "EVENTS". THE BUFR FILE IN LOGICAL UNIT LUNIT -C MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF. IN ADDITION, THE DATA SUBSET MUST HAVE -C SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY -C ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR -C READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE -C READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY -C SUBROUTINE READNS). THIS SUBROUTINE IS DESIGNED TO READ EVENT -C INFORMATION FROM "PREPFITS" TYPE BUFR FILES (BUT NOT FROM -C "PREPBUFR" TYPE FILES!!). PREPFITS FILES HAVE THE FOLLOWING BUFR -C TABLE EVENT STRUCTURE (NOTE SIXTEEN CHARACTERS HAVE BEEN REMOVED -C FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK): -C -C | ADPUPA | HEADR {PLEVL} | -C | HEADR | SID XOB YOB DHR ELV TYP T29 ITP | -C | PLEVL | CAT PRC PQM QQM TQM ZQM WQM CDTP_QM [OBLVL] | -C | OBLVL | SRC FHR | -C | OBLVL | | -C | PEVN | POB PMO | -C | QEVN | QOB | -C | TEVN | TOB | -C | ZEVN | ZOB | -C | WEVN | UOB VOB | -C | CEVN | CAPE CINH LI | -C | CTPEVN | CDTP GCDTT TOCC | -C -C NOTE THAT THE ONE-BIT DELAYED REPLICATED SEQUENCES "" ARE -C NESTED INSIDE THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES -C "[yyyy]". THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBEVN -C DOES NOT WORK PROPERLY ON THIS TYPE OF EVENT STRUCTURE. IT WORKS -C ONLY ON THE EVENT STRUCTURE FOUND IN "PREPBUFR" TYPE BUFR FILES -C (SEE UFBEVN FOR MORE DETAILS). IN TURN, UFBIN3 DOES NOT WORK -C PROPERLY ON THE EVENT STRUCTURE FOUND IN PREPBUFR FILES (ALWAYS USE -C UFBEVN IN THIS CASE). ONE OTHER DIFFERENCE BETWEEN UFBIN3 AND -C UFBEVN IS THAT UFBIN3 RETURNS THE MAXIMUM NUMBER OF EVENTS FOUND -C FOR ALL DATA VALUES SPECIFIED AS AN OUTPUT ARGUMENT (JRET). UFBEVN -C DOES NOT DO THIS, BUT RATHER IT STORES THIS VALUE INTERNALLY IN -C COMMON BLOCK /UFBN3C/. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION -C VERSION) -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY OR UNUSUAL THINGS HAPPEN -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBIN3 (LUNIT, USR, I1, I2, I3, IRET, JRET, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE .GE. LATTER) -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM -C VALUE IS 255) -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED -C TO TABLE B, THESE RETURN THE FOLLOWING -C INFORMATION IN CORRESPONDING USR LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C USR - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM -C DATA SUBSET (MUST BE NO LARGER THAN I2) -C JRET - INTEGER: MAXIMUM NUMBER OF "EVENTS" FOUND FOR ALL DATA -C VALUES SPECIFIED AMONGST ALL LEVELS READ FROM DATA -C SUBSET (MUST BE NO LARGER THAN I3) -C -C REMARKS: -C IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY THE VERIFICATION -C APPLICATION PROGRAM "GRIDTOBS", WHERE IT WAS PREVIOUSLY -C AN IN-LINE SUBROUTINE. IN GENERAL, UFBIN3 DOES NOT -C WORK PROPERLY IN OTHER APPLICATION PROGRAMS (I.E, THOSE -C THAT ARE READING PREPBUFR FILES) AT THIS TIME. ALWAYS -C USE UFBEVN INSTEAD!! -C -C THIS ROUTINE CALLS: BORT CONWIN ERRWRT GETWIN -C NEVN NXTWIN STATUS STRING -C THIS ROUTINE IS CALLED BY: None -C SHOULD NOT BE CALLED BY ANY APPLICATION -C PROGRAMS EXCEPT GRIDTOBS!! -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 ERRSTR - REAL*8 VAL,USR(I1,I2,I3) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - JRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // - . '8th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // - . '8th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I3.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // - . '8th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ENDIF - -C PARSE OR RECALL THE INPUT STRING -C -------------------------------- - - CALL STRING(STR,LUN,I1,0) - -C INITIALIZE USR ARRAY -C -------------------- - - DO K=1,I3 - DO J=1,I2 - DO I=1,I1 - USR(I,J,K) = BMISS - ENDDO - ENDDO - ENDDO - -C LOOP OVER COND WINDOWS -C ---------------------- - - INC1 = 1 - INC2 = 1 - -1 CALL CONWIN(LUN,INC1,INC2) - IF(NNOD.EQ.0) THEN - IRET = I2 - GOTO 100 - ELSEIF(INC1.EQ.0) THEN - GOTO 100 - ELSE - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INS2 = INC1 - CALL GETWIN(NODS(I),LUN,INS1,INS2) - IF(INS1.EQ.0) GOTO 100 - GOTO 2 - ENDIF - ENDDO - INS1 = INC1 - INS2 = INC2 - ENDIF - -C READ PUSH DOWN STACK DATA INTO 3D ARRAYS -C ---------------------------------------- - -2 IRET = IRET+1 - IF(IRET.LE.I2) THEN - DO I=1,NNOD - NNVN = NEVN(NODS(I),LUN,INS1,INS2,I1,I2,I3,USR(I,IRET,1)) - JRET = MAX(JRET,NNVN) - ENDDO - ENDIF - -C DECIDE WHAT TO DO NEXT -C ---------------------- - - CALL NXTWIN(LUN,INS1,INS2) - IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 - IF(NCON.GT.0) GOTO 1 - - IF(IRET.EQ.0 .OR. JRET.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' // - . 'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; ' // - . '8th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '// - . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') - END diff --git a/src/bufr/ufbint.f b/src/bufr/ufbint.f deleted file mode 100644 index b6e5b18897..0000000000 --- a/src/bufr/ufbint.f +++ /dev/null @@ -1,454 +0,0 @@ - SUBROUTINE UFBINT(LUNIN,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBINT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM -C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF -C ABS(LUNIN) (I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN -C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). -C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A -C DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION -C AT ALL. IF UFBINT IS READING VALUES, THEN EITHER BUFR ARCHIVE -C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY -C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO -C INTERNAL MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY -C CALLED TO OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS -C ABS(LUNIN). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-11-25 J. WOOLLEN -- MODIFIED TO ADD A RETURN CODE WHEN -C MNEMONICS ARE NOT FOUND WHEN READING -C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO -C WRITE NON-EXISTING MNEMONICS -C 1996-12-17 J. WOOLLEN -- MODIFIED TO ALWAYS INITIALIZE "USR" ARRAY -C TO MISSING (10E10) WHEN BUFR FILE IS BEING -C READ -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT"; IMPROVED MACHINE -C PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR -C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM -C BORT TO BORT2 IN SOME CASES -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBINT (LUNIN, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE -C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS -C THAN ZERO, UFBINT TREATS THE BUFR FILE AS THOUGH -C IT WERE OPEN FOR INPUT -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR INPUT: THIS CAN ALSO BE A -C SINGLE TABLE D (SEQUENCE) MNEMONIC WITH EITHER 8- -C OR 16-BIT DELAYED REPLICATION (SEE REMARKS 1) -C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE -C "GENERIC" MNEMONICS NOT RELATED TO TABLE B OR D, -C THESE RETURN THE FOLLOWING INFORMATION IN -C CORRESPONDING USR LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -C REMARKS: -C 1) UFBINT CAN ALSO BE CALLED TO PROVIDE INFORMATION ABOUT A SINGLE -C TABLE D (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED -C REPLICATION IN A SUBSET WHEN THE BUFR FILE IS OPEN FOR INPUT. -C THE MNEMONIC IN STR MUST APPEAR AS IT DOES IN THE BUFR TABLE, -C I.E., BRACKETED BY "{" AND "}" OR "[" AND "]" FOR 8-BIT DELAYED -C REPLICATION, OR BRACKETED BY "(" AND ")" FOR 16-BIT DELAYED -C REPLICATION. {NOTE: THIS WILL NOT WORK FOR SEQUENCES WITH -C 1-BIT DELAYED REPLICATION (BRACKETED BY "<" AND ">"), STANDARD -C REPLICATION (BRACKETED BY "'s), OR NO REPLICATION (NO -C BRACKETING SYMBOLS).} -C -C FOR EXAMPLE: -C -C CALL UFBINT(LUNIN,PLEVL,1, 50,IRET,'{PLEVL}') -C -C WILL RETURN WITH IRET EQUAL TO THE NUMBER OF OCCURRENCES OF THE -C 8-BIT DELAYED REPLICATION SEQUENCE PLEVL IN THE SUBSET AND WITH -C (PLEVL(I),I=1,IRET) EQUAL TO THE NUMBER OF REPLICATIONS IN EACH -C OCCURRENCE OF PLEVL IN THE SUBSET. IF THERE ARE NO OCCURRENCES -C OF PLEVL IN THE SUBSET, IRET IS RETURNED AS ZERO. -C -C 2) WHEN THE BUFR FILE IS OPEN FOR OUTPUT, UFBINT CAN BE USED TO -C PRE-ALLOCATE SPACE FOR SOME OR ALL MNEMONICS WITHIN DELAYED -C REPLICATION SEQUENCES. A SUBSEQUENT CALL TO BUFR ARCHIVE -C LIBRARY ROUTINE UFBREP OR UFBSEQ THEN ACTUALLY STORES THE -C VALUES INTO THE BUFR FILES. HERE ARE TWO EXAMPLES OF THIS: -C -C EXAMPLE 1) PROBLEM: AN OUTPUT SUBSET "SEQNCE" IS LAID OUT AS -C FOLLOWS IN A BUFR TABLE (NOTE 16 CHARACTERS HAVE BEEN -C REMOVED FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN -C THIS DOCBLOCK): -C -C | SEQNCE | {PLEVL} | -C | PLEVL | WSPD WDIR TSIG PRLC TSIG PRLC TSIG PRLC | -C -C -- OR -- -C -C | SEQNCE | {PLEVL} | -C | PLEVL | WSPD WDIR "PSEQ"3 | -C | PSEQ | TSIG PRLC | -C -C IN THIS CASE THE APPLICATION PROGRAM MUST STORE VALUES WHICH -C HAVE STANDARD REPLICATION NESTED INSIDE OF A DELAYED -C REPLICATION SEQUENCE. FOR EXAMPLE, ASSUME 50 LEVELS OF WIND -C SPEED, WIND DIRECTION, OBSERVED PRESSURE, FIRST GUESS -c PRESSURE AND ANALYZED PRESSURE ARE TO BE WRITTEN TO "SEQNCE". -C -C THE FOLLOWING LOGIC WOULD ENCODE VALUES PROPERLY: -C..................................................................... -C .... -C REAL*8 DROBS(2,50) -C REAL*8 SROBS(2,150) -C .... -C DO I=1,50 -C DROBS(1,I) = Value of wind speed on level "I" -C DROBS(2,I) = Value of wind direction on level "I" -C SROBS(1,I*3-2) = Value of observed pressure on level "I" -C SROBS(2,I*3-2) = 25. ! Value in Code Table 0-08-021 (TSIG) -C ! for time sigificance (Nominal -C ! reporting time) for observed -C ! pressure on level "I" -C SROBS(1,I*3-1) = Value of first guess pressure on level "I" -C SROBS(2,I*3-1) = 27. ! Value in Code Table 0-08-021 (TSIG) -C ! for time sigificance (First guess) -C ! for first guess pressure on level "I" -C SROBS(1,I*3) = Value of analyzed pressure on level "I" -C SROBS(2,I*3) = 16. ! Value in Code Table 0-08-021 (TSIG) -C ! for time sigificance (Analysis) for -C ! analyzed pressure on level "I" -C ENDDO -C -C ! The call to UFBINT here will not only store the 50 -C ! values of WSPD and WDIR into the BUFR subset, it -C ! will also allocate the space to store three -C ! replications of TSIG and PRLC on each of the 50 -C ! delayed-replication "levels" -C CALL UFBINT(LUNIN,DROBS,2, 50,IRET,'WSPD WDIR') -C -C ! The call to UFBREP here will actually store the 150 -C ! values of both TSIG and PRLC (three values for each -C ! on 50 delayed-replication "levels") -C CALL UFBREP(LUNIN,SROBS,2,150,IRET,'TSIG PRLC') -C .... -C STOP -C END -C..................................................................... -C -C A SIMILAR EXAMPLE COULD BE PROVIDED FOR READING VALUES WHICH -C HAVE STANDARD REPLICATION NESTED WITHIN DELAYED REPLICATION, -C FROM BUFR FILES OPEN FOR INPUT. (NOT SHOWN HERE.) -C -C -C EXAMPLE 2) PROBLEM: AN INPUT SUBSET, "REPT_IN", AND AN OUTPUT -C SUBSET "REPT_OUT", ARE LAID OUT AS FOLLOWS IN A BUFR TABLE -C (NOTE 16 CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN -C TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK): -C -C | REPT_IN | YEAR MNTH DAYS HOUR MINU {PLEVL} CLAT CLON | -C | REPT_OUT | YEAR DOYR HOUR MINU {PLEVL} CLAT CLON | -C | PLEVL | PRLC TMBD REHU WDIR WSPD -C -C IN THIS CASE THE APPLICATION PROGRAM IS READING IN VALUES -C FROM A BUFR FILE CONTAINING SUBSET "REPT_IN", CONVERTING -C MONTH AND DAY TO DAY OF YEAR, AND THEN WRITING VALUES TO -C SUBSET "REPT_OUT" IN ANOTHER BUFR FILE. A CONVENIENT WAY TO -C DO THIS IS TO CALL UFBSEQ TO READ IN AND WRITE OUT THE -C VALUES, HOWEVER THIS IS COMPLICATED BY THE PRESENCE OF THE -C DELAYED-RELICATION SEQUENCE "PLEVL" BECAUSE THE OUTPUT CALL -C TO UFBSEQ DOES NOT KNOW A-PRIORI HOW MANY REPLICATIONS ARE -C NEEDED TO STORE THE CONTENTS OF "PLEVL" (IT SETS THE NUMBER -C TO ZERO BY DEFUALT). A CALL TO UFBINT IS FIRST NEEDED TO -C ALLOCATE THE SPACE AND DETERMINE THE NUMBER OF LEVELS NEEDED -C TO STORE ALL VALUES IN "PLEVL". -C -C THE FOLLOWING LOGIC WOULD PEFORM THE READ/WRITE PROPERLY: -C..................................................................... -C .... -C REAL*8 OBSI(2000),OBSO(1999),PLEVL(5,255),REPS_8 -C CHARACTER*8 SUBSET -C .... -C -C CALL DATELEN(10) -C -C ! Open input BUFR file in LUBFI and open output BUFR file in -C ! LUBFJ, both use the BUFR table in LINDX -C CALL OPENBF(LUBFI,'IN', LINDX) -C CALL OPENBF(LUBFJ,'OUT',LINDX) -C -C ! Read through the BUFR messages in the input file -C DO WHILE(IREADMG(LUBFI,SUBSET,IDATE).GE.0) -C -C ! Open message (for writing) in output file -C CALL OPENMB(LUBFJ,'REPT_OUT',IDATE) -C -C ! Read through the subsets in this input BUFR messages -C DO WHILE(IREADSB(LUBFI).EQ.0) -C -C ! This call to UFBSEQ will read in the entire contents -C ! of subset "REPT_IN", storing them into array OBSI -C ! (Note: On input, UFBSEQ knows how many replications -C of "PLEV" are present) -C CALL UFBSEQ(LUBFI,OBSI,2000,1,IRET,'REPT_IN') -C -C ! This call to UFBINT will return the number of -C ! replications ("levels") in "PLEVL" for subset -C ! "REPT_IN"" ! {see 1) above in REMARKS} -C CALL UFBINT(LUBFI,REPS_8,1,1,IRET,'{PLEVL}') -C IREPS = REPS_8 -C -C IYR = OBSI(1) -C IMO = OBSI(2) -C IDA = OBSI(3) -C CALL xxxx(IYR, IMO, IDA, JDY) ! convert month and day -C ! to day of year (JDY) -C OBSO(1) = OBSI(1) -C OBSO(2) = JDY -C DO I = 3,1999 -C OBSO(I) = OBSI(1+1) -C ENDDO -C -C PLEVL = GETBMISS() -C -C ! The call to UFBINT here will allocate the space to -C ! later allow UFBSEQ to store IREPS replications of -C ! "PLEVL" into the output BUFR subset "REPT_OUT" (note -C ! here it is simply storing missing values) -C CALL UFBINT(LUBFJ,PLEVL,5,IREPS,IRET, -C $ 'PRLC TMBD REHU WDIR WSPD') -C -C ! The call to UFBSEQ here will write out the entire -C ! contents of subset "REPT_OUT", reading them from -C ! array OBSO -C CALL UFBSEQ(LUBFJ,OBSO,1999,1,IRET,'REPT_OUT') -C -C ! Write the subset into the output BUFR message -C CALL WRITSB(LUBFJ) -C ENDDO -C -C ! All done -C -C STOP -C END -C..................................................................... -C -C -C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS -C STRING TRYBUMP UFBRW -C THIS ROUTINE IS CALLED BY: UFBINX UFBRMS -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR - REAL*8 USR(I1,I2),VAL - - DATA IFIRST1/0/,IFIRST2/0/ - - SAVE IFIRST1, IFIRST2 - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - LUNIT = ABS(LUNIN) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IM.EQ.0) GOTO 901 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 - - IO = MIN(MAX(0,IL),1) - IF(LUNIT.NE.LUNIN) IO = 0 - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.EQ.-1) IFIRST1 = 1 - IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST1 = 1 - ENDIF - GOTO 100 - ENDIF - -C PARSE OR RECALL THE INPUT STRING -C -------------------------------- - - CALL STRING(STR,LUN,I1,IO) - -C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION -C -------------------------------------------------- - - IF(IO.EQ.0) THEN - DO J=1,I2 - DO I=1,I1 - USR(I,J) = BMISS - ENDDO - ENDDO - ENDIF - -C CALL THE MNEMONIC READER/WRITER -C ------------------------------- - - CALL UFBRW(LUN,USR,I1,I2,IO,IRET) - -C IF INCOMPLETE WRITE TRY TO INITIALIZE REPLICATION SEQUENCE OR RETURN -C --------------------------------------------------------------------- - - IF(IO.EQ.1 .AND. IRET.NE.I2 .AND. IRET.GE.0) THEN - CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) - IF(IRET.NE.I2) GOTO 903 - ELSEIF(IRET.EQ.-1) THEN - IRET = 0 - ENDIF - - IF(IRET.EQ.0) THEN - IF(IO.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ELSE - IF(IPRT.EQ.-1) IFIRST2 = 1 - IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') - IF(IPRT.EQ.0) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST2 = 1 - ENDIF - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') -901 CALL BORT('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR '// - . 'FILE, NONE ARE') -902 CALL BORT('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR '// - . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// - . 'SUBSET ARRAY') -903 WRITE(BORT_STR1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS'// - . ': ",A)') STR - WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// - . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// - . ' - INCOMPLETE WRITE")') IRET,I2 - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/ufbinx.f b/src/bufr/ufbinx.f deleted file mode 100644 index 5213529a94..0000000000 --- a/src/bufr/ufbinx.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE UFBINX(LUNIT,IMSG,ISUB,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBINX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO -C LOGICAL UNIT LUNIT FOR INPUT OPERATIONS (IF IT IS NOT ALREADY -C OPENED AS SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST -C DATA MESSAGE (IF BUFR FILE ALREADY OPENED), THEN (VIA A CALL TO -C BUFR ARCHIVE LIBRARY SUBROUTINE UFBINT) READS SPECIFIED VALUES FROM -C INTERNAL SUBSET ARRAYS ASSOCIATED WITH A PARTICULAR SUBSET FROM A -C PARTICULAR BUFR MESSAGE IN A MESSAGE BUFFER. THE PARTICULAR SUBSET -C AND BUFR MESSAGE ARE BASED BASED ON THE SUBSET NUMBER IN THE -C MESSAGE AND THE MESSAGE NUMBER IN THE BUFR FILE. FINALLY, THIS -C SUBROUTINE EITHER CLOSES THE BUFR FILE IN LUNIT (IF IS WAS OPENED -C HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND POSITION -C (IF IT WAS NOT OPENED HERE). SEE UFBINT FOR MORE INFORMATION ON -C THE READING OF VALUES OUT OF A BUFR MESSAGE SUBSET. NOTE: THE -C MESSAGE NUMBER HERE DOES NOT INCLUDE THE DICTIONARY MESSAGES AT THE -C BEGINNING OF THE FILE. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION -C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION -C VERSION AT ONE TIME AND THEN REMOVED) -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- MODIFY LOGIC TO HANDLE BUFR TABLE MESSAGES -C ENCOUNTERED ANYWHERE IN THE FILE (AND NOT -C JUST AT THE BEGINNING!) -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE -C USE 'INX' ARGUMENT TO OPENBF -C -C USAGE: CALL UFBINX (LUNIT, IMSG, ISUB, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER TO READ IN -C BUFR FILE -C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR -C MESSAGE -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D -C (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED -C REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)} -C -C OUTPUT ARGUMENT LIST: -C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ -C FROM DATA SUBSET -C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM -C DATA SUBSET (MUST BE NO LARGER THAN I2) -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CLOSBF OPENBF READMG -C READSB REWNBF STATUS UFBINT -C UPB -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - LOGICAL OPENIT - REAL*8 USR(I1,I2) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - OPENIT = IL.EQ.0 - - IF(OPENIT) THEN - -C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN -C ---------------------------------------------------------------- - - CALL OPENBF(LUNIT,'INX',LUNIT) - ELSE - -C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG -C --------------------------------------------------------------------- - - CALL REWNBF(LUNIT,0) - ENDIF - -C SKIP TO MESSAGE # IMSG -C ---------------------- - -C Note that we need to use subroutine READMG to actually read in all -C of the messages (including the first (IMSG-1) messages!), just in -C case there are any embedded dictionary messages in the file. - - DO I=1,IMSG - CALL READMG(LUNIT,SUBSET,JDATE,JRET) - IF(JRET.LT.0) GOTO 901 - ENDDO - -C POSITION AT SUBSET # ISUB -C ------------------------- - - DO I=1,ISUB-1 - IF(NSUB(LUN).GT.MSUB(LUN)) GOTO 902 - IBIT = MBYT(LUN)*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - MBYT(LUN) = MBYT(LUN) + NBYT - NSUB(LUN) = NSUB(LUN) + 1 - ENDDO - - CALL READSB(LUNIT,JRET) - IF(JRET.NE.0) GOTO 902 - - CALL UFBINT(LUNIT,USR,I1,I2,IRET,STR) - - IF(OPENIT) THEN - -C CLOSE BUFR FILE IF IT WAS OPENED HERE -C ------------------------------------- - - CALL CLOSBF(LUNIT) - ELSE - - -C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE -C --------------------------------------------------------------------- - - CALL REWNBF(LUNIT,1) - ENDIF - -C EXITS -C ----- - - RETURN -901 WRITE(BORT_STR,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// - . 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO'// - . ' UNIT",I4)') IMSG,LUNIT - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// - . 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR '// - . 'FILE CONNECTED TO UNIT",I4)') ISUB,IMSG,LUNIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbmem.f b/src/bufr/ufbmem.f deleted file mode 100644 index b158af92ce..0000000000 --- a/src/bufr/ufbmem.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBMEM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH -C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY -C MSGS IN COMMON BLOCK /MSGMEM/). IF MESSAGES ARE APPENDED TO -C EXISTING MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS -C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO -C STORE ALL MESSAGES INTERNALLY WAS INCREASED -C FROM 4 MBYTES TO 8 MBYTES -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-11-15 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THERE ARE EITHER -C TOO MANY MESSAGES READ IN (I.E., .GT. -C MAXMSG) OR TOO MANY BYTES READ IN (I.E., -C .GT. MAXMEM), BUT RATHER JUST STORE MAXMSG -C MESSAGES OR MAXMEM BYTES AND PRINT A -C DIAGNOSTIC; PARAMETER MAXMEM (THE MAXIMUM -C NUMBER OF BYTES REQUIRED TO STORE ALL -C MESSAGES INTERNALLY) WAS INCREASED FROM 16 -C MBYTES TO 50 MBYTES -C 2005-11-29 J. ATOR -- USE RDMSGW AND NMWRD -C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE -C (DICTIONARY) MESSAGES -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C CALL STATUS TO GET LUN; REPLACE FORTRAN -C REWIND AND BACKSPACE WITH C ROUTINES CEWIND -C AND BACKBUFR -C -C USAGE: CALL UFBMEM (LUNIT, INEW, IRET, IUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C INEW - INTEGER: SWITCH: -C 0 = initialize internal arrays prior to -C transferring messages here -C else = append the messages transferred here to -C internal memory arrays -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED -C IUNIT - INTEGER: RETURN CODE: -C 0 = no messages were read from LUNIT, file is -C empty -C LUNIT = INEW input as 0 -C else = FORTRAN logical unit for BUFR file -C associated with initial message transferred -C to internal memory -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C -C REMARKS: -C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB -C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES -C FROM INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT CLOSBF CPDXMM ERRWRT -C IDXMSG NMWRD OPENBF RDMSGW -C STATUS CEWIND BACKBUFR -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - - CHARACTER*128 BORT_STR,ERRSTR - DIMENSION MBAY(MXMSGLD4) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE -C ---------------------------------------------------------- - - CALL OPENBF(LUNIT,'IN',LUNIT) - - IF(INEW.EQ.0) THEN - MSGP(0) = 0 - MUNIT = 0 - MLAST = 0 - NDXTS = 0 - LDXTS = 0 - NDXM = 0 - LDXM = 0 - ENDIF - - NMSG = MSGP(0) - IRET = 0 - IFLG = 0 - ITIM = 0 - -C Copy any BUFR dictionary table messages from the beginning of -C LUNIT into COMMON /MSGMEM/ for possible later use. Note that -C such a table (if one exists) is already now in scope due to the -C prior call to subroutine OPENBF, which in turn would have -C automatically called subroutines READDX, RDBFDX and MAKESTAB -C for this table. - - ITEMP = NDXTS - CALL STATUS(LUNIT,LUN,IL,IM) - CALL CEWIND(LUN) - CALL CPDXMM(LUNIT) - -C If a table was indeed present at the beginning of the file, -C then set the flag to indicate that this table is now in scope. - - IF ((ITEMP+1).EQ.NDXTS) LDXTS = NDXTS - -C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS -C ------------------------------------------------------------ - -1 CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.EQ.-1) GOTO 100 - IF(IER.EQ.-2) GOTO 900 - - IF(IDXMSG(MBAY).EQ.1) THEN - -C New "embedded" BUFR dictionary table messages have been found in -C this file. Copy them into COMMON /MSGMEM/ for later use. - - call backbufr(lun) !BACKSPACE LUNIT - CALL CPDXMM(LUNIT) - GOTO 1 - ENDIF - - NMSG = NMSG+1 - IF(NMSG .GT.MAXMSG) IFLG = 1 - LMEM = NMWRD(MBAY) - IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2 - - IF(IFLG.EQ.0) THEN - IRET = IRET+1 - DO I=1,LMEM - MSGS(MLAST+I) = MBAY(I) - ENDDO - MSGP(0) = NMSG - MSGP(NMSG) = MLAST+1 - ELSE - IF(ITIM.EQ.0) THEN - MLAST0 = MLAST - ITIM=1 - ENDIF - ENDIF - MLAST = MLAST+LMEM - GOTO 1 - -C EXITS -C ----- - -100 IF(IFLG.EQ.1) THEN - -C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW -C -------------------------------------------------- - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) - . 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ', - . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, - . ') - INCOMPLETE READ' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - MLAST=MLAST0 - ENDIF - - IF(IFLG.EQ.2) THEN - -C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW -C -------------------------------------------------- - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) - . 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ', - . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, - . ') - INCOMPLETE READ' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - MLAST=MLAST0 - ENDIF - - IF(IRET.EQ.0) THEN - CALL CLOSBF(LUNIT) - ELSE - IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) - IF(MUNIT.EQ.0) MUNIT = LUNIT - ENDIF - IUNIT = MUNIT - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE '// - . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbmex.f b/src/bufr/ufbmex.f deleted file mode 100644 index 4c38f13e07..0000000000 --- a/src/bufr/ufbmex.f +++ /dev/null @@ -1,202 +0,0 @@ - SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBMEX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-01-26 -C -C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH -C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY -C MSGS IN COMMON BLOCK /MSGMEM/). IF MESSAGES ARE APPENDED TO -C EXISTING MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS -C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. AN ARRAY IS -C ALSO RETURNED CONTAINING A LIST OF MESSAGE TYPES READ IN. -C -C THIS IS A VARIATION OF UFBMEM WHICH ENABLES MESSAGE SORTING BEFORE -C READING. BECAUSE OF THIS RE-ORDERING, EMBEDDED TABLE MESSAGES ARE -C NOT STORED IN COMMON /MSGMEM/, SINCE THEY ARE NO LONGER RELEVANT -C ONCE THE RE-ORDERING (I.E. SORTING) HAS TAKEN PLACE. INSTEAD, A -C SEPARATE UNIT NUMBER IS ADDED TO THE INPUT ARGUMENTS TO SPECIFY -C WHERE THE NECESSARY BUFR TABLE INFORMATION CAN BE FOUND. -C -C PROGRAM HISTORY LOG: -C 2012-01-26 J. WOOLLEN -- MODIFIED UFBMEM TO READ AND SORT MEMORY -C MESSAGES FOR TRANJB INGEST ROUTINES AND -C RETURN A LIST OF MESSAGE TYPES READ IN. -C ALSO, A SEPARATE INPUT ARGUMENT IS ADDED -C TO SPECIFY WHERE TO FIND THE BUFR TABLE, -C INSTEAD OF SAVING EMBEDDED DICTIONARY -C MESSAGES IN COMMON /MSGMEM/ -C -C USAGE: CALL UFBMEX (LUNIT, LUNDX, INEW, IRET, MESG) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER- -C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT -C INEW - INTEGER: SWITCH: -C 0 = initialize internal arrays prior to -C transferring messages here -C else = append the messages transferred here to -C internal memory arrays -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED -C MESG - INTEGER: ARRAY OF MESSAGE TYPES READ INTO MEMORY -C -C INPUT FILES: -C UNIT "LUNIT" - BUFR FILE -C UNIT "LUNDX" - BUFR DICTIONARY TABLE IN CHARACTER FORMAT -C -C REMARKS: -C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB -C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES -C FROM INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IUPBS01 -C NMWRD OPENBF RDMSGW -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - - CHARACTER*128 BORT_STR,ERRSTR - DIMENSION MBAY(MXMSGLD4) - INTEGER MESG(MAXMSG) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE -C ---------------------------------------------------------- - - CALL OPENBF(LUNIT,'IN',LUNDX) - - IF(INEW.EQ.0) THEN - MSGP(0) = 0 - MUNIT = 0 - MLAST = 0 - NDXTS = 0 - LDXTS = 0 - NDXM = 0 - LDXM = 0 - ENDIF - - NMSG = MSGP(0) - IRET = 0 - IFLG = 0 - ITIM = 0 - -C SET SOME FLAGS SO THAT SUBSEQUENT CALLS TO THE MESSAGE READING -C ROUTINES WILL KNOW THERE IS A BUFR TABLE IN SCOPE. - - NDXTS = 1 - LDXTS = 1 - IPMSGS(1) = 1 - -C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS -C ------------------------------------------------------------ - -1 CALL RDMSGW(LUNIT,MBAY,IER) - IF(IER.EQ.-1) GOTO 100 - IF(IER.EQ.-2) GOTO 900 - - NMSG = NMSG+1 - MESG(NMSG) = IUPBS01(MBAY,'MTYP') - IF(NMSG .GT.MAXMSG) IFLG = 1 - LMEM = NMWRD(MBAY) - IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2 - - IF(IFLG.EQ.0) THEN - IRET = IRET+1 - DO I=1,LMEM - MSGS(MLAST+I) = MBAY(I) - ENDDO - MSGP(0) = NMSG - MSGP(NMSG) = MLAST+1 - ELSE - IF(ITIM.EQ.0) THEN - MLAST0 = MLAST - ITIM=1 - ENDIF - ENDIF - MLAST = MLAST+LMEM - GOTO 1 - -C EXITS -C ----- - -100 IF(IFLG.EQ.1) THEN - -C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW -C -------------------------------------------------- - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) - . 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ', - . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, - . ') - INCOMPLETE READ' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - MLAST=MLAST0 - ENDIF - - IF(IFLG.EQ.2) THEN - -C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW -C -------------------------------------------------- - - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) - . 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ', - . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, - . ') - INCOMPLETE READ' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - MLAST=MLAST0 - ENDIF - - IF(IRET.EQ.0) THEN - CALL CLOSBF(LUNIT) - ELSE - IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) - IF(MUNIT.EQ.0) MUNIT = LUNIT - ENDIF - IUNIT = MUNIT - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '// - . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbmms.f b/src/bufr/ufbmms.f deleted file mode 100644 index 11a737dabe..0000000000 --- a/src/bufr/ufbmms.f +++ /dev/null @@ -1,109 +0,0 @@ - SUBROUTINE UFBMMS(IMSG,ISUB,SUBSET,JDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBMMS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET INTO INTERNAL -C SUBSET ARRAYS FROM A PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY -C BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE MESSAGE NUMBER IN -C INTERNAL MEMORY. THIS SUBROUTINE IS ACTUALLY A COMBINATION OF -C BUFR ARCHIVE LIBRARY SUBROUTINES RDMEMM AND RDMEMS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO -C STORE ALL MESSAGES INTERNALLY WAS INCREASED -C FROM 4 MBYTES TO 8 MBYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C -C USAGE: CALL UFBMMS (IMSG, ISUB, SUBSET, JDATE) -C INPUT ARGUMENT LIST: -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C STORAGE -C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR -C MESSAGE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE -C CONTAINING SUBSET -C JDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE -C CONTAINING SUBSET, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C -C REMARKS: -C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT RDMEMM RDMEMS STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C READ SUBSET #ISUB FROM MEMORY MESSAGE #IMSG -C ------------------------------------------- - - CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) - IF(IRET.LT.0) GOTO 900 - CALL RDMEMS(ISUB,IRET) - IF(IRET.NE.0) GOTO 901 - -C EXITS -C ----- - - RETURN -900 IF(IMSG.GT.0) THEN - WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE '// - . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '// - . 'MEMORY (",I5,")")') IMSG,MSGP(0) - ELSE - WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE '// - . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")') - ENDIF - CALL BORT(BORT_STR) -901 CALL STATUS(MUNIT,LUN,IL,IM) - WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQ. SUBSET NUMBER TO READ '// - . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// - . 'REG. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbmns.f b/src/bufr/ufbmns.f deleted file mode 100644 index 88552a5c37..0000000000 --- a/src/bufr/ufbmns.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE UFBMNS(IREP,SUBSET,IDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBMNS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET INTO INTERNAL -C SUBSET ARRAYS FROM A COLLECTION OF BUFR MESSAGES IN INTERNAL MEMORY -C BASED ON THE SUBSET NUMBER RELATIVE TO THE TOTAL NUMBER OF SUBSETS -C IN THE COLLECTION. THE SUBROUTINE DOES NOT RETURN ANY INFORMATION -C ABOUT WHICH MESSAGE NUMBER CONTAINED THE DESIRED SUBSET. IF THE -C REQUESTED SUBSET IS LARGER THAN THE TOTAL NUMBER OF SUBSETS IN -C MEMORY, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY -C SUBROUTINE BORT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO -C STORE ALL MESSAGES INTERNALLY WAS INCREASED -C FROM 4 MBYTES TO 8 MBYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2009-03-23 J. ATOR -- USE IREADMM INSTEAD OF RDMEMM; -C SIMPLIFY LOGIC -C -C USAGE: CALL UFBMNS (IREP, SUBSET, IDATE) -C INPUT ARGUMENT LIST: -C IREP - INTEGER: POINTER TO SUBSET NUMBER TO READ IN -C COLLECTION OF MESSAGES -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE -C CONTAINING SUBSET -C IDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE -C CONTAINING SUBSET, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C -C REMARKS: -C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT IREADMM NMSUB RDMEMS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - JREP = 0 - IMSG = 1 - -C READ SUBSET #ISUB FROM MEMORY MESSAGE #IMSG -C ------------------------------------------- - - DO WHILE(IREADMM(IMSG,SUBSET,IDATE).EQ.0) - IF(JREP+NMSUB(MUNIT).GE.IREP) THEN - CALL RDMEMS(IREP-JREP,IRET) - GOTO 100 - ENDIF - JREP = JREP+NMSUB(MUNIT) - ENDDO - GOTO 900 - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: UFBMNS - REQ. SUBSET NO. TO READ IN '// - . '(",I5,") EXCEEDS TOTAL NO. OF SUBSETS IN THE COLLECTION OF '// - . 'MEMORY MESSAGES (",I5,")")') IREP,JREP - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbovr.f b/src/bufr/ufbovr.f deleted file mode 100644 index 75bcdfccd2..0000000000 --- a/src/bufr/ufbovr.f +++ /dev/null @@ -1,191 +0,0 @@ - SUBROUTINE UFBOVR(LUNIT,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBOVR -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE WRITES OVER SPECIFIED VALUES WHICH EXIST -C IN CURRENT INTERNAL BUFR SUBSET ARRAYS IN A FILE OPEN FOR OUTPUT. -C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A -C DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION -C AT ALL. EITHER BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR OPENMB -C MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A BUFR -C MESSAGE WITHIN MEMORY FOR THIS LUNIT. IN ADDITION, BUFR ARCHIVE -C LIBRARY SUBROUTINE WRITSB OR INVMRG MUST HAVE BEEN CALLED TO STORE -C DATA IN THE INTERNAL OUTPUT SUBSET ARRAYS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR -C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM -C BORT TO BORT2 IN SOME CASES -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBOVR (LUNIT, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE -C WRITTEN TO DATA SUBSET -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES WRITTEN TO -C DATA SUBSET (SHOULD BE SAME AS I2) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS -C STRING TRYBUMP -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - - CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR - CHARACTER*(*) STR - REAL*8 USR(I1,I2),VAL - - DATA IFIRST1/0/,IFIRST2/0/ - - SAVE IFIRST1, IFIRST2 - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 - -C .... DK: Why check, isn't IO always 1 here? - IO = MIN(MAX(0,IL),1) - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.EQ.-1) IFIRST1 = 1 - IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST1 = 1 - ENDIF - GOTO 100 - ENDIF - -C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES -C ---------------------------------------------------- - - CALL STRING(STR,LUN,I1,IO) - CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) - - IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 904 - - IF(IRET.EQ.0) THEN - IF(IPRT.EQ.-1) IFIRST2 = 1 - IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBOVR - NO SPECIFIED VALUES WRITTEN OUT, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') - IF(IPRT.EQ.0) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST2 = 1 - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// - . 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') -904 WRITE(BORT_STR1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS'// - . ': ",A)') STR - WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// - . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// - . ' - INCOMPLETE WRITE")') IRET,I2 - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/ufbpos.f b/src/bufr/ufbpos.f deleted file mode 100644 index a3d667255f..0000000000 --- a/src/bufr/ufbpos.f +++ /dev/null @@ -1,143 +0,0 @@ - SUBROUTINE UFBPOS(LUNIT,IREC,ISUB,SUBSET,JDATE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBPOS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1995-11-22 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT POSITIONS THE -C MESSAGE POINTER TO A USER-SPECIFIED BUFR MESSAGE NUMBER IN THE FILE -C CONNECTED TO LUNIT AND THEN CALLS BUFR ARCHIVE LIBRARY SUBROUTINE -C READMG TO READ THIS BUFR MESSAGE INTO A MESSAGE BUFFER (ARRAY MBAY -C IN COMMON BLOCK /BITBUF/). IT THEN POSITIONS THE SUBSET POINTER TO -C A USER-SPECIFIED SUBSET NUMBER WITHIN THE BUFR MESSAGE AND CALLS -C BUFR ARCHIVE LIBRARY SUBROUTINE READSB TO READ THIS SUBSET INTO -C INTERNAL SUBSET ARRAYS. THE BUFR MESSAGE HERE MAY BE EITHER -C COMPRESSED OR UNCOMPRESSED. THE USER-SPECIFIED MESSAGE NUMBER DOES -C NOT INCLUDE ANY DICTIONARY MESSAGES THAT MAY BE AT THE TOP OF THE -C FILE). -C -C PROGRAM HISTORY LOG: -C 1995-11-22 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN-LINED IN PROGRAM -C NAM_STNMLIST) -C 2005-03-04 D. KEYSER -- ADDED TO BUFR ARCHIVE LIBRARY; ADDED -C DOCUMENTATION -C 2005-11-29 J. ATOR -- USE IUPBS01 AND RDMSGW -C 2006-04-14 J. ATOR -- REMOVE UNNECESSARY MOIN INITIALIZATION -C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE -C (DICTIONARY) MESSAGES -C -C USAGE: CALL UFBPOS( LUNIT, IREC, ISUB, SUBSET, JDATE ) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C IREC - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C FILE (DOES NOT INCLUDE ANY DICTIONARY MESSSAGES THAT -C MAY BE AT THE TOP OF THE FILE) -C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR -C MESSAGE -C -C OUTPUT ARGUMENT LIST: -C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE -C BEING READ -C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR -C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR -C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CEWIND NMSUB READMG -C READSB STATUS UFBCNT UPB -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - - CHARACTER*128 BORT_STR - CHARACTER*8 SUBSET - -C----------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C MAKE SURE A FILE IS OPEN FOR INPUT -C ---------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - - IF(IREC.LE.0) GOTO 902 - IF(ISUB.LE.0) GOTO 903 - -C SEE WHERE POINTERS ARE CURRENTLY LOCATED -C ---------------------------------------- - - CALL UFBCNT(LUNIT,JREC,JSUB) - -C REWIND FILE IF REQUESTED POINTERS ARE BEHIND CURRENT POINTERS -C ------------------------------------------------------------- - - IF(IREC.LT.JREC .OR. (IREC.EQ.JREC.AND.ISUB.LT.JSUB)) THEN - CALL CEWIND(LUN) - NMSG(LUN) = 0 - NSUB(LUN) = 0 - CALL UFBCNT(LUNIT,JREC,JSUB) - ENDIF - -C READ SUBSET #ISUB FROM MESSAGE #IREC FROM FILE -C ---------------------------------------------- - - DO WHILE (IREC.GT.JREC) - CALL READMG(LUNIT,SUBSET,JDATE,IRET) - IF(IRET.LT.0) GOTO 904 - CALL UFBCNT(LUNIT,JREC,JSUB) - ENDDO - - KSUB = NMSUB(LUNIT) - IF(ISUB.GT.KSUB) GOTO 905 - - DO WHILE (ISUB-1.GT.JSUB) - IBIT = MBYT(LUN)*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - MBYT(LUN) = MBYT(LUN) + NBYT - NSUB(LUN) = NSUB(LUN) + 1 - CALL UFBCNT(LUNIT,JREC,JSUB) - ENDDO - - CALL READSB(LUNIT,IRET) - IF(IRET.NE.0) GOTO 905 - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST'// - . ' BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT'// - . ', IT MUST BE OPEN FOR INPUT') -902 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// - . 'TO READ IN (",I5,") IS NOT VALID")') IREC - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED SUBSET NUMBER '// - . 'TO READ IN (",I5,") IS NOT VALID")') ISUB - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// - . 'TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN THE '// - . 'FILE (",I5,")")') IREC,JREC - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQ. SUBSET NUMBER TO READ'// - . ' IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// - . 'REQ. MESSAGE (",I5,")")') ISUB,KSUB,IREC - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbqcd.f b/src/bufr/ufbqcd.f deleted file mode 100644 index 6f88d9d29a..0000000000 --- a/src/bufr/ufbqcd.f +++ /dev/null @@ -1,95 +0,0 @@ - SUBROUTINE UFBQCD(LUNIT,NEMO,QCD) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBQCD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS IN A MNEMONIC KNOWN TO BE IN THE BUFR -C TABLE ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT, AND -C RETURNS THE DESCRIPTOR ENTRY (Y) ASSOCIATED WITH IT WHEN THE FXY -C DESCRIPTOR IS A SEQUENCE DESCRIPTOR (F=3) WITH TABLE D CATEGORY 63 -C (X=63). THIS ROUTINE WILL NOT WORK FOR ANY OTHER TYPE OF -C DESCRIPTOR OR ANY OTHER SEQUENCE DESCRIPTOR TABLE D CATEGORY. -C LUNIT MUST ALREADY BE OPENED FOR INPUT OR OUTPUT VIA A CALL TO -C OPENBF. THIS ROUTINE IS ESPECIALLY USEFUL WHEN THE CALLING PROGRAM -C IS WRITING "EVENTS" TO AN OUTPUT BUFR FILE (USUALLY THE "PREPBUFR" -C FILE) USING THE SAME BUFR TABLE SINCE THE DESCRIPTOR ENTRY (Y) HERE -C DEFINES THE EVENT PROGRAM CODE. THUS, THE CALLING PROGRAM CAN PASS -C THE PROGRAM CODE INTO VARIOUS EVENTS WITHOUT ACTUALLY KNOWING ITS -C VALUE AS LONG AS IT KNOWS THE MNEMONIC NAME ASSOCIATED WITH IT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: CALL UFBQCD (LUNIT, NEMO, QCD) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C (ASSOCIATED BUFR TABLE MAY BE INTERNAL OR EXTERNAL) -C NEMO - CHARACTER*(*): MNEMONIC -C -C OUTPUT ARGUMENT LIST: -C QCD - REAL: SEQUENCE DESCRIPTOR ENTRY (I.E., EVENT PROGRAM -C CODE) IN BUFR TABLE ASSOCIATED WITH NEMO (Y IN FXY -C DESCRIPTOR, WHERE F=3 AND X=63) -C -C REMARKS: -C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE -C UFBQCP. -C -C THIS ROUTINE CALLS: ADN30 BORT NEMTAB STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) NEMO - CHARACTER*128 BORT_STR - CHARACTER*6 FXY,ADN30 - CHARACTER*1 TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - - CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) - IF(TAB.NE.'D') GOTO 901 - - FXY = ADN30(IDN,6) - IF(FXY(2:3).NE.'63') GOTO 902 - READ(FXY(4:6),'(F3.0)',ERR=903) QCD - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') -901 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT '// - . 'DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') NEMO - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - BUFR TABLE SEQ. DESCRIPTOR '// - . 'ASSOC. WITH INPUT MNEMONIC ",A," HAS INVALID CATEGORY ",A," -'// - . ' CATEGORY MUST BE 63")') NEMO,FXY(2:3) - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - ERROR READING ENTRY '// - . '(PROGRAM CODE) FROM BUFR TBL SEQ. DESCRIPTOR ",A," ASSOC. '// - . 'WITH INPUT MNEM. ",A)') FXY,NEMO - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbqcp.f b/src/bufr/ufbqcp.f deleted file mode 100644 index 9281cc6157..0000000000 --- a/src/bufr/ufbqcp.f +++ /dev/null @@ -1,79 +0,0 @@ - SUBROUTINE UFBQCP(LUNIT,QCP,NEMO) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBQCP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS IN A FXY DESCRIPTOR ENTRY (Y) FOR A -C SEQUENCE DESCRIPTOR (F=3) WITH TABLE D CATEGORY 63 (X=63) WHEN THE -C DESCRIPTOR IS KNOWN TO BE IN THE BUFR TABLE IN LOGICAL UNIT LUNIT, -C AND RETURNS THE MNEMONIC ASSOCIATED WITH IT. THIS ROUTINE WILL NOT -C WORK FOR ANY OTHER TYPE OF DESCRIPTOR OR ANY OTHER SEQUENCE -C DESCRIPTOR TABLE D CATEGORY. LUNIT MUST ALREADY BE OPENED FOR -C INPUT OR OUTPUT VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE -C OPENBF. THIS ROUTINE IS ESPECIALLY USEFUL WHEN THE CALLING PROGRAM -C IS READING "EVENTS" FROM AN INPUT BUFR FILE IN LUNIT (USUALLY THE -C "PREPBUFR" FILE) SINCE THE DESCRIPTOR ENTRY (Y) HERE DEFINES THE -C EVENT PROGRAM CODE. THUS, THE CALLING PROGRAM CAN OBTAIN THE -C MNEMONIC NAME ASSOCIATED WITH AN EVENT PROGRAM CODE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C -C USAGE: CALL UFBQCP (LUNIT, QCP, NEMO) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C (ASSOCIATED BUFR TABLE MAY BE INTERNAL OR EXTERNAL) -C QCP - REAL: SEQUENCE DESCRIPTOR ENTRY (I.E., EVENT PROGRAM -C CODE) (Y IN FXY DESCRIPTOR) -C -C OUTPUT ARGUMENT LIST: -C NEMO - CHARACTER*(*): MNEMONIC IN BUFR TABLE ASSOCIATED WITH -C SEQUENCE DESCRIPTOR FXY WHERE F=3 AND X=63 AND -C Y=INT(QCP) -C -C REMARKS: -C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE -C UFBQCD. -C -C THIS ROUTINE CALLS: BORT IFXY NUMTAB STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*(*) NEMO - CHARACTER*1 TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - - IDN = IFXY('363000')+IFIX(QCP) -c .... get NEMO from IDN - CALL NUMTAB(LUN,IDN,NEMO,TAB,IRET) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') - END diff --git a/src/bufr/ufbrep.f b/src/bufr/ufbrep.f deleted file mode 100644 index ee59ea329c..0000000000 --- a/src/bufr/ufbrep.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE UFBREP(LUNIO,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBREP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR -C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF -C ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN -C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). -C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE EITHER: -C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE -C OR -C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN -C OVERALL SUBSET DEFINITION -C -C THE DIFFERENCE IN THE WAY UFBREP WORKS AS COMPARED TO UFBINT IS IN -C THE WAY THE MNEMONIC STRING IS INTERPRETED TO DEFINE WHICH ELEMENTS -C ARE PROCESSED AND IN WHAT ORDER. UFBREP INTERPRETS THE FIRST -C MNEMONIC IN THE STRING AS A "PIVOT". THIS MEANS THE 2ND DIMENSION -C OF THE DATA RETURNED (AS INDICATED BY ARGUMENT I2) IS DEFINED BY -C OCCURRENCES OF THE PIVOT ELEMENT FOUND WITHIN THE OVERALL SUBSET -C DEFINITION. FOR EXAMPLE, IF THE SUBSET DEFINITION CONTAINS THE -C FOLLOWING SEQUENCE OF MNEMONICS: -C {..,A,..,B,..,C,..,D,..,A,..,C,..,D,..,B,.. -C A,..,B,..,D,..,C,..,A,..,C,..,B,..,D,..}, -C THEN READING A SUBSET VIA UFBREP WITH STR = "A B C D" RETURNS THE -C FOLLOWING 4X4 MATRIX OF VALUES IN USR, USING A AS THE "PIVOT" -C MNEMONIC SINCE IT WAS THE FIRST MNEMONIC IN THE STRING: -C ( A1, B1, C1, D2, -C A2, B2, C2, D2, -C A3, B3, C3, D3, -C A4, B4, C4, D4 ) -C NOTE THAT, WHEN USING UFBREP, THE ORDER OF THE NON-PIVOT MNEMONICS -C BETWEEN EACH PIVOT IS IMMATERIAL, I.E., IN THE ABOVE EXAMPLE, UFBREP -C FINDS ALL OF THE OCCURRENCES OF MNEMONICS B, C AND D BETWEEN EACH -C PIVOT BECAUSE IT SEARCHES INDEPENDENTLY FOR EACH ONE BETWEEN -C SUCCESSIVE PIVOTS. -C -C IN CONTRAST, NOTE THERE IS ALSO A SEPARATE SUBROUTINE UFBSTP WHICH -C IS SIMILAR TO UFBREP, EXCEPT THAT UFBSTP ALWAYS STEPS FORWARD WHEN -C SEARCHING FOR EACH SUCCESSIVE NON-PIVOT MNEMONIC, RATHER THAN -C SEARCHING INDEPENDENTLY FOR EACH ONE BETWEEN SUCCESSIVE PIVOTS. -C SO IN THE ABOVE EXAMPLE WITH STR="A B C D" AND STARTING FROM EACH -C SUCCESSIVE PIVOT MNEMONIC A, UFBSTP WOULD SEARCH FORWARD FOR THE -C NEXT OCCURRENCE OF MNEMONIC B, THEN IF FOUND SEARCH FORWARD FROM -C THERE FOR THE NEXT OCCURRENCE OF C, THEN IF FOUND SEARCH FORWARD -C FROM THERE FOR THE NEXT OCCURRENCE OF D, ETC. UP UNTIL REACHING -C THE NEXT OCCURRENCE OF THE PIVOT MNEMONIC A (OR THE END OF THE DATA -C SUBSET), WITHOUT EVER DOING ANY BACKTRACKING. SO IN THE ABOVE -C EXAMPLE UFBSTP WOULD RETURN THE FOLLOWING 4x4 MATRIX OF VALUES IN -C ARRAY USR, WHERE XX DENOTES A "MISSING" VALUE: -C ( A1, B1, C1, D2, -C A2, B2, XX, XX, -C A3, B3, C3, XX, -C A4, B4, XX, XX ) -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-05-19 J. WOOLLEN -- DISABLED THE PARSING SWITCH WHICH CONTROLS -C CHECKING FOR IN THE SAME REPLICATION GROUP, -C UFBREP DOES NOT NEED THIS CHECK, AND IT -C INTERFERES WITH WHAT UFBREP CAN DO -C OTHERWISE -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR -C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM -C BORT TO BORT2 IN SOME CASES -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS -C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBREP (LUNIO, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIO - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE -C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS -C THAN ZERO, UFBREP TREATS THE BUFR FILE AS THOUGH -C IT WERE OPEN FOR INPUT -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE -C "GENERIC" MNEMONICS NOT RELATED TO TABLE B, -C THESE RETURN THE FOLLOWING INFORMATION IN -C CORRESPONDING USR LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS -C STRING UFBRP -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /ACMODE/ IAC - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR - REAL*8 USR(I1,I2),VAL - - DATA IFIRST1/0/,IFIRST2/0/ - - SAVE IFIRST1, IFIRST2 - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - LUNIT = ABS(LUNIO) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IM.EQ.0) GOTO 901 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 - - IO = MIN(MAX(0,IL),1) - IF(LUNIO.NE.LUNIT) IO = 0 - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.EQ.-1) IFIRST1 = 1 - IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST1 = 1 - ENDIF - GOTO 100 - ENDIF - -C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION -C -------------------------------------------------- - - IF(IO.EQ.0) THEN - DO J=1,I2 - DO I=1,I1 - USR(I,J) = BMISS - ENDDO - ENDDO - ENDIF - -C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES -C ---------------------------------------------------- - - IA2 = IAC - IAC = 1 - CALL STRING(STR,LUN,I1,IO) - -C CALL THE MNEMONIC READER/WRITER -C ------------------------------- - - CALL UFBRP(LUN,USR,I1,I2,IO,IRET) - IAC = IA2 - - IF(IO.EQ.1 .AND. IRET.LT.I2) GOTO 903 - - IF(IRET.EQ.0) THEN - IF(IO.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ELSE - IF(IPRT.EQ.-1) IFIRST2 = 1 - IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES WRITTEN OUT, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') - IF(IPRT.EQ.0) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST2 = 1 - ENDIF - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') -901 CALL BORT('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR '// - . 'FILE, NONE ARE') -902 CALL BORT('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR '// - . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// - . 'SUBSET ARRAY') -903 WRITE(BORT_STR1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS'// - . ': ",A)') STR - WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// - . 'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - '// - . 'INCOMPLETE WRITE")') IRET,I2 - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/ufbrms.f b/src/bufr/ufbrms.f deleted file mode 100644 index f4149fa286..0000000000 --- a/src/bufr/ufbrms.f +++ /dev/null @@ -1,154 +0,0 @@ - SUBROUTINE UFBRMS(IMSG,ISUB,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBRMS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES OUT OF A PARTICULAR -C SUBSET WHICH HAS BEEN READ INTO INTERNAL SUBSET ARRAYS FROM A -C PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY. THE DATA VALUES -C CORRESPOND TO MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION -C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. THE SUBSET -C READ IN IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE -C MESSAGE READ IN IS BASED ON THE MESSAGE NUMBER IN INTERNAL MEMORY. -C THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY -C SUBROUTINES RDMEMM, RDMEMS AND UFBINT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO -C STORE ALL MESSAGES INTERNALLY WAS INCREASED -C FROM 4 MBYTES TO 8 MBYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBRMS (IMSG, ISUB, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN -C STORAGE -C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR -C MESSAGE -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D -C (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED -C REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)} -C -C OUTPUT ARGUMENT LIST: -C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ -C FROM DATA SUBSET -C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM -C DATA SUBSET (MUST BE NO LARGER THAN I2) -C -C REMARKS: -C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT ERRWRT RDMEMM RDMEMS -C STATUS UFBINT -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*8 SUBSET - REAL*8 USR(I1,I2) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IRET = 0 - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ENDIF - -C UFBINT SUBSET #ISUB FROM MEMORY MESSAGE #IMSG -C --------------------------------------------- - - CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) - IF(IRET.LT.0) GOTO 900 - CALL RDMEMS(ISUB,IRET) - IF(IRET.NE.0) GOTO 901 - - CALL UFBINT(MUNIT,USR,I1,I2,IRET,STR) - -C EXITS -C ----- - -100 RETURN -900 IF(IMSG.GT.0) THEN - WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '// - . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '// - . 'MEMORY (",I5,")")') IMSG,MSGP(0) - ELSE - WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '// - . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")') - ENDIF - CALL BORT(BORT_STR) -901 CALL STATUS(MUNIT,LUN,IL,IM) - WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ '// - . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// - . 'REQ. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbrp.f b/src/bufr/ufbrp.f deleted file mode 100644 index 58f071fcca..0000000000 --- a/src/bufr/ufbrp.f +++ /dev/null @@ -1,145 +0,0 @@ - SUBROUTINE UFBRP(LUN,USR,I1,I2,IO,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBRP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR -C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO -C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR -C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). -C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED -C STRINGS OF MNEMONICS WHICH ARE EITHER: -C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE -C OR -C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN -C OVERALL SUBSET DEFINITION -C -C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; -C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE -C LIBRARY SUBROUTINE UFBREP. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION -C -C USAGE: CALL UFBRP (LUN, USR, I1, I2, IO, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUN: -C 0 = input file -C 1 = output file -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -C REMARKS: -C THIS ROUTINE CALLS: INVTAG -C THIS ROUTINE IS CALLED BY: UFBREP -C Normally not called by any application -C programs (they should call UFBREP). -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - - REAL*8 USR(I1,I2),VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - INS1 = 0 - INS2 = 0 - -C FIND FIRST NON-ZERO NODE IN STRING -C ---------------------------------- - - DO NZ=1,NNOD - IF(NODS(NZ).GT.0) GOTO 1 - ENDDO - GOTO 100 - -C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME -C ---------------------------------------------------- - -1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100 - IF(IO.EQ.1 .AND. IRET.EQ.I2) GOTO 100 - INS1 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN)) - IF(INS1.EQ.0) GOTO 100 - - INS2 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN)) - IF(INS2.EQ.0) INS2 = NVAL(LUN) - IRET = IRET+1 - -C READ USER VALUES -C ---------------- - - IF(IO.EQ.0 .AND. IRET.LE.I2) THEN - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INVN = INVTAG(NODS(I),LUN,INS1,INS2) - IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) - ENDIF - ENDDO - ENDIF - -C WRITE USER VALUES -C ----------------- - - IF(IO.EQ.1 .AND. IRET.LE.I2) THEN - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INVN = INVTAG(NODS(I),LUN,INS1,INS2) - IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET) - ENDIF - ENDDO - ENDIF - -C GO FOR NEXT FRAME -C ----------------- - - GOTO 1 - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/ufbrw.f b/src/bufr/ufbrw.f deleted file mode 100644 index 778af9723d..0000000000 --- a/src/bufr/ufbrw.f +++ /dev/null @@ -1,218 +0,0 @@ - SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBRW -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM -C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO -C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR -C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). -C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED -C STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION -C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. -C -C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; -C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE -C LIBRARY SUBROUTINE UFBINT. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO -C WRITE NON-EXISTING MNEMONICS -C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS -C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT; USE LSTJPB INSTEAD OF LSTRPS -C -C USAGE: CALL UFBRW (LUN, USR, I1, I2, IO, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUN: -C 0 = input file -C 1 = output file -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED -C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED -C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE -C -C REMARKS: -C THIS ROUTINE CALLS: CONWIN DRSTPL ERRWRT GETWIN -C IBFMS INVWIN LSTJPB NEWWIN -C NXTWIN -C THIS ROUTINE IS CALLED BY: TRYBUMP UFBINT -C Normally not called by any application -C programs (they should call UFBINT). -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /QUIET / IPRT - - CHARACTER*128 ERRSTR - CHARACTER*10 TAG - CHARACTER*3 TYP - REAL*8 USR(I1,I2),VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - -C LOOP OVER COND WINDOWS -C ---------------------- - - INC1 = 1 - INC2 = 1 - -1 CALL CONWIN(LUN,INC1,INC2) - IF(NNOD.EQ.0) THEN - IRET = I2 - GOTO 100 - ELSEIF(INC1.EQ.0) THEN - GOTO 100 - ELSE - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INS2 = INC1 - CALL GETWIN(NODS(I),LUN,INS1,INS2) - IF(INS1.EQ.0) GOTO 100 - GOTO 2 - ENDIF - ENDDO - IRET = -1 - GOTO 100 - ENDIF - -C LOOP OVER STORE NODES -C --------------------- - -2 IRET = IRET+1 - - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(5(A,I4))' ) - . 'BUFRLIB: UFBRW - IRET:INS1:INS2:INC1:INC2 = ', - . IRET, ':', INS1, ':', INS2, ':', INC1, ':', INC2 - CALL ERRWRT(ERRSTR) - KK = INS1 - DO WHILE ( ( INS2 - KK ) .GE. 5 ) - WRITE ( UNIT=ERRSTR, FMT='(5A10)' ) - . (TAG(INV(I,LUN)),I=KK,KK+4) - CALL ERRWRT(ERRSTR) - KK = KK+5 - ENDDO - WRITE ( UNIT=ERRSTR, FMT='(5A10)' ) - . (TAG(INV(I,LUN)),I=KK,INS2) - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C WRITE USER VALUES -C ----------------- - - IF(IO.EQ.1 .AND. IRET.LE.I2) THEN - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - IF(IBFMS(USR(I,IRET)).EQ.0) THEN - INVN = INVWIN(NODS(I),LUN,INS1,INS2) - IF(INVN.EQ.0) THEN - CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) - IF(INVN.EQ.0) THEN - IRET = 0 - GOTO 100 - ENDIF - CALL NEWWIN(LUN,INC1,INC2) - VAL(INVN,LUN) = USR(I,IRET) - ELSEIF(LSTJPB(NODS(I),LUN,'RPS').EQ.0) THEN - VAL(INVN,LUN) = USR(I,IRET) - ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN - VAL(INVN,LUN) = USR(I,IRET) - ELSE - CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) - IF(INVN.EQ.0) THEN - IRET = 0 - GOTO 100 - ENDIF - CALL NEWWIN(LUN,INC1,INC2) - VAL(INVN,LUN) = USR(I,IRET) - ENDIF - ENDIF - ENDIF - ENDDO - ENDIF - -C READ USER VALUES -C ---------------- - - IF(IO.EQ.0 .AND. IRET.LE.I2) THEN - DO I=1,NNOD - USR(I,IRET) = BMISS - IF(NODS(I).GT.0) THEN - INVN = INVWIN(NODS(I),LUN,INS1,INS2) - IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) - ENDIF - ENDDO - ENDIF - -C DECIDE WHAT TO DO NEXT -C ---------------------- - - IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100 - CALL NXTWIN(LUN,INS1,INS2) - IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 - IF(NCON.GT.0) GOTO 1 - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/ufbseq.f b/src/bufr/ufbseq.f deleted file mode 100644 index 66e73ecbb4..0000000000 --- a/src/bufr/ufbseq.f +++ /dev/null @@ -1,386 +0,0 @@ - SUBROUTINE UFBSEQ(LUNIN,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBSEQ -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM -C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF -C ABS(LUNIN) {I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN -C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET}. -C THE DATA VALUES CORRESPOND TO A SEQUENCE OF TABLE B MNEMONICS WHICH -C ARE REPRESENTED BY A SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC. -C THIS SEQUENCE MNEMONIC MAY ITSELF CONTAIN ONE OR MORE TABLE D -C SEQUENCE MNEMONICS ALONG WITH TABLE B MNEMONICS, THE SEQUENCE -C MNEMONICS HERE CAN USE EITHER DELAYED REPLICATION, REGULAR (I.E., -C NON-DELAYED) REPLICATION OR THEY CAN HAVE NO REPLICATION AT ALL. -C HOWEVER, IN CASES WHERE THIS SUBROUTINE IS WRITING DATA VALUES TO -C SEQUENCES USING DELAYED-REPLICATION, THE APPLICATION PROGRAM MUST -C FIRST CALL BUFR ARCHIVE LIBRARY ROUTINE DRFINI TO PRE-ALLOCATE THE -C SPACE NEEDED TO EXPAND THE DELAYED-REPLICATION SEQUENCE (THE NUMBER -C OF REPLICATIONS IN DELAYED-REPLICATION IS SET TO ZERO BY DEFAULT). -C (SEE BUFR ARCHIVE LIBRARY DRFINI DOCBLOCK REMARKS FOR MORE -C INFORMATION.) IF UFBSEQ IS READING VALUES, THEN EITHER BUFR ARCHIVE -C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY -C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO INTERNAL -C MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE LIBRARY -C SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO -C OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS -C ABS(LUNIN). -C -C PROGRAM HISTORY LOG: -C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR -C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY UFBSEQ -C WOULD NOT RECOGNIZE COMPRESSED DELAYED -C REPLICATION AS A LEGITIMATE DATA STRUCTURE -C 2003-05-19 J. WOOLLEN -- CORRECTED THE LOGIC ARRAY OF EXIT -C CONDITIONS FOR THE SUBROUTINE, PREVIOUSLY, -C IN SOME CASES, PROPER EXITS WERE MISSED, -C GENERATING BOGUS ERROR MESSAGES, BECAUSE OF -C SEVERAL MISCELLANEOUS BUGS WHICH ARE NOW -C REMOVED -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR -C UNUSUAL THINGS HAPPEN -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBSEQ (LUNIN, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT -C NUMBER FOR BUFR FILE -C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS -C THAN ZERO, UFBSEQ TREATS THE BUFR FILE AS THOUGH -C IT WERE OPEN FOR INPUT -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF UNIQUE TABLE B MNEMONICS REPRESENTED BY THE -C SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC IN STR -C (FORMER MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET; THIS -C CORRESPONDS TO THE NUMBER OF REPLICATIONS OF THE -C MNEMONIC IN STR -C STR - CHARACTER*(*): STRING CONTAINING A SINGLE TABLE A OR -C TABLE D SEQUENCE MNEMONIC WHOSE SEQUENCE OF TABLE B -C MNEMONICS ARE IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE -C "GENERIC" MNEMONICS NOT RELATED TO TABLE A OR D, -C THESE RETURN THE FOLLOWING INFORMATION IN -C CORRESPONDING USR LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT INVTAG INVWIN -C PARSTR STATUS -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - PARAMETER (MTAG=10) - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*10 TAG,TAGS(MTAG) - CHARACTER*3 TYP - REAL*8 USR(I1,I2),VAL - - DATA IFIRST1/0/,IFIRST2/0/ - - SAVE IFIRST1, IFIRST2 - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - LUNIT = ABS(LUNIN) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IM.EQ.0) GOTO 901 - - IO = MIN(MAX(0,IL),1) - IF(LUNIT.NE.LUNIN) IO = 0 - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.EQ.-1) IFIRST1 = 1 - IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST1 = 1 - ENDIF - GOTO 100 - ENDIF - -C CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS -C ------------------------------------------------------ - - CALL PARSTR(STR,TAGS,MTAG,NTAG,' ',.TRUE.) - IF(NTAG.LT.1) GOTO 902 - IF(NTAG.GT.1) GOTO 903 - IF(I1.LE.0) GOTO 904 - IF(I2.LE.0) GOTO 905 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 906 - - -C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION -C -------------------------------------------------- - - IF(IO.EQ.0) THEN - DO J=1,I2 - DO I=1,I1 - USR(I,J) = BMISS - ENDDO - ENDDO - ENDIF - -C FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE -C --------------------------------------------- - - DO NODE=INODE(LUN),ISC(INODE(LUN)) - IF(STR.EQ.TAG(NODE)) THEN - IF(TYP(NODE).EQ.'SEQ'.OR.TYP(NODE).EQ.'RPC') THEN - INS1 = INVTAG(NODE,LUN, 1,NVAL(LUN)) - INS2 = INVTAG(NODE,LUN,INS1+1,NVAL(LUN)) - IF(INS1.EQ.0) GOTO 200 - IF(INS2.EQ.0) INS2 = 10E5 - NODS = NODE - DO WHILE(LINK(NODS).EQ.0.AND.JMPB(NODS).GT.0) - NODS = JMPB(NODS) - ENDDO - IF(LINK(NODS).EQ.0) THEN - INSX = NVAL(LUN) - ELSEIF(LINK(NODS).GT.0) THEN - INSX = INVWIN(LINK(NODS),LUN,INS1+1,NVAL(LUN))-1 - ENDIF - INS2 = MIN(INS2,INSX) - ELSEIF(TYP(NODE).EQ.'SUB') THEN - INS1 = 1 - INS2 = NVAL(LUN) - ELSE - GOTO 907 - ENDIF - NSEQ = 0 - DO ISQ=INS1,INS2 - ITYP = ITP(INV(ISQ,LUN)) - IF(ITYP.GT.1) NSEQ = NSEQ+1 - ENDDO - IF(NSEQ.GT.I1) GOTO 908 - GOTO 1 - ENDIF - ENDDO - - GOTO 200 - -C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME -C ---------------------------------------------------- - -1 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN)) -c .... previous SP version of BUFR ARCHIVE LIBRARY has line below -c (note ".gt.") - IF(INS1.GT.NVAL(LUN)) GOTO 200 - IF(INS1.GT.0) THEN -c .... previous decoder version of BUFR ARCHIVE LIBRARY has line below -c (note ".ge.") -ccccc IF(INS1.GE.NVAL(LUN)) GOTO 200 - IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN - INS1 = INS1+1 - GOTO 1 - ELSEIF(IO.EQ.0.AND.IRET+1.GT.I2) THEN - GOTO 909 - ENDIF - ELSEIF(INS1.EQ.0) THEN - IF(IO.EQ.1.AND.IRET.LT.I2) GOTO 910 - ELSE - GOTO 911 - ENDIF - - IF(INS1.EQ. 0) GOTO 200 - IF(IRET.EQ.I2) GOTO 200 - - IRET = IRET+1 - INS1 = INS1+1 - -C READ/WRITE USER VALUES -C ---------------------- - - J = INS1 - DO I=1,NSEQ - DO WHILE(ITP(INV(J,LUN)).LT.2) - J = J+1 - ENDDO - IF(IO.EQ.0) USR(I,IRET) = VAL(J,LUN ) - IF(IO.EQ.1) VAL(J,LUN ) = USR(I,IRET) - J = J+1 - ENDDO - -C CHECK FOR NEXT FRAME -C -------------------- - - GOTO 1 - -200 CONTINUE - - IF(IRET.EQ.0) THEN - IF(IO.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ELSE - IF(IPRT.EQ.-1) IFIRST2 = 1 - IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') - IF(IPRT.EQ.0) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST2 = 1 - ENDIF - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') -901 CALL BORT('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '// - . 'FILE, NONE ARE') -902 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '// - . 'DOES NOT CONTAIN ANY MNEMONICS!!")') STR - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// - . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'// - . ',")")') STR,NTAG - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'// - . ' BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)') - . I1,TAGS(1) - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '// - . 'MUST BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)') - . I2,TAGS(1) - CALL BORT(BORT_STR) -906 CALL BORT('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// - . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// - . 'SUBSET ARRAY') -907 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// - . 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') TAGS(1),TYP(NODE) - CALL BORT(BORT_STR) -908 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'// - . '" CONSISTS OF",I4," TABLE B MNEM., .GT. THE MAX. SPECIFIED IN'// - . ' (INPUT) ARGUMENT 3 (",I3,")")') TAGS(1),NSEQ,I1 - CALL BORT(BORT_STR) -909 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' READ > '// - . 'LIMIT OF",I4," IN THE 4-TH ARG. (INPUT) - INCOMPLETE READ '// - . '(INPUT MNEMONIC IS ",A,")")') I2,TAGS(1) - CALL BORT(BORT_STR) -910 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '// - . '(",I3,") .LT. NO. REQUESTED (",I3,") - INCOMPLETE WRITE '// - . '(INPUT MNEMONIC IS ",A,")")') IRET,I2,TAGS(1) - CALL BORT(BORT_STR) -911 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE .GE. '// - . 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') INS1,TAGS(1) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbsp.f b/src/bufr/ufbsp.f deleted file mode 100644 index 68e89cf630..0000000000 --- a/src/bufr/ufbsp.f +++ /dev/null @@ -1,141 +0,0 @@ - SUBROUTINE UFBSP(LUN,USR,I1,I2,IO,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBSP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR -C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO -C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR -C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). -C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED -C STRINGS OF MNEMONICS WHICH ARE EITHER: -C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE -C OR -C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN -C OVERALL SUBSET DEFINITION -C SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE UFBRP, BUT THERE IS AN IMPORTANT DIFFERENCE (SEE BELOW). -C -C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; -C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE -C LIBRARY SUBROUTINE UFBSTP. -C -C SEE THE DOCBLOCK FOR BUFR ARCHIVE LIBRARY SUBROUTINE UFBREP FOR AN -C EXPLANATION OF HOW UFBSTP DIFFERS FROM UFBREP, AND THEREFORE HOW -C UFBSP DIFFERS FROM UFBRP. -C -C PROGRAM HISTORY LOG: -C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION -C -C USAGE: CALL UFBSP (LUN, USR, I1, I2, IO, IRET) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR -C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED -C WITH LUN: -C 0 = input file -C 1 = output file -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -C REMARKS: -C THIS ROUTINE CALLS: INVTAG -C THIS ROUTINE IS CALLED BY: UFBSTP -C Normally not called by any application -C programs (they should call UFBSTP). -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - - REAL*8 USR(I1,I2),VAL - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - INS1 = 0 - INS2 = 0 - -C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME -C ---------------------------------------------------- - -1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100 - INS1 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN)) - IF(INS1.EQ.0) GOTO 100 - - INS2 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN)) - IF(INS2.EQ.0) INS2 = NVAL(LUN) - IRET = IRET+1 - -C READ USER VALUES -C ---------------- - - IF(IO.EQ.0 .AND. IRET.LE.I2) THEN - INVM = INS1 - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INVN = INVTAG(NODS(I),LUN,INVM,INS2) - IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) - INVM = MAX(INVN,INVM) - ENDIF - ENDDO - ENDIF - -C WRITE USER VALUES -C ----------------- - - IF(IO.EQ.1 .AND. IRET.LE.I2) THEN - INVM = INS1 - DO I=1,NNOD - IF(NODS(I).GT.0) THEN - INVN = INVTAG(NODS(I),LUN,INVM,INS2) - IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET) - INVM = MAX(INVN,INVM) - ENDIF - ENDDO - ENDIF - -C GO FOR NEXT FRAME -C ----------------- - - GOTO 1 - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/ufbstp.f b/src/bufr/ufbstp.f deleted file mode 100644 index cb3fb33150..0000000000 --- a/src/bufr/ufbstp.f +++ /dev/null @@ -1,244 +0,0 @@ - SUBROUTINE UFBSTP(LUNIO,USR,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBSTP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 -C -C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM -C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE -C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF -C ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN -C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; -C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). -C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED -C STRINGS OF MNEMONICS WHICH ARE EITHER: -C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE -C OR -C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN -C OVERALL SUBSET DEFINITION -C SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE UFBREP. HOWEVER, THERE IS AN IMPORTANT DIFFERENCE IN -C HOW UFBSTP PROCESSES THE INPUT MNEMONIC STRING STR; FOR MORE DETAILS -C SEE THE EXAMPLE IN THE DOCBLOCK FOR SUBROUTINE UFBREP. -C -C PROGRAM HISTORY LOG: -C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE); OUTPUTS MORE -C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN; CHANGED CALL FROM BORT TO BORT2 IN -C SOME CASES -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL UFBSTP (LUNIO, USR, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIO - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT -C NUMBER FOR BUFR FILE -C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS -C THAN ZERO, UFBSTP TREATS THE BUFR FILE AS THOUGH -C IT WERE OPEN FOR INPUT -C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C WRITTEN TO DATA SUBSET -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE AT LEAST AS LARGE AS LATTER) -C I2 - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS -C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF USR -C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE -C "GENERIC" MNEMONICS NOT RELATED TO TABLE B, -C THESE RETURN THE FOLLOWING INFORMATION IN -C CORRESPONDING USR LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET -C NUMBER OF THIS SUBSET WITHIN THE BUFR -C MESSAGE (RECORD) NUMBER 'IREC' -C -C OUTPUT ARGUMENT LIST: -C USR - ONLY IF BUFR FILE OPEN FOR INPUT: -C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES -C READ FROM DATA SUBSET -C IRET - INTEGER: -C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF -C DATA VALUES READ FROM DATA SUBSET (MUST BE NO -C LARGER THAN I2) -C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" -C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE -C SAME AS I2) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS -C STRING UFBSP -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR - REAL*8 USR(I1,I2),VAL - - DATA IFIRST1/0/,IFIRST2/0/ - - SAVE IFIRST1, IFIRST2 - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - IRET = 0 - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - LUNIT = ABS(LUNIO) - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IM.EQ.0) GOTO 901 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 - - IO = MIN(MAX(0,IL),1) - IF(LUNIO.NE.LUNIT) IO = 0 - - IF(I1.LE.0) THEN - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ELSEIF(I2.LE.0) THEN - IF(IPRT.EQ.-1) IFIRST1 = 1 - IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST1 = 1 - ENDIF - GOTO 100 - ENDIF - -C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION -C -------------------------------------------------- - - IF(IO.EQ.0) THEN - DO J=1,I2 - DO I=1,I1 - USR(I,J) = BMISS - ENDDO - ENDDO - ENDIF - -C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES -C ---------------------------------------------------- - - CALL STRING(STR,LUN,I1,IO) - -C CALL THE MNEMONIC READER/WRITER -C ------------------------------- - - CALL UFBSP(LUN,USR,I1,I2,IO,IRET) - - IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 903 - - IF(IRET.EQ.0) THEN - IF(IO.EQ.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - ELSE - IF(IPRT.EQ.-1) IFIRST2 = 1 - IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES WRITTEN OUT, ' // - . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(STR) - CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') - IF(IPRT.EQ.0) THEN - ERRSTR = 'Note: Only the first occurrence of this WARNING ' // - . 'message is printed, there may be more. To output all ' // - . 'such messages,' - CALL ERRWRT(ERRSTR) - ERRSTR = 'modify your application program to add ' // - . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // - . 'to a BUFRLIB routine.' - CALL ERRWRT(ERRSTR) - ENDIF - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - IFIRST2 = 1 - ENDIF - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE'// - . ' OPEN') -901 CALL BORT('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR '// - . 'FILE, NONE ARE') -902 CALL BORT('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR '// - . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// - . 'SUBSET ARRAY') -903 WRITE(BORT_STR1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS'// - . ': ",A)') STR - WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// - . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// - . ' - INCOMPLETE WRITE")') IRET,I2 - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/ufbtab.f b/src/bufr/ufbtab.f deleted file mode 100644 index 3076bd76b3..0000000000 --- a/src/bufr/ufbtab.f +++ /dev/null @@ -1,564 +0,0 @@ - SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBTAB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO -C ABS(LUNIN) FOR INPUT OPERATIONS (IF IT IS NOT ALREADY OPENED AS -C SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST DATA -C MESSAGE (IF BUFR FILE ALREADY OPENED), THE EXTENT OF ITS PROCESSING -C IS DETERMINED BY THE SIGN OF LUNIN. IF LUNIN IS GREATER THAN ZERO, -C THIS SUBROUTINE READS SPECIFIED VALUES FROM ALL DATA SUBSETS IN THE -C BUFR FILE INTO INTERNAL ARRAYS AND RETURNS THESE VALUES ALONG WITH -C A COUNT OF THE SUBSETS. IF LUNIN IS LESS THAN ZERO, THIS -C SUBROUTINE RETURNS THE BUFR ARCHIVE LIBRARY'S GLOBAL VALUE FOR -C MISSING (REGARDLESS OF THE MNEMONICS SPECIFIED IN STR) -C ALONG WITH A COUNT OF THE SUBSETS (SEE REMARKS 2). FINALLY, THIS -C SUBROUTINE EITHER CLOSES THE BUFR FILE IN ABS(LUNIN) (IF IT WAS -C OPENED HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND -C POSITION (IF IT WAS NOT OPENED HERE). WHEN LUNIN IS GREATER THAN -C ZERO, THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE -C IS NO REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT -C THIS SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC -C IN EACH SUBSET). UFBTAB PROVIDES A MECHANISM WHEREBY A USER CAN -C EITHER DO A QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE -C OR MORE MNEMNONICS AMONGST ALL DATA SUBSETS FOR AN ENTIRE BUFR FILE -C (WHEN LUNIN IS GREATER THAN ZERO), OR SIMPLY OBTAIN A COUNT OF -C SUBSETS IN THE BUFR FILE (WHEN LUNIN IS LESS THAN ZERO); NO OTHER -C BUFR ARCHIVE LIBRARY ROUTINES HAVE TO BE CALLED. THIS SUBROUTINE -C IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UFBTAM EXCEPT UFBTAM -C READS SUBSETS FROM MESSAGES STORED IN INTERNAL MEMORY AND IT HAS NO -C OPTION FOR RETURNING ONLY A COUNT OF THE SUBSETS. IN ADDITION, -C UFBTAM CURRENTLY CANNOT READ DATA FROM COMPRESSED BUFR MESSAGES. -C UFBTAB CAN READ DATA FROM BOTH UNCOMPRESSED AND COMPRESSED BUFR -C MESSAGES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THERE ARE TOO -C MANY SUBSETS COMING IN (I.E., .GT. "I2"), -C BUT RATHER JUST PROCESS "I2" REPORTS AND -C PRINT A DIAGNOSTIC; MAXJL (MAXIMUM NUMBER -C OF JUMP/LINK ENTRIES) INCREASED FROM 15000 -C TO 16000 (WAS IN VERIFICATION VERSION); -C MODIFIED TO CALL ROUTINE REWNBF WHEN THE -C BUFR FILE IS ALREADY OPENED, ALLOWS -C SPECIFIC SUBSET INFORMATION TO BE READ FROM -C A FILE IN THE MIDST OF ITS BEING READ FROM -C OR WRITTEN TO), BEFORE OPENBF WAS ALWAYS -C CALLED AND THIS WOULD HAVE LED TO AN ABORT -C OF THE APPLICATION PROGRAM (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-09-16 J. WOOLLEN -- WORKS FOR COMPRESSED BUFR MESSAGES; ADDED -C OPTION TO RETURN ONLY SUBSET COUNT (WHEN -C INPUT UNIT NUMBER IS LESS THAN ZERO) -C 2006-04-14 J. ATOR -- ADD DECLARATION FOR CREF -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C 2009-04-21 J. ATOR -- USE ERRWRT -C 2009-12-01 J. ATOR -- FIX BUG FOR COMPRESSED CHARACTER STRINGS -C WHICH ARE IDENTICAL ACROSS ALL SUBSETS IN -C A SINGLE MESSAGE -C 2010-05-07 J. ATOR -- WHEN CALLING IREADMG, TREAT READ ERROR AS -C END-OF-FILE CONDITION -C 2012-03-02 J. ATOR -- USE FUNCTION UPS -C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; -C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE -C THE C FILE WITHOUT CLOSING THE FORTRAN FILE -C -C USAGE: CALL UFBTAB (LUNIN, TAB, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE -C I1 - INTEGER: -C - IF LUNIN IS GREATER THAN ZERO: LENGTH OF FIRST -C DIMENSION OF TAB OR THE NUMBER OF BLANK-SEPARATED -C MNEMONICS IN STR, (FORMER MUST BE AT LEAST AS -C LARGE AS LATTER) -C - IF LUNIN IS LESS THAN ZERO: LENGTH OF FIRST -C DIMENSION OF TAB (RECOMMEND PASSING IN WITH VALUE -C OF 1 - SEE REMARKS 2) -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB -C - IF LUNIN IS GREATER THAN ZERO: MUST BE AT LEAST AS -C LARGE AS VALUE RETURNED IN IRET, OTHERWISE ONLY -C FIRST I2 SUBSETS ARE RETURNED IN TAB -C - IF LUNIN IS LESS THAN ZERO: RECOMMEND PASSING IN -C WITH VALUE OF 1 - SEE REMARKS 2 -C STR - CHARACTER*(*): -C - IF LUNIN IS GREATER THAN ZERO: STRING OF BLANK- -C SEPARATED TABLE B MNEMONICS IN ONE-TO-ONE -C CORRESPONDENCE WITH FIRST DIMENSION OF TAB, I1 -C (THE NUMBER OF MNEMONICS IN THE STRING MUST BE NO -C LARGER THAN I1) -C - THERE ARE THREE "GENERIC" MNEMONICS NOT -C RELATED TO TABLE B, THESE RETURN THE FOLLOWING -C INFORMATION IN CORRESPONDING TAB LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR -C MESSAGE (RECORD) NUMBER IN WHICH THIS -C SUBSET RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT -C SUBSET NUMBER OF THIS SUBSET WITHIN -C THE BUFR MESSAGE (RECORD) NUMBER -C 'IREC' -C - IF LUNIN IS LESS THAN ZERO: DUMMY {RECOMMEND -C PASSING IN STRING AS A 1-CHARACTER BLANK (i.e., -C ' ') - SEE REMARKS 2} -C -C OUTPUT ARGUMENT LIST: -C TAB - REAL*8: (I1,I2): -C - IF LUNIN IS GREATER THAN ZERO: STARTING ADDRESS OF -C DATA VALUES READ FROM BUFR FILE -C - IF LUNIN IS LESS THAN ZERO: STARTING ADDRESS OF -C ARRAY OF VALUES ALL RETURNED WITH THE BUFRLIB'S -C GLOBAL VALUE FOR MISSING (BMISS) -C IRET - INTEGER: NUMBER OF DATA SUBSETS IN BUFR FILE -C - IF LUNIN IS GREATER THAN ZERO: MUST BE NO LARGER -C THAN I2, OTHERWISE ONLY FIRST I2 SUBSETS ARE -C RETURNED IN TAB -C -C REMARKS: -C 1) NOTE THAT UFBMEM CAN BE CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C 2) BELOW ARE TWO EXAMPLES WHERE THE USER CALLS UFBTAB WITH LUNIN -C LESS THAN ZERO SO AS TO ONLY OBTAIN A COUNT OF SUBSETS IN A -C BUFR FILE (ALONG WITH THE BUFRLIB'S GLOBAL VALUE FOR -C "MISSING"). -C -C EXAMPLE 1) I1 AND I2 ARE SET TO 1 SUCH THAT TAB IS A SCALAR AND -C STR IS SET TO A 1-CHARACTER BLANK. THESE ARE THE -C RECOMMENDED VALUES FOR I1, I2 AND STR SINCE THEY USE THE -C LEAST AMOUNT OF MEMORY): -C -C REAL(8) TAB -C .... -C .... -C CALL UFBTAB(-LUNIN,TAB,1,1,IRET,' ') -C .... -C .... -C -C HERE IRET WILL RETURN THE COUNT OF SUBSETS IN THE BUFR FILE -C AND TAB WILL RETURN THE BUFRLIB'S GLOBAL VALUE FOR "MISSING" -C (BMISS). -C -C EXAMPLE 2) I1 IS SET TO 4 AND I2 IS SET TO 8 SUCH THAT TAB IS A -C 32-WORD ARRAY, AND STR IS SET TO A NONSENSICAL STRING. -C THESE VALUES FOR I1, I2 AND STR WASTE MEMORY BUT GIVE THE -C SAME ANSWERS FOR TAB AND IRET AS IN EXAMPLE 1 (FOR THE SAME -C INPUT BUFR FILE!): -C -C REAL(8) TAB(4,8) -C .... -C .... -C CALL UFBTAB(-LUNIN,TAB,4,8,IRET,'BUFR IS A WONDERFUL FMT') -C .... -C .... -C -C HERE IRET WILL AGAIN RETURN THE COUNT OF SUBSETS IN THE BUFR -C FILE AND ALL 32 VALUES OF ARRAY TAB WILL RETURN THE -C BUFRLIB'S GLOBAL VALUE FOR "MISSING" (BMISS). -C -C THE SIXTH ARGUMENT STR IS A DUMMY VALUE AND CAN BE SET TO -C ANY CHARACTER STRING (AGAIN, A 1-CHARACTER BLANK ' ' IS -C RECOMMENDED). THE THIRD ARGUMENT I1 HAS NO RELATIONSHIP WITH -C THE NUMBER OF BLANK-SEPARATED MNEMONICS IN STR AND CAN BE SET -C TO ANY INTEGER VALUE (AGAIN, 1 IS RECOMMENDED). THE FOURTH -C ARGUMENT I2 HAS NO RELATIONSHIP WITH THE NUMBER OF DATA SUBSETS -C IN THE BUFR FILE RETURNED IN IRET (AGAIN, 1 IS RECOMMENDED). -C -C..................................................................... -C -C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IREADMG -C IREADSB MESGBC NMSUB OPENBF -C PARSTR REWNBF STATUS STRING -C UPB UPBB UPC UPS -C USRTPL -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /ACMODE/ IAC - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*40 CREF - CHARACTER*10 TAG,TGS(100) - CHARACTER*8 SUBSET,CVAL - CHARACTER*3 TYP - EQUIVALENCE (CVAL,RVAL) - LOGICAL OPENIT,JUST_COUNT - REAL*8 VAL,TAB(I1,I2),RVAL,UPS - - DATA MAXTG /100/ - -C----------------------------------------------------------------------- - MPS(NODE) = 2**(IBT(NODE))-1 - LPS(LBIT) = MAX(2**(LBIT)-1,1) -C----------------------------------------------------------------------- - -C SET COUNTERS TO ZERO -C -------------------- - - IRET = 0 - IREC = 0 - ISUB = 0 - IACC = IAC - -C CHECK FOR COUNT SUBSET ONLY OPTION (RETURNING THE BUFRLIB'S GLOBAL -C VALUE FOR MISSING IN OUTPUT ARRAY) INDICATED BY NEGATIVE UNIT -C ------------------------------------------------------------------ - - LUNIT = ABS(LUNIN) - JUST_COUNT = LUNIN.LT.LUNIT - - CALL STATUS(LUNIT,LUN,IL,IM) - OPENIT = IL.EQ.0 - - IF(OPENIT) THEN - -C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN -C ---------------------------------------------------------------- - - CALL OPENBF(LUNIT,'INX',LUNIT) - ELSE - -C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG -C --------------------------------------------------------------------- - - CALL REWNBF(LUNIT,0) - ENDIF - - IAC = 1 - -C SET THE OUTPUT ARRAY VALUES TO THE BUFRLIB'S GLOBAL VALUE FOR -C MISSING (BMISS) -C ------------------------------------------------------------- - - DO J=1,I2 - DO I=1,I1 - TAB(I,J) = BMISS - ENDDO - ENDDO - - IF(JUST_COUNT) THEN - -C COME HERE FOR COUNT ONLY OPTION (OUTPUT ARRAY VALUES REMAIN MISSING) -C -------------------------------------------------------------------- - - DO WHILE(IREADMG(-LUNIT,SUBSET,IDATE).GE.0) - IRET = IRET+NMSUB(LUNIT) - ENDDO - GOTO 25 - ENDIF - -C OTHERWISE, CHECK FOR SPECIAL TAGS IN STRING -C ------------------------------------------- - - CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) - DO I=1,NTG - IF(TGS(I).EQ.'IREC') IREC = I - IF(TGS(I).EQ.'ISUB') ISUB = I - ENDDO - -C READ A MESSAGE AND PARSE A STRING -C --------------------------------- - -10 IF(IREADMG(-LUNIT,SUBSET,JDATE).LT.0) GOTO 25 - CALL STRING(STR,LUN,I1,0) - IF(IREC.GT.0) NODS(IREC) = 0 - IF(ISUB.GT.0) NODS(ISUB) = 0 - -C PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT -C -------------------------------------------------------- - - CALL MESGBC(-LUNIT,MTYP,ICMP) - IF(ICMP.EQ.0) THEN - GOTO 15 - ELSEIF(ICMP.EQ.1) then - GOTO 115 - ELSE - GOTO 900 - ENDIF - -C --------------------------------------------- -C THIS BRANCH IS FOR UNCOMPRESSED MESSAGES -C --------------------------------------------- -C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE -C --------------------------------------------- - -15 IF(NSUB(LUN).EQ.MSUB(LUN)) GOTO 10 - IF(IRET+1.GT.I2) GOTO 99 - IRET = IRET+1 - - DO I=1,NNOD - NODS(I) = ABS(NODS(I)) - ENDDO - -C PARSE THE STRING NODES FROM A SUBSET -C ------------------------------------ - - MBIT = MBYT(LUN)*8 + 16 - NBIT = 0 - N = 1 - CALL USRTPL(LUN,N,N) -20 IF(N+1.LE.NVAL(LUN)) THEN - N = N+1 - NODE = INV(N,LUN) - MBIT = MBIT+NBIT - NBIT = IBT(NODE) - IF(ITP(NODE).EQ.1) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - CALL USRTPL(LUN,N,IVAL) - ENDIF - DO I=1,NNOD - IF(NODS(I).EQ.NODE) THEN - IF(ITP(NODE).EQ.1) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - TAB(I,IRET) = IVAL - ELSEIF(ITP(NODE).EQ.2) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE) - ELSEIF(ITP(NODE).EQ.3) THEN - CVAL = ' ' - KBIT = MBIT - CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT) - TAB(I,IRET) = RVAL - ENDIF - NODS(I) = -NODS(I) - GOTO 20 - ENDIF - ENDDO - DO I=1,NNOD - IF(NODS(I).GT.0) GOTO 20 - ENDDO - ENDIF - -C UPDATE THE SUBSET POINTERS BEFORE NEXT READ -C ------------------------------------------- - - IBIT = MBYT(LUN)*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - MBYT(LUN) = MBYT(LUN) + NBYT - NSUB(LUN) = NSUB(LUN) + 1 - IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN) - IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN) - GOTO 15 - -C --------------------------------------------- -C THIS BRANCH IS FOR COMPRESSED MESSAGES -C --------------------------------------------- -C STORE ANY MESSAGE AND/OR SUBSET COUNTERS -C --------------------------------------------- - -C CHECK ARRAY BOUNDS -C ------------------ - -115 IF(IRET+MSUB(LUN).GT.I2) GOTO 99 - -C STORE MESG/SUBS TOKENS -C ---------------------- - - IF(IREC.GT.0.OR.ISUB.GT.0) THEN - DO NSB=1,MSUB(LUN) - IF(IREC.GT.0) TAB(IREC,IRET+NSB) = NMSG(LUN) - IF(ISUB.GT.0) TAB(ISUB,IRET+NSB) = NSB - ENDDO - ENDIF - -C SETUP A NEW SUBSET TEMPLATE, PREPARE TO SUB-SURF -C ------------------------------------------------ - - CALL USRTPL(LUN,1,1) - IBIT = MBYT(LUN) - N = 0 - -C UNCOMPRESS CHOSEN NODES INTO THE TAB ARRAY (FIRST OCCURANCES ONLY) -C ------------------------------------------------------------------ - -C READ ELEMENTS LOOP -C ------------------ - -120 DO N=N+1,NVAL(LUN) - NODE = INV(N,LUN) - NBIT = IBT(NODE) - ITYP = ITP(NODE) - -C FIRST TIME IN RESET NODE INDEXES, OR CHECK FOR NODE(S) STILL NEEDED -C ------------------------------------------------------------------- - - IF(N.EQ.1) THEN - DO I=1,NNOD - NODS(I) = ABS(NODS(I)) - ENDDO - ELSE - DO I=1,NNOD - IF(NODS(I).GT.0) GOTO 125 - ENDDO - GOTO 135 - ENDIF - -C FIND THE EXTENT OF THE NEXT SUB-GROUP -C ------------------------------------- - -125 IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN - CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) - CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) - NIBIT = IBIT + LINC*MSUB(LUN) - ELSEIF(ITYP.EQ.3) THEN - CREF=' ' - CALL UPC(CREF,NBIT/8,MBAY(1,LUN),IBIT) - CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) - NIBIT = IBIT + 8*LINC*MSUB(LUN) - ELSE - GOTO 120 - ENDIF - -C LOOP OVER STRING NODES -C ---------------------- - - DO I=1,NNOD - -C CHOSEN NODES LOOP - KEEP TRACK OF NODES NEEDED AND NODES FOUND -C -------------------------------------------------------------- - - IF(NODE.NE.NODS(I)) GOTO 130 - NODS(I) = -NODS(I) - LRET = IRET - -C PROCESS A FOUND NODE INTO TAB -C ----------------------------- - - IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN - DO NSB=1,MSUB(LUN) - JBIT = IBIT + LINC*(NSB-1) - CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) - IVAL = LREF+NINC - LRET = LRET+1 - IF(NINC.LT.LPS(LINC)) TAB(I,LRET) = UPS(IVAL,NODE) - ENDDO - ELSEIF(ITYP.EQ.3) THEN - DO NSB=1,MSUB(LUN) - IF(LINC.EQ.0) THEN - CVAL = CREF - ELSE - JBIT = IBIT + LINC*(NSB-1)*8 - CVAL = ' ' - CALL UPC(CVAL,LINC,MBAY(1,LUN),JBIT) - ENDIF - LRET = LRET+1 - TAB(I,LRET) = RVAL - ENDDO - ELSE - CALL BORT('UFBTAB - INVALID ELEMENT TYPE SPECIFIED') - ENDIF - -C END OF LOOPS FOR COMPRESSED MESSAGE PARSING -C ------------------------------------------- - -130 CONTINUE - ENDDO - IF(ITYP.EQ.1) CALL USRTPL(LUN,N,IVAL) - IBIT = NIBIT - -C END OF READ ELEMENTS LOOP -C ------------------------- - - ENDDO -135 IRET = IRET+MSUB(LUN) - -C END OF MESSAGE PARSING - GO BACK FOR ANOTHER -C -------------------------------------------- - - GOTO 10 - -C ------------------------------------------- -C ERROR PROCESSING AND EXIT ROUTES BELOW -C ------------------------------------------- -C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW -C ------------------------------------------- - -99 NREP = IRET - DO WHILE(IREADSB(LUNIT).EQ.0) - NREP = NREP+1 - ENDDO - DO WHILE(IREADMG(-LUNIT,SUBSET,JDATE).GE.0) - NREP = NREP+NMSUB(LUNIT) - ENDDO - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' ) - . 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', - . 'IS .GT. LIMIT OF ', I2, ' IN THE 4TH ARG. (INPUT) - ', - . 'INCOMPLETE READ' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBTAB STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - -25 IF(OPENIT) THEN - -C CLOSE BUFR FILE IF IT WAS OPENED HERE -C ------------------------------------- - - CALL CLOSBF(LUNIT) - ELSE - -C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE -C --------------------------------------------------------------------- - - CALL REWNBF(LUNIT,1) - ENDIF - - IAC = IACC - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: UFBTAB - INVALID COMPRESSION '// - . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '// - . 'ROUTINE MESGBC")') ICMP - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufbtam.f b/src/bufr/ufbtam.f deleted file mode 100644 index d39198808b..0000000000 --- a/src/bufr/ufbtam.f +++ /dev/null @@ -1,283 +0,0 @@ - SUBROUTINE UFBTAM(TAB,I1,I2,IRET,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFBTAM -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES INTO INTERNAL ARRAYS -C FROM ALL DATA SUBSETS IN BUFR MESSAGES STORED IN INTERNAL MEMORY. -C THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE IS NO -C REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT THIS -C SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC IN -C EACH SUBSET). UFBTAM PROVIDES A MECHANISM WHEREBY A USER CAN DO A -C QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE OR MORE -C MNEMNONICS AMONGST ALL DATA SUBSETS FOR A GROUP OF BUFR MESSAGES -C STORED IN INTERNAL MEMORY, NO OTHER BUFR ARCHIVE LIBRARY ROUTINES -C HAVE TO BE CALLED. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE -C LIBRARY SUBROUTINE UFBTAB EXCEPT UFBTAB READS SUBSETS FROM MESSAGES -C IN A PHYSICAL BUFR FILE. UFBTAM CURRENTLY CANNOT READ DATA FROM -C COMPRESSED BUFR MESSAGES. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO -C 16 MBYTES; MODIFIED TO NOT ABORT WHEN THERE -C ARE TOO MANY SUBSETS COMING IN (I.E., .GT. -C I2), BUT RATHER JUST PROCESS I2 REPORTS AND -C PRINT A DIAGNOSTIC -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF -C BUFR MESSAGES WHICH CAN BE STORED -C INTERNALLY) INCREASED FROM 50000 TO 200000; -C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF -C BYTES REQUIRED TO STORE ALL MESSAGES -C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO -C 50 MBYTES -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C 2009-04-21 J. ATOR -- USE ERRWRT -C 2009-10-21 D. KEYSER -- ADDED OPTION TO INPUT NEW MNEMONIC "ITBL" -C IN ARGUMENT STR, RETURNS THE BUFR -C DICTIONARY TABLE NUMBER ASSOCIATED WITH -C EACH SUBSET IN INTERNAL MEMORY -C 2012-03-02 J. ATOR -- USE FUNCTION UPS -C -C USAGE: CALL UFBTAM (TAB, I1, I2, IRET, STR) -C INPUT ARGUMENT LIST: -C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF TAB OR THE -C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER -C MUST BE .GE. LATTER) -C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB -C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B -C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST -C DIMENSION OF TAB -C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED -C TO TABLE B, THESE RETURN THE FOLLOWING -C INFORMATION IN CORRESPONDING TAB LOCATION: -C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") -C 'IREC' WHICH ALWAYS RETURNS THE BUFR MESSAGE -C (RECORD) NUMBER IN WHICH EACH SUBSET IN -C INTERNAL MEMORY RESIDES -C 'ISUB' WHICH ALWAYS RETURNS THE LOCATION WITHIN -C MESSAGE "IREC" (I.E., THE SUBSET NUMBER) -C FOR EACH SUBSET IN INTERNAL MEMORY -C 'ITBL' WHICH ALWAYS RETURNS THE BUFR DICTIONARY -C TABLE NUMBER ASSOCIATED WITH EACH SUBSET -C IN INTERNAL MEMORY -C -C OUTPUT ARGUMENT LIST: -C TAB - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ -C FROM INTERNAL MEMORY -C IRET - INTEGER: NUMBER OF DATA SUBSETS IN INTERNAL MEMORY -C (MUST BE NO LARGER THAN I2) -C -C REMARKS: -C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR -C MESSAGES INTO INTERNAL MEMORY. -C -C THIS ROUTINE CALLS: BORT ERRWRT NMSUB PARSTR -C RDMEMM STATUS STRING UPB -C UPBB UPC UPS USRTPL -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM), - . MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS, - . IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),VALS(10),KONS(10) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /QUIET / IPRT - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*10 TAG,TGS(100) - CHARACTER*8 SUBSET,CVAL - CHARACTER*3 TYP - EQUIVALENCE (CVAL,RVAL) - REAL*8 TAB(I1,I2),VAL,RVAL,UPS - - DATA MAXTG /100/ - -C----------------------------------------------------------------------- - MPS(NODE) = 2**(IBT(NODE))-1 -C----------------------------------------------------------------------- - - IRET = 0 - - IF(MSGP(0).EQ.0) GOTO 100 - - DO J=1,I2 - DO I=1,I1 - TAB(I,J) = BMISS - ENDDO - ENDDO - -C CHECK FOR SPECIAL TAGS IN STRING -C -------------------------------- - - CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) - IREC = 0 - ISUB = 0 - ITBL = 0 - DO I=1,NTG - IF(TGS(I).EQ.'IREC') IREC = I - IF(TGS(I).EQ.'ISUB') ISUB = I - IF(TGS(I).EQ.'ITBL') ITBL = I - ENDDO - -C READ A MESSAGE AND PARSE A STRING -C --------------------------------- - - CALL STATUS(MUNIT,LUN,IL,IM) - - DO IMSG=1,MSGP(0) - CALL RDMEMM(IMSG,SUBSET,JDATE,MRET) - IF(MRET.LT.0) GOTO 900 - - CALL STRING(STR,LUN,I1,0) - IF(IREC.GT.0) NODS(IREC) = 0 - IF(ISUB.GT.0) NODS(ISUB) = 0 - IF(ITBL.GT.0) NODS(ITBL) = 0 - -C PROCESS ALL THE SUBSETS IN THE MEMORY MESSAGE -C --------------------------------------------- - - DO WHILE (NSUB(LUN).LT.MSUB(LUN)) - IF(IRET+1.GT.I2) GOTO 99 - IRET = IRET+1 - - DO I=1,NNOD - NODS(I) = ABS(NODS(I)) - ENDDO - - CALL USRTPL(LUN,1,1) - MBIT = MBYT(LUN)*8+16 - NBIT = 0 - N = 1 - -20 IF(N+1.LE.NVAL(LUN)) THEN - N = N+1 - NODE = INV(N,LUN) - MBIT = MBIT+NBIT - NBIT = IBT(NODE) - IF(ITP(NODE).EQ.1) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - CALL USRTPL(LUN,N,IVAL) - ENDIF - DO I=1,NNOD - IF(NODS(I).EQ.NODE) THEN - IF(ITP(NODE).EQ.1) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - TAB(I,IRET) = IVAL - ELSEIF(ITP(NODE).EQ.2) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE) - ELSEIF(ITP(NODE).EQ.3) THEN - CVAL = ' ' - KBIT = MBIT - CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT) - TAB(I,IRET) = RVAL - ENDIF - NODS(I) = -NODS(I) - GOTO 20 - ENDIF - ENDDO - DO I=1,NNOD - IF(NODS(I).GT.0) GOTO 20 - ENDDO - ENDIF - -C UPDATE THE SUBSET POINTERS BEFORE NEXT READ -C ------------------------------------------- - - IBIT = MBYT(LUN)*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - MBYT(LUN) = MBYT(LUN) + NBYT - NSUB(LUN) = NSUB(LUN) + 1 - IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN) - IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN) - IF(ITBL.GT.0) TAB(ITBL,IRET) = LDXTS - ENDDO - - ENDDO - - GOTO 200 - -C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW -C ------------------------------------------- - -99 CALL RDMEMM(0,SUBSET,JDATE,MRET) - NREP = 0 - DO IMSG=1,MSGP(0) - CALL RDMEMM(IMSG,SUBSET,JDATE,MRET) - IF(MRET.LT.0) GOTO 900 - NREP = NREP+NMSUB(MUNIT) - ENDDO - IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' ) - . 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ', - . 'IS .GT. LIMIT OF ', I2, ' IN THE 3RD ARG. (INPUT) - ', - . 'INCOMPLETE READ' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) - . '>>>UFBTAM STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C RESET THE MEMORY FILE -C --------------------- - -200 CALL RDMEMM(0,SUBSET,JDATE,MRET) - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING '// - . 'MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') IMSG - CALL BORT(BORT_STR) - END diff --git a/src/bufr/ufdump.f b/src/bufr/ufdump.f deleted file mode 100644 index 7e4c537cbc..0000000000 --- a/src/bufr/ufdump.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE UFDUMP(LUNIT,LUPRT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UFDUMP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE -C CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE -C INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT. -C LUNIT MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR -C ARCHIVE LIBRARY SUBROUTINE OPENBF. THE DATA SUBSET MUST HAVE BEEN -C SUBSEQUENTLY READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY ARRAYS VIA -C A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR READERME, -C FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR VIA -C A SINGLE CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READNS!). FOR A -C PARTICULAR SUBSET, THE PRINT LISTING CONTAINS EACH MNEMONIC -C ACCOMPANIED BY ITS CORRESPONDING DATA VALUE (INCLUDING THE ACTUAL -C BITS THAT WERE SET FOR FLAG TABLE VALUES!) AS WELL AS OTHER USEFUL -C IDENTIFICATION INFORMATION. THIS SUBROUTINE IS SIMILAR TO BUFR -C ARCHIVE LIBRARY SUBROUTINE UFBDMP EXCEPT THAT IT DOES NOT PRINT -C POINTERS, COUNTERS AND OTHER MORE ESOTERIC INFORMATION DESCRIBING -C THE INTERNAL SUBSET STRUCTURES. EACH SUBROUTINE, UFBDMP AND UFDUMP, -C IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP -C IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. WOOLLEN -- MODIFIED TO HANDLE PRINT OF CHARACTER -C VALUES GREATER THAN EIGHT BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC -C INFO WHEN ROUTINE TERMINATES ABNORMALLY -C 2004-08-18 J. ATOR -- ADDED FUZZINESS TEST AND THRESHOLD FOR -C MISSING VALUE; ADDED INTERACTIVE AND -C SCROLLING CAPABILITY SIMILAR TO UFBDMP -C 2006-04-14 J. ATOR -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET -C ACTUAL BITS THAT WERE SET TO GENERATE VALUE -C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS -C 2009-03-23 J. ATOR -- ADD LEVEL MARKERS TO OUTPUT FOR SEQUENCES -C WHERE THE REPLICATION COUNT IS > 1; OUTPUT -C ALL OCCURRENCES OF LONG CHARACTER STRINGS -C 2012-02-24 J. ATOR -- FIX MISSING CHECK FOR LONG CHARACTER STRINGS -C 2012-03-02 J. ATOR -- LABEL REDEFINED REFERENCE VALUES -C -C USAGE: CALL UFDUMP (LUNIT, LUPRT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LUPRT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT -C FILE -C 0 = LUPRT is set to 06 -C -C OUTPUT FILES: -C IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT) -C IF LUPRT = 0: UNIT 06 - STANDARD OUTPUT PRINT -C -C REMARKS: -C THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS -C AT A TIME WHEN LUPRT IS INPUT AS "0". IN THIS CASE, THE EXECUTING -C SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND -C STANDARD OUTPUT. INITIALLY, THE FIRST TWENTY ELEMENTS OF THE -C CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL, -C FOLLOWED BY THE PROMPT "( for MORE, q to QUIT)". -C IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY -C "" (e.g., ""), THE NEXT TWENTY ELEMENTS WILL BE -C DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT. THIS CONTINUES -C UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL -C ENTERS "q" FOLLOWED BY "" AFTER THE PROMPT, IN WHICH CASE -C THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING -C PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE). -C -C THIS ROUTINE CALLS: BORT ICBFMS IBFMS ISIZE -C NEMTAB READLC RJUST STATUS -C STRSUC UPFTBV -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), - . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV - - - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - - CHARACTER*80 FMT - CHARACTER*64 DESC - CHARACTER*24 UNIT - CHARACTER*120 LCHR2 - CHARACTER*20 LCHR,PMISS - CHARACTER*15 NEMO3 - CHARACTER*10 TAG,NEMO,NEMO2 - CHARACTER*6 NUMB - CHARACTER*7 FMTF - CHARACTER*8 CVAL,TAGNRV - CHARACTER*3 TYP,TYPE - CHARACTER*1 TAB,YOU - EQUIVALENCE (RVAL,CVAL) - REAL*8 VAL,RVAL - LOGICAL TRACK,FOUND,RDRV - - PARAMETER (MXFV=31) - INTEGER IFV(MXFV) - - PARAMETER (MXSEQ=10) - INTEGER IDXREP(MXSEQ) - INTEGER NUMREP(MXSEQ) - CHARACTER*10 SEQNAM(MXSEQ) - - PARAMETER (MXLS=10) - CHARACTER*10 LSNEMO(MXLS) - INTEGER LSCT(MXLS) - - DATA PMISS /' MISSING'/ - DATA YOU /'Y'/ - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - NSEQ = 0 - NLS = 0 - - IF(LUPRT.EQ.0) THEN - LUOUT = 6 - ELSE - LUOUT = LUPRT - ENDIF - -C CHECK THE FILE STATUS AND I-NODE -C -------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.GT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 - - WRITE(LUOUT,*) - WRITE(LUOUT,*) 'MESSAGE TYPE ',TAG(INODE(LUN)) - WRITE(LUOUT,*) - -C DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT LUNIT -C --------------------------------------------------- - - DO NV=1,NVAL(LUN) - IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN - -C When LUPRT=0, the output will be scrolled, 20 elements at a time -C ---------------------------------------------------------------- - - PRINT*,'( for MORE, q to QUIT)' - READ(5,'(A1)') YOU - -C If the terminal enters "q" followed by "" after the prompt -C "( for MORE, q to QUIT)", scrolling will end and the -C subroutine will return to the calling program -C ------------------------------------------------------------------- - - IF(YOU.EQ.'q') THEN - PRINT* - PRINT*,'==> You have chosen to stop the dumping of this subset' - PRINT* - GOTO 100 - ENDIF - ENDIF - - NODE = INV (NV,LUN) - NEMO = TAG (NODE) - ITYP = ITP (NODE) - TYPE = TYP (NODE) - - IF(ITYP.GE.1.AND.ITYP.LE.3) THEN - CALL NEMTAB(LUN,NEMO,IDN,TAB,N) - NUMB = TABB(N,LUN)(1:6) - DESC = TABB(N,LUN)(16:70) - UNIT = TABB(N,LUN)(71:94) - RVAL = VAL(NV,LUN) - ENDIF - - IF((ITYP.EQ.0).OR.(ITYP.EQ.1)) THEN - -C Sequence descriptor or delayed descriptor replication factor - - IF((TYPE.EQ.'REP').OR.(TYPE.EQ.'DRP').OR.(TYPE.EQ.'DRB')) THEN - -C Print the number of replications - - NSEQ = NSEQ+1 - IF(NSEQ.GT.MXSEQ) GOTO 904 - IF(TYPE.EQ.'REP') THEN - NUMREP(NSEQ) = IRF(NODE) - ELSE - NUMREP(NSEQ) = NINT(RVAL) - ENDIF - CALL STRSUC(NEMO,NEMO2,LNM2) - FMT = '(11X,A,I6,1X,A)' - WRITE(LUOUT,FMT) NEMO2(1:LNM2), NUMREP(NSEQ), 'REPLICATIONS' - -C How many times is this sequence replicated? - - IF(NUMREP(NSEQ).GT.1) THEN - -C Track the sequence - - SEQNAM(NSEQ) = NEMO - IDXREP(NSEQ) = 1 - ELSE - -C Don't bother - - NSEQ = NSEQ-1 - ENDIF - ELSEIF( ((TYPE.EQ.'SEQ').OR.(TYPE.EQ.'RPC')) - . .AND. (NSEQ.GT.0) ) THEN - -C Is this one of the sequences being tracked? - - II = NSEQ - TRACK = .FALSE. - CALL STRSUC(NEMO,NEMO2,LNM2) - DO WHILE ((II.GE.1).AND.(.NOT.TRACK)) - IF(INDEX(SEQNAM(II),NEMO2(1:LNM2)).GT.0) THEN - TRACK = .TRUE. - -C Mark this level in the output - - FMT = '(4X,A,2X,A,2X,A,I6,2X,A)' - WRITE(LUOUT,FMT) '++++++', NEMO2(1:LNM2), - . 'REPLICATION #', IDXREP(II), '++++++' - IF(IDXREP(II).LT.NUMREP(II)) THEN - -C There are more levels to come - - IDXREP(II) = IDXREP(II)+1 - ELSE - -C This was the last level for this sequence, so stop -C tracking it - - NSEQ = NSEQ-1 - ENDIF - ELSE - II = II-1 - ENDIF - ENDDO - ENDIF - ELSEIF(ITYP.EQ.2) THEN - -C Other numeric value - -C First check if this node contains a redefined reference -C value. If so, modify the DESC field to label it as such. - - JJ = 1 - RDRV = .FALSE. - DO WHILE ((JJ.LE.NNRV).AND.(.NOT.RDRV)) - IF (NODE.EQ.INODNRV(JJ)) THEN - RDRV = .TRUE. - DESC = 'NEW REFERENCE VALUE FOR ' // NUMB - UNIT = ' ' - ELSE - JJ = JJ+1 - ENDIF - ENDDO - -C Now print the value - - IF(IBFMS(RVAL).NE.0) THEN - -C The value is "missing". - - FMT = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)' - WRITE(LUOUT,FMT) NUMB,NEMO,PMISS,UNIT,DESC - ELSE - FMT = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)' - -C Based upon the corresponding scale factor, select an -C appropriate format for the printing of this value. - - WRITE(FMT(19:20),'(I2)') MAX(1,ISC(NODE)) - IF(UNIT(1:4).EQ.'FLAG') THEN - -C Print a listing of the bits corresponding to -C this value. - - CALL UPFTBV(LUNIT,NEMO,RVAL,MXFV,IFV,NIFV) - IF(NIFV.GT.0) THEN - UNIT(11:11) = '(' - IPT = 12 - DO II=1,NIFV - ISZ = ISIZE(IFV(II)) - WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)' - IF((IPT+ISZ).LE.24) THEN - WRITE(UNIT(IPT:IPT+ISZ),FMTF) IFV(II), ',' - IPT = IPT + ISZ + 1 - ELSE - UNIT(12:23) = 'MANY BITS ON' - IPT = 25 - ENDIF - ENDDO - UNIT(IPT-1:IPT-1) = ')' - ENDIF - ENDIF - WRITE(LUOUT,FMT) NUMB,NEMO,RVAL,UNIT,DESC - ENDIF - ELSEIF(ITYP.EQ.3) THEN - -C Character (CCITT IA5) value - - NCHR = IBT(NODE)/8 - - IF(IBFMS(RVAL).NE.0) THEN - LCHR = PMISS - ELSE IF(NCHR.LE.8) THEN - LCHR = CVAL - ELSE - -C Track the number of occurrences of this long character string, so -C that we can properly output each one. - - II = 1 - FOUND = .FALSE. - DO WHILE((II.LE.NLS).AND.(.NOT.FOUND)) - IF(NEMO.EQ.LSNEMO(II)) THEN - FOUND = .TRUE. - ELSE - II = II + 1 - ENDIF - ENDDO - - IF(.NOT.FOUND) THEN - NLS = NLS+1 - IF(NLS.GT.MXLS) GOTO 905 - LSNEMO(NLS) = NEMO - LSCT(NLS) = 1 - NEMO3 = NEMO - ELSE - CALL STRSUC(NEMO,NEMO3,LNM3) - LSCT(II) = LSCT(II) + 1 - WRITE(FMTF,'(A,I1,A)') '(2A,I', ISIZE(LSCT(II)), ')' - WRITE(NEMO3,FMTF) NEMO(1:LNM3), '#', LSCT(II) - ENDIF - - CALL READLC(LUNIT,LCHR2,NEMO3) - IF (ICBFMS(LCHR2,NCHR).NE.0) THEN - LCHR = PMISS - ELSE - LCHR = LCHR2(1:20) - ENDIF - ENDIF - - IF ( NCHR.LE.20 .OR. LCHR.EQ.PMISS ) THEN - IRET = RJUST(LCHR) - FMT = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)' - WRITE(LUOUT,FMT) NUMB,NEMO,LCHR,NCHR,UNIT,DESC - ELSE - FMT = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)' - WRITE(LUOUT,FMT) NUMB,NEMO,LCHR2(1:NCHR),NCHR,UNIT,DESC - ENDIF - ENDIF - - ENDDO - - WRITE(LUOUT,3) -3 FORMAT(/' >>> END OF SUBSET <<< '/) - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '// - . 'OUTPUT, IT MUST BE OPEN FOR INPUT') -902 CALL BORT('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '// - . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// - . 'INTERNAL SUBSET ARRAY') -904 CALL BORT('BUFRLIB: UFDUMP - MXSEQ OVERFLOW') -905 CALL BORT('BUFRLIB: UFDUMP - MXLS OVERFLOW') - END diff --git a/src/bufr/upb.f b/src/bufr/upb.f deleted file mode 100644 index bf3a3467e3..0000000000 --- a/src/bufr/upb.f +++ /dev/null @@ -1,69 +0,0 @@ - SUBROUTINE UPB(NVAL,NBITS,IBAY,IBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER -C CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1). -C ON OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS -C UNPACKED. THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPBB, -C EXCEPT IN UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF -C ARGUMENTS IS DIFFERENT). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-05-19 J. ATOR -- ADDED CHECK FOR NBITS EQUAL TO ZERO -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS -C IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2009-03-23 J. ATOR -- REWROTE TO CALL UPBB -C -C USAGE: CALL UPB (NVAL, NBITS, IBAY, IBIT) -C INPUT ARGUMENT LIST: -C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK -C NVAL -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED -C NVAL -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER -C WHICH TO START UNPACKING -C -C OUTPUT ARGUMENT LIST: -C NVAL - INTEGER: UNPACKED INTEGER -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT -C THAT WAS UNPACKED -C -C REMARKS: -C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE -C PKB. -C -C THIS ROUTINE CALLS: UPBB -C THIS ROUTINE IS CALLED BY: COPYSB IUPB MVB RDCMPS -C RDMGSB READSB STNDRD UFBINX -C UFBPOS UFBTAB UFBTAM UPC -C WRCMPS WRITLC -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION IBAY(*) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - CALL UPBB(NVAL,NBITS,IBIT,IBAY) - - IBIT = IBIT+NBITS - - RETURN - END diff --git a/src/bufr/upbb.f b/src/bufr/upbb.f deleted file mode 100644 index 57dd460e1f..0000000000 --- a/src/bufr/upbb.f +++ /dev/null @@ -1,82 +0,0 @@ - SUBROUTINE UPBB(NVAL,NBITS,IBIT,IBAY) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPBB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER -C CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1). -C THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPB, EXCEPT IN -C UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF ARGUMENTS IS -C DIFFERENT). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- -C LINING CODE WITH FPP DIRECTIVES -C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS -C IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- ADDED CHECK FOR NBITS EQUAL TO ZERO; -C MODIFIED LOGIC TO MAKE IT CONSISTENT WITH -C LOGIC IN UPB; UNIFIED/PORTABLE FOR WRF; -C ADDED DOCUMENTATION (INCLUDING HISTORY) -C -C USAGE: CALL UPBB (NVAL, NBITS, IBIT, IBAY) -C INPUT ARGUMENT LIST: -C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK -C NVAL -C IBIT - INTEGER: BIT POINTER WITHIN IBAY TO START UNPACKING -C FROM -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED -C NVAL -C -C OUTPUT ARGUMENT LIST: -C NVAL - INTEGER: UNPACKED INTEGER -C -C REMARKS: -C THIS ROUTINE CALLS: IREV -C THIS ROUTINE IS CALLED BY: RCSTPL RDTREE UFBGET UFBTAB -C UFBTAM UPB WRITLC -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - DIMENSION IBAY(*) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C IF NBITS=0, THEN JUST SET NVAL=0 AND RETURN -C ------------------------------------------- - - IF(NBITS.EQ.0)THEN - NVAL=0 - GOTO 100 - ENDIF - - NWD = IBIT/NBITW + 1 - NBT = MOD(IBIT,NBITW) - INT = ISHFT(IREV(IBAY(NWD)),NBT) - INT = ISHFT(INT,NBITS-NBITW) - LBT = NBT+NBITS - IF(LBT.GT.NBITW) THEN - JNT = IREV(IBAY(NWD+1)) - INT = IOR(INT,ISHFT(JNT,LBT-2*NBITW)) - ENDIF - NVAL = INT - -C EXIT -C ---- - -100 RETURN - END diff --git a/src/bufr/upc.f b/src/bufr/upc.f deleted file mode 100644 index 61d4ed9fdf..0000000000 --- a/src/bufr/upc.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE UPC(CHR,NCHR,IBAY,IBIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPC -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF -C LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF IBAY, STARTING WITH BIT -C (IBIT+1). ON OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT -C WAS UNPACKED. NOTE THAT THE STRING TO BE UNPACKED DOES NOT -C NECESSARILY NEED TO BE ALIGNED ON A BYTE BOUNDARY WITHIN IBAY. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION -C 2009-03-23 J. ATOR -- TREAT NULL CHARACTERS AS BLANKS; -C PREVENT OVERFLOW OF CHR -C -C USAGE: CALL UPC (CHR, NCHR, IBAY, IBIT) -C INPUT ARGUMENT LIST: -C NCHR - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO -C UNPACK CHR (I,E, THE NUMBER OF CHARACTERS IN CHR) -C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED -C CHR -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER -C WHICH TO START UNPACKING -C -C OUTPUT ARGUMENT LIST: -C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING OF LENGTH -C NCHR -C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT -C THAT WAS UNPACKED -C -C REMARKS: -C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE -C PKC. -C -C THIS ROUTINE CALLS: IPKM IUPM UPB -C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE READLC STNDRD -C UFBGET UFBTAB UFBTAM WRCMPS -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - - CHARACTER*(*) CHR - CHARACTER*8 CVAL - DIMENSION IBAY(*),IVAL(2) - EQUIVALENCE (CVAL,IVAL) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - LB = IORD(NBYTW) - CVAL = ' ' - - NUMCHR = MIN(NCHR,LEN(CHR)) - DO I=1,NUMCHR - CALL UPB(IVAL(1),8,IBAY,IBIT) - IF(IVAL(1).EQ.0) THEN - CHR(I:I) = ' ' - ELSE - CHR(I:I) = CVAL(LB:LB) - ENDIF - IF(IASCII.EQ.0) CALL IPKM(CHR(I:I),1,IATOE(IUPM(CHR(I:I),8))) - ENDDO - - RETURN - END diff --git a/src/bufr/upds3.f b/src/bufr/upds3.f deleted file mode 100644 index 12dfb268ad..0000000000 --- a/src/bufr/upds3.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE UPDS3(MBAY,LCDS3,CDS3,NDS3) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPDS3 -C PRGMMR: ATOR ORG: NP12 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE DESCRIPTORS -C CONTAINED WITHIN SECTION 3 OF A BUFR MESSAGE STORED IN ARRAY MBAY. -C THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE -C ALIGNED ON THE FIRST FOUR BYTES OF MBAY. NOTE ALSO THAT THIS -C SUBROUTINE DOES NOT RECURSIVELY RESOLVE SEQUENCE DESCRIPTORS THAT -C APPEAR WITHIN SECTION 3; RATHER, WHAT IS RETURNED IS THE EXACT LIST -C OF DESCRIPTORS AS IT APPEARS WITHIN SECTION 3. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. ATOR -- ORIGINAL AUTHOR (WAS IN DECODER VERSION) -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF -C 2004-08-18 J. ATOR -- REMOVED IFIRST CHECK, SINCE WRDLEN NOW -C KEEPS TRACK OF WHETHER IT HAS BEEN CALLED -C 2005-11-29 J. ATOR -- USE GETLENS -C 2009-03-23 J. ATOR -- ADDED LCDS3 ARGUMENT AND CHECK -C -C USAGE: CALL UPDS3 (MBAY, LCDS3, CDS3, NDS3) -C INPUT ARGUMENT LIST: -C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE -C LCDS3 - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF CDS3; -C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT -C OVERFLOW THE CDS3 ARRAY -C -C OUTPUT ARGUMENT LIST: -C CDS3 - CHARACTER*6: *-WORD ARRAY CONTAINING UNPACKED LIST OF -C DESCRIPTORS (FIRST NDS3 WORDS FILLED) -C NDS3 - INTEGER: NUMBER OF DESCRIPTORS RETURNED -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT IUPB GETLENS -C WRDLEN -C THIS ROUTINE IS CALLED BY: READS3 -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - DIMENSION MBAY(*) - - CHARACTER*6 CDS3(*), ADN30 - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C Call subroutine WRDLEN to initialize some important information -C about the local machine, just in case subroutine OPENBF hasn't -C been called yet. - - CALL WRDLEN - -C Skip to the beginning of Section 3. - - CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) - IPT = LEN0 + LEN1 + LEN2 - -C Unpack the Section 3 descriptors. - - NDS3 = 0 - DO JJ = 8,(LEN3-1),2 - NDS3 = NDS3 + 1 - IF(NDS3.GT.LCDS3) GOTO 900 - CDS3(NDS3) = ADN30(IUPB(MBAY,IPT+JJ,16),6) - ENDDO - - RETURN -900 CALL BORT('BUFRLIB: UPDS3 - OVERFLOW OF OUTPUT DESCRIPTOR '// - . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END diff --git a/src/bufr/upftbv.f b/src/bufr/upftbv.f deleted file mode 100644 index c8ef21ca15..0000000000 --- a/src/bufr/upftbv.f +++ /dev/null @@ -1,100 +0,0 @@ - SUBROUTINE UPFTBV(LUNIT,NEMO,VAL,MXIB,IBIT,NIB) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPFTBV -C PRGMMR: JATOR ORG: NP12 DATE: 2005-11-29 -C -C ABSTRACT: GIVEN A MNEMONIC OF TYPE "FLAG TABLE" ALONG WITH ITS -C CORRESPONDING VALUE, THIS SUBROUTINE DETERMINES THE BIT SETTINGS -C EQUIVALANT TO THAT VALUE. NOTE THAT THIS SUBROUTINE IS THE -C LOGICAL INVERSE OF BUFRLIB SUBROUTINE PKFTBV. -C -C PROGRAM HISTORY LOG: -C 2005-11-29 J. ATOR -- ORIGINAL VERSION -C -C USAGE: UPFTBV (LUNIT,NEMO,VAL,MXIB,IBIT,NIB) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C NEMO - CHARACTER*(*): MNEMONIC OF TYPE "FLAG TABLE" -C VAL - REAL*8: VALUE CORRESPONDING TO NEMO -C MXIB - INTEGER: DIMENSIONED SIZE OF IBIT IN CALLING PROGRAM -C -C OUTPUT ARGUMENT LIST: -C IBIT - INTEGER(*): BIT NUMBERS WHICH WERE SET TO "ON" -C (I.E. SET TO "1") IN VAL -C NIB - INTEGER: NUMBER OF BIT NUMBERS RETURNED IN IBIT -C -C REMARKS: -C THIS ROUTINE CALLS: BORT NEMTAB STATUS VALX -C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - - REAL*8 VAL,R8VAL,R82I - - INTEGER IBIT (*) - - CHARACTER*(*) NEMO - CHARACTER*600 TABD - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*128 BORT_STR - CHARACTER*1 TAB - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - -C Perform some sanity checks. - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - - CALL NEMTAB(LUN,NEMO,IDN,TAB,N) - IF(N.EQ.0) GOTO 901 - IF(TABB(N,LUN)(71:74).NE.'FLAG') GOTO 902 - -C Figure out which bits are set. - - NIB = 0 - R8VAL = VAL - NBITS = VALX(TABB(N,LUN)(110:112)) - DO I=(NBITS-1),0,-1 - R82I = (2.)**I - IF(ABS(R8VAL-R82I).LT.(0.005)) THEN - NIB = NIB + 1 - IF(NIB.GT.MXIB) GOTO 903 - IBIT(NIB) = NBITS-I - RETURN - ELSEIF(R82I.LT.R8VAL) THEN - NIB = NIB + 1 - IF(NIB.GT.MXIB) GOTO 903 - IBIT(NIB) = NBITS-I - R8VAL = R8VAL - R82I - ENDIF - ENDDO - - RETURN -900 CALL BORT('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR INPUT') -901 WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'// - . '" NOT FOUND IN TABLE B")') NEMO - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'// - . '" IS NOT A FLAG TABLE")') NEMO - CALL BORT(BORT_STR) -903 CALL BORT('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW') - END diff --git a/src/bufr/ups.f b/src/bufr/ups.f deleted file mode 100644 index 3fe67475d5..0000000000 --- a/src/bufr/ups.f +++ /dev/null @@ -1,97 +0,0 @@ - REAL*8 FUNCTION UPS(IVAL,NODE) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPS -C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-03-02 -C -C ABSTRACT: THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED -C BUFR INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES. -C NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX -C NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*); -C HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A -C 2-03 OPERATOR IS IN EFFECT FOR THIS NODE. -C -C PROGRAM HISTORY LOG: -C 2012-03-02 J. ATOR -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL -C STATEMENT FUNCTION IN OTHER SUBROUTINES -C -C USAGE: UPS (IVAL,NODE) -C INPUT ARGUMENT LIST: -C IVAL - INTEGER: PACKED BUFR INTEGER -C NODE - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES -C -C OUTPUT ARGUMENT LIST: -C UPS - REAL*8: USER VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: None -C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE UFBGET UFBTAB -C UFBTAM -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), - . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV - - CHARACTER*10 TAG - CHARACTER*8 TAGNRV - CHARACTER*3 TYP - - REAL*8 TEN - - DATA TEN /10./ - -C----------------------------------------------------------------------- - - UPS = ( IVAL + IRF(NODE) ) * TEN**(-ISC(NODE)) - - IF ( NNRV .GT. 0 ) THEN - -C There are redefined reference values in the jump/link table, -C so we need to check if this node is affected by any of them. - - DO JJ = 1, NNRV - IF ( NODE .EQ. INODNRV(JJ) ) THEN - -C This node contains a redefined reference value. -C Per the rules of BUFR, negative values may be encoded -C as positive integers with the left-most bit set to 1. - - IMASK = 2**(IBT(NODE)-1) - IF ( IAND(IVAL,IMASK) .GT. 0 ) THEN - NRV(JJ) = (-1) * ( IVAL - IMASK ) - ELSE - NRV(JJ) = IVAL - END IF - UPS = NRV(JJ) - RETURN - ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND. - . ( NODE .GE. ISNRV(JJ) ) .AND. - . ( NODE .LE. IENRV(JJ) ) ) THEN - -C The corresponding redefinded reference value needs to -C be used when decoding this value. - - UPS = ( IVAL + NRV(JJ) ) * TEN**(-ISC(NODE)) - RETURN - END IF - END DO - - END IF - - RETURN - END diff --git a/src/bufr/uptdd.f b/src/bufr/uptdd.f deleted file mode 100644 index 178522f9f9..0000000000 --- a/src/bufr/uptdd.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE UPTDD(ID,LUN,IENT,IRET) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: UPTDD -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE RETURNS THE BIT-WISE REPRESENTATION OF THE -C FXY VALUE CORRESPONDING TO, SEQUENTIALLY, A PARTICULAR (IENT'th) -C "CHILD" MNEMONIC OF A TABLE D SEQUENCE ("PARENT") MNEMONIC. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL UPTDD (ID, LUN, IENT, IRET) -C INPUT ARGUMENT LIST: -C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN -C INTERNAL BUFR TABLE D ARRAY TABD -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C IENT - INTEGER: ORDINAL INDICATOR OF CHILD MNEMONIC TO RETURN -C FROM WITHIN TABD(ID,LUN) SEQUENCE: -C 0 = return a count of the total number of child -C mnemonics within TABD(ID,LUN) -C -C OUTPUT ARGUMENT LIST: -C IRET - INTEGER: RETURN VALUE (SEE REMARKS) -C -C REMARKS: -C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE INPUT -C VALUE IENT, AS FOLLOWS: -C -C IF ( IENT = 0 ) THEN -C IRET = a count of the total number of child mnemonics within -C TABD(ID,LUN) -C ELSE -C IRET = the bit-wise representation of the FXY value -C corresponding to the IENT'th child mnemonic of -C TABD(ID,LUN) -C END IF -C -C -C THIS ROUTINE CALLS: BORT IUPM -C THIS ROUTINE IS CALLED BY: NEMTBD RESTD -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*56 DXSTR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - LDD = LDXD(IDXV+1)+1 - -C CHECK IF IENT IS IN BOUNDS -C -------------------------- - - NDSC = IUPM(TABD(ID,LUN)(LDD:LDD),8) - - IF(IENT.EQ.0) THEN - IRET = NDSC - GOTO 100 - ELSEIF(IENT.LT.0 .OR. IENT.GT.NDSC) THEN - GOTO 900 - ENDIF - -C RETURN THE DESCRIPTOR INDICATED BY IENT -C --------------------------------------- - - IDSC = LDD+1 + (IENT-1)*2 - IRET = IUPM(TABD(ID,LUN)(IDSC:IDSC),16) - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: UPTDD - VALUE OF THIRD ARGUMENT IENT'// - . ' (INPUT) IS OUT OF RANGE (IENT =",I4,")")') IENT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/usrtpl.f b/src/bufr/usrtpl.f deleted file mode 100644 index f807195517..0000000000 --- a/src/bufr/usrtpl.f +++ /dev/null @@ -1,250 +0,0 @@ - SUBROUTINE USRTPL(LUN,INVN,NBMP) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: USRTPL -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL -C SUBSET ARRAYS IN COMMON BLOCK /USRINT/ FOR CASES OF NODE EXPANSION -C (I.E. WHEN THE NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED -C REPLICATION FACTOR). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY) (INCOMPLETE); OUTPUTS MORE -C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY OR UNUSUAL THINGS -C HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO -C "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED -C PROBLEMS ON SOME FOREIGN MACHINES) -C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: CALL USRTPL (LUN, INVN, NBMP) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C INVN - INTEGER: STARTING JUMP/LINK TABLE INDEX OF THE NODE -C TO BE EXPANDED WITHIN THE SUBSET TEMPLATE -C NBMP - INTEGER: NUMBER OF TIMES BY WHICH INVN IS TO BE -C EXPANDED (I.E. NUMBER OF REPLICATIONS OF NODE) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT ERRWRT -C THIS ROUTINE IS CALLED BY: DRFINI DRSTPL MSGUPD OPENMB -C OPENMG RDCMPS TRYBUMP UFBGET -C UFBTAB UFBTAM WRCMPS WRITLC -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /QUIET / IPRT - - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*10 TAG - CHARACTER*3 TYP - DIMENSION ITMP(MAXJL) - LOGICAL DRP,DRS,DRB,DRX - REAL*8 VAL,VTMP(MAXJL) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I5,A,I5,A,A10)' ) - . 'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ', - . LUN, ':', INVN, ':', NBMP, ':', TAG(INODE(LUN)) - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - IF(NBMP.LE.0) THEN - IF(IPRT.GE.1) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT('BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN') - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - GOTO 100 - ENDIF - - DRP = .FALSE. - DRS = .FALSE. - DRX = .FALSE. - -C SET UP A NODE EXPANSION -C ----------------------- - - IF(INVN.EQ.1) THEN -c .... case where node is a Table A mnemonic (nodi is positional index) - NODI = INODE(LUN) - INV(1,LUN) = NODI - NVAL(LUN) = 1 - IF(NBMP.NE.1) GOTO 900 - ELSEIF(INVN.GT.0 .AND. INVN.LE.NVAL(LUN)) THEN -c .... case where node is (hopefully) a delayed replication factor - NODI = INV(INVN,LUN) - DRP = TYP(NODI) .EQ. 'DRP' - DRS = TYP(NODI) .EQ. 'DRS' - DRB = TYP(NODI) .EQ. 'DRB' - DRX = DRP .OR. DRS .OR. DRB - IVAL = VAL(INVN,LUN) - JVAL = 2**IBT(NODI)-1 - VAL(INVN,LUN) = IVAL+NBMP - IF(DRB.AND.NBMP.NE.1) GOTO 901 - IF(.NOT.DRX ) GOTO 902 - IF(IVAL.LT.0. ) GOTO 903 - IF(IVAL+NBMP.GT.JVAL) GOTO 904 - ELSE - GOTO 905 - ENDIF - -C RECALL A PRE-FAB NODE EXPANSION SEGMENT -C --------------------------------------- - - NEWN = 0 - N1 = ISEQ(NODI,1) - N2 = ISEQ(NODI,2) - - IF(N1.EQ.0 ) GOTO 906 - IF(N2-N1+1.GT.MAXJL) GOTO 907 - - DO N=N1,N2 - NEWN = NEWN+1 - ITMP(NEWN) = JSEQ(N) - VTMP(NEWN) = VALI(JSEQ(N)) - ENDDO - -C MOVE OLD NODES - STORE NEW ONES -C ------------------------------- - - IF(NVAL(LUN)+NEWN*NBMP.GT.MAXSS) GOTO 908 - - DO J=NVAL(LUN),INVN+1,-1 - INV(J+NEWN*NBMP,LUN) = INV(J,LUN) - VAL(J+NEWN*NBMP,LUN) = VAL(J,LUN) - ENDDO - - IF(DRP.OR.DRS) VTMP(1) = NEWN - KNVN = INVN - - DO I=1,NBMP - DO J=1,NEWN - KNVN = KNVN+1 - INV(KNVN,LUN) = ITMP(J) - VAL(KNVN,LUN) = VTMP(J) - ENDDO - ENDDO - -C RESET POINTERS AND COUNTERS -C --------------------------- - - NVAL(LUN) = NVAL(LUN) + NEWN*NBMP - - IF(IPRT.GE.2) THEN - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,A,A10,3(A,I5))' ) - . 'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:', - . 'NVAL(LUN) = ', TAG(INV(INVN,LUN)), ':', NEWN, ':', - . NBMP, ':', NVAL(LUN) - CALL ERRWRT(ERRSTR) - DO I=1,NEWN - WRITE ( UNIT=ERRSTR, FMT='(2(A,I5),A,A10)' ) - . 'For I = ', I, ', ITMP(I) = ', ITMP(I), - . ', TAG(ITMP(I)) = ', TAG(ITMP(I)) - CALL ERRWRT(ERRSTR) - ENDDO - CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - - IF(DRX) THEN - NODE = NODI - INVR = INVN -4 NODE = JMPB(NODE) - IF(NODE.GT.0) THEN - IF(ITP(NODE).EQ.0) THEN - DO INVR=INVR-1,1,-1 - IF(INV(INVR,LUN).EQ.NODE) THEN - VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP - GOTO 4 - ENDIF - ENDDO - GOTO 909 - ELSE - GOTO 4 - ENDIF - ENDIF - ENDIF - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// - . 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '// - . 'NODE) (",A,")")') NBMP,TAG(NODI) - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// - . 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'// - . ' (",A,")")') NBMP,TAG(NODI) - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '// - . 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")') - . TYP(NODI),TAG(NODI) - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '// - . 'NEGATIVE (=",I5,") (",A,")")') IVAL,TAG(NODI) - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'// - . ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') JVAL,TAG(NODI) - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '// - . 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'// - . ') (",A,")")') INVN,NVAL(LUN),TAG(NODI) - CALL BORT(BORT_STR) -906 WRITE(BORT_STR,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'// - . 'A,")")') TAG(NODI) - CALL BORT(BORT_STR) -907 WRITE(BORT_STR,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '// - . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI) - CALL BORT(BORT_STR) -908 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'// - . ', EXCEEDS THE LIMIT (",I6,") (",A,")")') - . NVAL(LUN)+NEWN*NBMP,MAXSS,TAG(NODI) - CALL BORT(BORT_STR) -909 WRITE(BORT_STR,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'// - . '")")') TAG(NODI) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/valx.f b/src/bufr/valx.f deleted file mode 100644 index 1052d13d34..0000000000 --- a/src/bufr/valx.f +++ /dev/null @@ -1,87 +0,0 @@ - FUNCTION VALX(STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: VALX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS FUNCTION DECODES A REAL NUMBER FROM A CHARACTER -C STRING. IF THE DECODE FAILS, THEN THE VALUE BMISS IS -C RETURNED. NOTE THAT, UNLIKE FOR SUBROUTINE STRNUM, THE INPUT -C STRING MAY CONTAIN A LEADING SIGN CHARACTER (E.G. '+', '-'). -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- RENAMED THIS FUNCTION FROM "VAL$" TO "VALX" -C TO REMOVE THE POSSIBILITY OF THE "$" SYMBOL -C CAUSING PROBLEMS ON OTHER PLATFORMS -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY; CHANGED CALL FROM BORT TO BORT2 -C 2009-04-21 J. ATOR -- USE ERRWRT -C -C USAGE: VALX (STR) -C INPUT ARGUMENT LIST: -C STR - CHARACTER*(*): STRING CONTAINING ENCODED REAL VALUE -C -C OUTPUT ARGUMENT LIST: -C VALX - REAL: DECODED VALUE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT2 ERRWRT RJUST -C THIS ROUTINE IS CALLED BY: GETTBH NEMTBB UPFTBV -C Normally not called by any application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - CHARACTER*(*) STR - CHARACTER*128 BORT_STR1,BORT_STR2 - CHARACTER*99 BSTR - CHARACTER*8 FMT - - COMMON /QUIET / IPRT - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - LENS = LEN(STR) - IF(LENS.GT.99) GOTO 900 - BSTR(1:LENS) = STR - RJ = RJUST(BSTR(1:LENS)) - WRITE(FMT,'(''(F'',I2,''.0)'')') LENS - VALX = BMISS - READ(BSTR,FMT,ERR=800) VAL - VALX = VAL - GOTO 100 -800 IF(IPRT.GE.0) THEN - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT('BUFRLIB: VALX - ERROR READING STRING:') - CALL ERRWRT(BSTR(1:LENS)) - CALL ERRWRT('RETURN WITH VALX = MISSING') - CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - CALL ERRWRT(' ') - ENDIF - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR1,'("STRING IS: ",A)') STR - WRITE(BORT_STR2,'("BUFRLIB: VALX - STRING LENGTH EXCEEDS LIMIT '// - . ' OF 99 CHARACTERS")') - CALL BORT2(BORT_STR1,BORT_STR2) - END diff --git a/src/bufr/wrcmps.f b/src/bufr/wrcmps.f deleted file mode 100644 index 7374eaa493..0000000000 --- a/src/bufr/wrcmps.f +++ /dev/null @@ -1,472 +0,0 @@ - SUBROUTINE WRCMPS(LUNIX) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRCMPS -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY -C (ARRAY IBAY IN COMMON BLOCK /BITBUF/), STORING IT FOR COMPRESSION. -C IT THEN TRIES TO ADD IT TO THE COMPRESSED BUFR MESSAGE THAT IS -C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNIX) (ARRAY MESG). IF THE -C SUBSET WILL NOT FIT INTO THE CURRENTLY OPEN MESSAGE, THEN THAT -C COMPRESSED MESSAGE IS FLUSHED TO LUNIX AND A NEW ONE IS CREATED IN -C ORDER TO HOLD THE CURRENT SUBSET (STILL STORED FOR COMPRESSION). -C THIS SUBROUTINE PERFORMS FUNCTIONS SIMILAR TO BUFR ARCHIVE LIBRARY -C SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); LOGICAL VARIABLES -C "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL -C MEMORY (IN COMMON BLOCK /COMPRS/), THIS -C FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD -C TO MESSAGES BEING WRITTEN OUT BEFORE THEY -C ARE FULL; UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-18 J. ATOR -- REMOVE CALL TO XMSGINI (CMSGINI NOW HAS -C SAME CAPABILITY); IMPROVE DOCUMENTATION; -C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS -C THE SAME FOR ALL SUBSETS IN A MESSAGE; -C MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2004-08-18 J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST' -C 2) ADDED 'KMISS' TO FIX BUG WHICH WOULD -C OCCASIONALLY SKIP OVER SUBSETS -C 3) ADDED LOGIC TO MAKE SURE MISSING VALUES -C ARE REPRESENTED BY INCREMENTS WITH ALL -C BITS ON -C 4) REMOVED TWO UNECESSARY REFERENCES TO -C 'WRIT1' -C 2005-11-29 J. ATOR -- FIX INITIALIZATION BUG FOR CHARACTER -C COMPRESSION; INCREASE MXCSB TO 4000; -C USE IUPBS01; CHECK EDITION NUMBER OF BUFR -C MESSAGE BEFORE PADDING TO AN EVEN BYTE COUNT -C 2009-03-23 J. ATOR -- ADDED SAVE FOR IBYT AND JBIT; USE MSGFULL -C 2009-08-11 J. WOOLLEN -- MADE CATX AND CSTR BIGGER TO HANDLE LONGER -C STRINGS. ALSO SEPARATED MATX,CATX,NCOL FROM -C OTHER VARS IN COMMON COMPRS FOR USE IN -C SUBROUTINE WRITLC. ALSO PASSED MBAY(1,LUN) -C AS ARRAY TO INITIAL CALL TO CMSGINI IN ORDER -C FOR USE BY WRITLC. -C 2012-02-17 J. ATOR -- FIXED A BUG INVOLVING COMPRESSED FILES WITH -C EMBEDDED DICTIONARY MESSAGES -C -C USAGE: CALL WRCMPS (LUNIX) -C INPUT ARGUMENT LIST: -C LUNIX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A -C "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT) -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CMSGINI IUPBS01 MSGFULL -C MSGWRT PKB PKC STATUS -C UPB UPC USRTPL -C THIS ROUTINE IS CALLED BY: CLOSMG WRITSA WRITSB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB) - COMMON /COMPRX/ KMIN(MXCDV),KMAX(MXCDV),KMIS(MXCDV),KBIT(MXCDV), - . ITYP(MXCDV),IWID(MXCDV),NROW,LUNC,KBYT,WRIT1, - . FLUSH,CSTR(MXCDV) - COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) - - CHARACTER*(MXLCC) CATX,CSTR - CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*8 SUBSET,CMNEM - CHARACTER*3 TYP - - LOGICAL MSGFULL - - DIMENSION MESG(MXMSGLD4) - -C NOTE THE FOLLOWING LOGICAL FLAGS: -C FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE -C FIRST SUBSET OF A NEW MESSAGE -C FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED -C WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY -C PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY -C IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!) -C WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS -C TO BE WRITTEN OUT - - LOGICAL FIRST,FLUSH,WRIT1,KMIS,KMISS,EDGE4 - REAL*8 VAL - - DATA FIRST /.TRUE./ - - SAVE FIRST,IBYT,JBIT,SUBSET - -C----------------------------------------------------------------------- - RLN2 = 1./LOG(2.) -C----------------------------------------------------------------------- - -C GET THE UNIT AND SUBSET TAG -C --------------------------- - - LUNIT = ABS(LUNIX) - CALL STATUS(LUNIT,LUN,IL,IM) - -C IF THIS IS A "FIRST" CALL, THEN INITIALIZE SOME VALUES IN -C ORDER TO PREPARE FOR THE CREATION OF A NEW COMPRESSED BUFR -C MESSAGE FOR OUTPUT. - - 1 IF(FIRST) THEN - KBYT = 0 - NCOL = 0 - LUNC = LUN - NROW = NVAL(LUN) - SUBSET = TAG(INODE(LUN)) - FIRST = .FALSE. - FLUSH = .FALSE. - WRIT1 = .FALSE. - -C THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE -C HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY -C THE INFORMATION IN SECTIONS 0, 1, 2 AND 3. THIS WILL -C ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL -C FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB. LATER ON, -C A SEPARATE CALL TO CMSGINI WILL BE DONE TO ACTUALLY -C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED -C BUFR MESSAGE THAT WILL BE WRITTEN OUT. - - CALL CMSGINI(LUN,MBAY(1,LUN),SUBSET,IDATE(LUN),NCOL,KBYT) - -C CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED - - EDGE4 = .FALSE. - IF(NS01V.GT.0) THEN - II = 1 - DO WHILE ( (.NOT.EDGE4) .AND. (II.LE.NS01V) ) - IF( (CMNEM(II).EQ.'BEN') .AND. (IVMNEM(II).GE.4) ) THEN - EDGE4 = .TRUE. - ELSE - II = II+1 - ENDIF - ENDDO - ENDIF - - ENDIF - - IF(LUN.NE.LUNC) GOTO 900 - -C IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT -C THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE -C THE FINAL COMPRESSED BUFR MESSAGE. - - IF(LUNIX.LT.0) THEN - IF(NCOL.EQ.0) GOTO 100 - IF(NCOL.GT.0) THEN - FLUSH = .TRUE. - WRIT1 = .TRUE. - ICOL = 1 - GOTO 20 - ENDIF - ENDIF - -C CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS -C --------------------------------------------------- - - IF(NCOL+1.GT.MXCSB) THEN - GOTO 50 - ELSEIF(NVAL(LUN).NE.NROW) THEN - GOTO 50 - ELSEIF(NVAL(LUN).GT.MXCDV) THEN - GOTO 901 - ENDIF - -C STORE THE NEXT SUBSET FOR COMPRESSION -C ------------------------------------- - -C WILL THE CURRENT SUBSET FIT INTO THE CURRENT MESSAGE? -C (UNFORTUNATELY, THE ONLY WAY TO FIND OUT IS TO ACTUALLY -C RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL -C REFERENCE VALUES, INCREMENTS, ETC.) - - 10 NCOL = NCOL+1 - ICOL = NCOL - IBIT = 16 - DO I=1,NVAL(LUN) - NODE = INV(I,LUN) - ITYP(I) = ITP(NODE) - IWID(I) = IBT(NODE) - IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN - CALL UPB(MATX(I,NCOL),IBT(NODE),IBAY,IBIT) - ELSEIF(ITYP(I).EQ.3) THEN - CALL UPC(CATX(I,NCOL),IBT(NODE)/8,IBAY,IBIT) - ENDIF - ENDDO - -C COMPUTE THE MIN,MAX,WIDTH FOR EACH ROW - ACCUMULATE LENGTH -C ---------------------------------------------------------- - -C LDATA WILL HOLD THE LENGTH IN BITS OF THE COMPRESSED DATA -C (I.E. THE SUM TOTAL FOR ALL DATA VALUES FOR ALL SUBSETS -C IN THE MESSAGE) - - 20 LDATA = 0 - IF(NCOL.LE.0) GOTO 902 - DO I=1,NROW - IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) THEN - -C ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES, -C SO KMIS(I) WILL STORE: -C .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING" -C .TRUE. OTHERWISE - - IMISS = 2**IWID(I)-1 - IF(ICOL.EQ.1) THEN - KMIN(I) = IMISS - KMAX(I) = 0 - KMIS(I) = .FALSE. - ENDIF - DO J=ICOL,NCOL - IF(MATX(I,J).LT.IMISS) THEN - KMIN(I) = MIN(KMIN(I),MATX(I,J)) - KMAX(I) = MAX(KMAX(I),MATX(I,J)) - ELSE - KMIS(I) = .TRUE. - ENDIF - ENDDO - KMISS = KMIS(I).AND.KMIN(I).LT.IMISS - RANGE = MAX(1,KMAX(I)-KMIN(I)+1) - IF(ITYP(I).EQ.1.AND.RANGE.GT.1) THEN - -C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX -C ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE -C NOT ALL IDENTICAL (I.E. RANGE.GT.1), SO WE CANNOT -C COMPRESS ALL OF THESE SUBSETS INTO THE SAME MESSAGE. -C ASSUMING THAT NONE OF THE VALUES ARE "MISSING", -C EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN -C OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN. - - IF(KMISS) GOTO 903 - WRIT1 = .TRUE. - NCOL = NCOL-1 - ICOL = 1 - GOTO 20 - ELSEIF(ITYP(I).EQ.2.AND.(RANGE.GT.1..OR.KMISS)) THEN - -C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX -C ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL. -C COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE -C LARGEST OF THE INCREMENTS. - - KBIT(I) = NINT(LOG(RANGE)*RLN2) - IF(2**KBIT(I)-1.LE.RANGE) KBIT(I) = KBIT(I)+1 - -C HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER -C EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING -C DESCRIPTOR! - - IF(KBIT(I).GT.IWID(I)) KBIT(I) = IWID(I) - ELSE - -C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX -C ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE -C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. - - KBIT(I) = 0 - ENDIF - LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) - ELSEIF(ITYP(I).EQ.3) THEN - -C ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES, -C SO KMIS(I) WILL STORE: -C .FALSE. IF ALL SUCH VALUES ARE IDENTICAL -C .TRUE. OTHERWISE - - IF(ICOL.EQ.1) THEN - CSTR(I) = CATX(I,1) - KMIS(I) = .FALSE. - ENDIF - DO J=ICOL,NCOL - IF ( (.NOT.KMIS(I)) .AND. (CSTR(I).NE.CATX(I,J)) ) THEN - KMIS(I) = .TRUE. - ENDIF - ENDDO - IF (KMIS(I)) THEN - -C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX -C ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL. - - KBIT(I) = IWID(I) - ELSE - -C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX -C ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE -C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. - - KBIT(I) = 0 - ENDIF - LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) - ENDIF - ENDDO - -C ROUND DATA LENGTH UP TO A WHOLE BYTE COUNT -C ------------------------------------------ - - IBYT = (LDATA+8-MOD(LDATA,8))/8 - -C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE -C THAT WE ROUND TO AN EVEN BYTE COUNT - - IF( (.NOT.EDGE4) .AND. (MOD(IBYT,2).NE.0) ) IBYT = IBYT+1 - - JBIT = IBYT*8-LDATA - -C CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN -C ------------------------------------------------------------------ - - IF(MSGFULL(IBYT,KBYT,MAXCMB)) THEN - -C THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE. -C SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED, -C THEN GO BACK AND RE-COMPRESS THE SECTION 4 DATA FOR THIS -C MESSAGE WHILE *EXCLUDING* THE DATA FOR THE CURRENT SUBSET -C (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A -C NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!). - - WRIT1 = .TRUE. - NCOL = NCOL-1 - ICOL = 1 - GOTO 20 - ELSEIF(.NOT.WRIT1) THEN - -C ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN. - - CALL USRTPL(LUN,1,1) - NSUB(LUN) = -NCOL - GOTO 100 - ENDIF - -C WRITE THE COMPLETE COMPRESSED MESSAGE -C ------------------------------------- - -C NOW IT IS TIME TO DO THE "REAL" CALL TO CMSGINI TO ACTUALLY -C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED -C BUFR MESSAGE THAT WILL BE WRITTEN OUT. - - 50 CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL,IBYT) - -C NOW ADD THE SECTION 4 DATA. - - IBIT = IBYT*8 - DO I=1,NROW - IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN - CALL PKB(KMIN(I),IWID(I),MESG,IBIT) - CALL PKB(KBIT(I), 6,MESG,IBIT) - IF(KBIT(I).GT.0) THEN - DO J=1,NCOL - IF(MATX(I,J).LT.2**IWID(I)-1) THEN - INCR = MATX(I,J)-KMIN(I) - ELSE - INCR = 2**KBIT(I)-1 - ENDIF - CALL PKB(INCR,KBIT(I),MESG,IBIT) - ENDDO - ENDIF - ELSEIF(ITYP(I).EQ.3) THEN - NCHR = IWID(I)/8 - IF(KBIT(I).GT.0) THEN - CALL PKB( 0,IWID(I),MESG,IBIT) - CALL PKB(NCHR, 6,MESG,IBIT) - DO J=1,NCOL - CALL PKC(CATX(I,J),NCHR,MESG,IBIT) - ENDDO - ELSE - CALL PKC(CSTR(I),NCHR,MESG,IBIT) - CALL PKB( 0, 6,MESG,IBIT) - ENDIF - ENDIF - ENDDO - -C FILL IN THE END OF THE MESSAGE -C ------------------------------ - -C PAD THE END OF SECTION 4 WITH ZEROES UP TO THE NECESSARY -C BYTE COUNT. - - CALL PKB( 0,JBIT,MESG,IBIT) - -C ADD SECTION 5. - - CALL PKC('7777', 4,MESG,IBIT) - -C SEE THAT THE MESSAGE BYTE COUNTERS AGREE THEN WRITE A MESSAGE -C ------------------------------------------------------------- - - IF(MOD(IBIT,8).NE.0) GOTO 904 - LBYT = IUPBS01(MESG,'LENM') - NBYT = IBIT/8 - IF(NBYT.NE.LBYT) GOTO 905 - - CALL MSGWRT(LUNIT,MESG,NBYT) - - MAXROW = MAX(MAXROW,NROW) - MAXCOL = MAX(MAXCOL,NCOL) - NCMSGS = NCMSGS+1 - NCSUBS = NCSUBS+NCOL - NCBYTS = NCBYTS+NBYT - -C RESET -C ----- - -C NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK -C AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE -C WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT. - - FIRST = .TRUE. - IF(.NOT.FLUSH) GOTO 1 - -C EXITS -C ----- - -100 RETURN -900 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '// - . 'CALL (",I3,") .NE. I/O STREAM INDEX FOR INITIAL CALL (",I3,")'// - . ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC,LUNIX - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// - . 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE '// - . 'COMPRESSION MATRIX (",I6,")")') NVAL(LUN),MXCDV - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// - . 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL - CALL BORT(BORT_STR) -903 CALL BORT('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR') -904 CALL BORT('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// - . 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '// - . ' A BYTE BOUNDARY') -905 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// - . 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'// - .',I6,")")') LBYT,NBYT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/wrdesc.c b/src/bufr/wrdesc.c deleted file mode 100644 index d6df3fc957..0000000000 --- a/src/bufr/wrdesc.c +++ /dev/null @@ -1,59 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRDESC -C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 -C -C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF A DESCRIPTOR, -C THIS ROUTINE ADDS IT TO AN ONGOING ARRAY OF DESCRIPTORS, AFTER -C FIRST MAKING SURE THAT THERE IS ENOUGH ROOM IN THE ARRAY. -C IF AN ARRAY OVERFLOW OCCURS, THEN AN APPROPRIATE ERROR MESSAGE -C WILL BE WRITTEN VIA BORT. -C -C PROGRAM HISTORY LOG: -C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR -C -C USAGE: CALL WRDESC( DESC, DESCARY, NDESCARY ) -C INPUT ARGUMENT LIST: -C DESC - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR -C TO BE WRITTEN INTO DESCARY -C DESCARY - INTEGER: ARRAY OF DESCRIPTORS -C NDESCARY - INTEGER: NUMBER OF DESCRIPTORS WRITTEN SO FAR -C INTO DESCARY -C -C OUTPUT ARGUMENT LIST: -C DESCARY - INTEGER: ARRAY OF DESCRIPTORS -C NDESCARY - INTEGER: NUMBER OF DESCRIPTORS WRITTEN SO FAR -C INTO DESCARY -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: RESTD -C Normally not called by application -C programs but it could be. -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$*/ - -#include "bufrlib.h" - -void wrdesc( f77int desc, f77int descary[], f77int *ndescary ) -{ - char errstr[129]; - -/* -** Is there room in descary for desc ? -*/ - if ( ( *ndescary + 1 ) < MAXNC ) { - descary[(*ndescary)++] = desc; - } - else { - sprintf( errstr, "BUFRLIB: WRDESC - EXPANDED SECTION 3 CONTAINS" - " MORE THAN %d DESCRIPTORS", MAXNC ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - - return; -} diff --git a/src/bufr/wrdlen.F b/src/bufr/wrdlen.F deleted file mode 100755 index 75591d31e4..0000000000 --- a/src/bufr/wrdlen.F +++ /dev/null @@ -1,482 +0,0 @@ - SUBROUTINE WRDLEN - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRDLEN -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE FIGURES OUT SOME IMPORTANT INFORMATION -C ABOUT THE LOCAL MACHINE ON WHICH THE BUFR ARCHIVE LIBRARY SOFTWARE -C IS BEING RUN AND STORES THIS INTO COMMON BLOCK /HRDWRD/. SUCH -C INFORMATION INCLUDES DETERMINING THE NUMBER OF BITS AND THE NUMBER -C OF BYTES IN A MACHINE WORD AS WELL AS DETERMINING WHETHER THE -C MACHINE USES THE ASCII OR EBCDIC CHARACTER SET. -C -C NOTE: IT IS ONLY NECESSARY FOR THIS SUBROUTINE TO BE CALLED ONCE, -C AND THIS IS NORMALLY DONE DURING THE FIRST CALL TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF. HOWEVER, THE SUBROUTINE DOES KEEP TRACK -C OF WHETHER IT HAS ALREADY BEEN CALLED; THUS, IF IT IS CALLED AGAIN -C LATER BY A DIFFERENT BUFR ARCHIVE LIBRARY SUBROUTINE, IT WILL JUST -C QUIETLY RETURN WITHOUT (RE)COMPUTING ALL OF THE INFORMATION WITHIN -C COMMON BLOCK /HRDWRD/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY OR FOR INFORMATIONAL PURPOSES; -C NBYTW INITIALIZED AS ZERO THE FIRST TIME -C THIS ROUTINE IS CALLED (BEFORE WAS -C UNDEFINED WHEN FIRST REFERENCED) -C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST FLAG AND IMMEDIATE -C RETURN IF IFIRST=1 -C 2007-01-19 J. ATOR -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW -C DETERMINED AT COMPILE TIME AND CONFIGURED -C WITHIN BUFRLIB VIA CONDITIONAL COMPILATION -C DIRECTIVES -C 2009-03-23 J. ATOR -- CALL BVERS TO GET VERSION NUMBER -C -C USAGE: CALL WRDLEN -C -C REMARKS: -C THIS ROUTINE CALLS: BORT BVERS ERRWRT IUPM -C THIS ROUTINE IS CALLED BY: COBFL COPYBF DATEBF DATELEN -C DUMPBF IUPBS01 MESGBC MESGBF -C OPENBF RDMTBB UPDS3 -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) - COMMON /QUIET / IPRT - - CHARACTER*128 BORT_STR,ERRSTR - CHARACTER*8 CINT,DINT,CVSTR - CHARACTER*6 CNDIAN,CLANG - EQUIVALENCE (CINT,INT) - EQUIVALENCE (DINT,JNT) - LOGICAL PRINT - - DATA IFIRST/0/ - - SAVE IFIRST - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C HAS THIS SUBROUTINE ALREADY BEEN CALLED? - - IF(IFIRST.EQ.0) THEN - -C NO, SO CHECK WHETHER DIAGNOSTIC INFORMATION SHOULD BE PRINTED -C AND THEN PROCEED THROUGH THE REST OF THE SUBROUTINE. - - PRINT = IPRT.GE.1 - IFIRST = 1 - ELSE - -C YES, SO THERE IS NO NEED TO PROCEED ANY FURTHER. - - RETURN - ENDIF - -C COUNT THE BITS IN A WORD - MAX 64 ALLOWED -C ----------------------------------------- - - INT = 1 - DO I=1,65 - INT = ISHFT(INT,1) - IF(INT.EQ.0) GOTO 10 - ENDDO -c .... DK: Can the below ever happen since upper loop bounds is 65? - 10 IF(I.GE.65) GOTO 900 - IF(MOD(I,8).NE.0) GOTO 901 - -C NBITW is no. of bits in a word, NBYTW is no. of bytes in a word -C --------------------------------------------------------------- - - NBITW = I - NBYTW = I/8 - -C INDEX THE BYTE STORAGE ORDER - HIGH BYTE TO LOW BYTE -C ----------------------------------------------------- - - JNT = 0 - - DO I = 1,8 - IORD(I) = 9999 - ENDDO - - DO I=1,NBYTW - INT = ISHFT(1,(NBYTW-I)*8) - DO J=1,NBYTW - IF(CINT(J:J).NE.DINT(J:J)) GOTO 20 - ENDDO -c .... DK: Can the below ever happen since upper loop bounds is NBYTW? - 20 IF(J.GT.NBYTW) GOTO 902 - IORD(I) = J - ENDDO - -C SETUP AN ASCII/EBCDIC TRANSLATOR AND DETERMINE WHICH IS NATIVE -C -------------------------------------------------------------- - - IA = IUPM('A',8) - IF(IA.EQ. 65) THEN - IASCII = 1 - CLANG = 'ASCII ' - ELSEIF(IA.EQ.193) THEN - IASCII = 0 - CLANG = 'EBCDIC' - ELSE - GOTO 903 - ENDIF - - DO I=0,255 - IETOA(I) = 0 - IATOE(I) = 0 - ENDDO - - IETOA( 1) = 1 - IATOE( 1) = 1 - IETOA( 2) = 2 - IATOE( 2) = 2 - IETOA( 3) = 3 - IATOE( 3) = 3 - IETOA( 5) = 9 - IATOE( 9) = 5 - IETOA( 7) = 127 - IATOE(127) = 7 - IETOA( 11) = 11 - IATOE( 11) = 11 - IETOA( 12) = 12 - IATOE( 12) = 12 - IETOA( 13) = 13 - IATOE( 13) = 13 - IETOA( 14) = 14 - IATOE( 14) = 14 - IETOA( 15) = 15 - IATOE( 15) = 15 - IETOA( 16) = 16 - IATOE( 16) = 16 - IETOA( 17) = 17 - IATOE( 17) = 17 - IETOA( 18) = 18 - IATOE( 18) = 18 - IETOA( 19) = 19 - IATOE( 19) = 19 - IETOA( 22) = 8 - IATOE( 8) = 22 - IETOA( 24) = 24 - IATOE( 24) = 24 - IETOA( 25) = 25 - IATOE( 25) = 25 - IETOA( 29) = 29 - IATOE( 29) = 29 - IETOA( 31) = 31 - IATOE( 31) = 31 - IETOA( 34) = 28 - IATOE( 28) = 34 - IETOA( 37) = 10 - IATOE( 10) = 37 - IETOA( 38) = 23 - IATOE( 23) = 38 - IETOA( 39) = 27 - IATOE( 27) = 39 - IETOA( 45) = 5 - IATOE( 5) = 45 - IETOA( 46) = 6 - IATOE( 6) = 46 - IETOA( 47) = 7 - IATOE( 7) = 47 - IETOA( 50) = 22 - IATOE( 22) = 50 - IETOA( 53) = 30 - IATOE( 30) = 53 - IETOA( 55) = 4 - IATOE( 4) = 55 - IETOA( 60) = 20 - IATOE( 20) = 60 - IETOA( 61) = 21 - IATOE( 21) = 61 - IETOA( 63) = 26 - IATOE( 26) = 63 - IETOA( 64) = 32 - IATOE( 32) = 64 - IETOA( 74) = 91 - IATOE( 91) = 74 - IETOA( 75) = 46 - IATOE( 46) = 75 - IETOA( 76) = 60 - IATOE( 60) = 76 - IETOA( 77) = 40 - IATOE( 40) = 77 - IETOA( 78) = 43 - IATOE( 43) = 78 - IETOA( 79) = 33 - IATOE( 33) = 79 - IETOA( 80) = 38 - IATOE( 38) = 80 - IETOA( 90) = 93 - IATOE( 93) = 90 - IETOA( 91) = 36 - IATOE( 36) = 91 - IETOA( 92) = 42 - IATOE( 42) = 92 - IETOA( 93) = 41 - IATOE( 41) = 93 - IETOA( 94) = 59 - IATOE( 59) = 94 - IETOA( 95) = 94 - IATOE( 94) = 95 - IETOA( 96) = 45 - IATOE( 45) = 96 - IETOA( 97) = 47 - IATOE( 47) = 97 - IETOA(106) = 124 - IATOE(124) = 106 - IETOA(107) = 44 - IATOE( 44) = 107 - IETOA(108) = 37 - IATOE( 37) = 108 - IETOA(109) = 95 - IATOE( 95) = 109 - IETOA(110) = 62 - IATOE( 62) = 110 - IETOA(111) = 63 - IATOE( 63) = 111 - IETOA(121) = 96 - IATOE( 96) = 121 - IETOA(122) = 58 - IATOE( 58) = 122 - IETOA(123) = 35 - IATOE( 35) = 123 - IETOA(124) = 64 - IATOE( 64) = 124 - IETOA(125) = 39 - IATOE( 39) = 125 - IETOA(126) = 61 - IATOE( 61) = 126 - IETOA(127) = 34 - IATOE( 34) = 127 - IETOA(129) = 97 - IATOE( 97) = 129 - IETOA(130) = 98 - IATOE( 98) = 130 - IETOA(131) = 99 - IATOE( 99) = 131 - IETOA(132) = 100 - IATOE(100) = 132 - IETOA(133) = 101 - IATOE(101) = 133 - IETOA(134) = 102 - IATOE(102) = 134 - IETOA(135) = 103 - IATOE(103) = 135 - IETOA(136) = 104 - IATOE(104) = 136 - IETOA(137) = 105 - IATOE(105) = 137 - IETOA(145) = 106 - IATOE(106) = 145 - IETOA(146) = 107 - IATOE(107) = 146 - IETOA(147) = 108 - IATOE(108) = 147 - IETOA(148) = 109 - IATOE(109) = 148 - IETOA(149) = 110 - IATOE(110) = 149 - IETOA(150) = 111 - IATOE(111) = 150 - IETOA(151) = 112 - IATOE(112) = 151 - IETOA(152) = 113 - IATOE(113) = 152 - IETOA(153) = 114 - IATOE(114) = 153 - IETOA(161) = 126 - IATOE(126) = 161 - IETOA(162) = 115 - IATOE(115) = 162 - IETOA(163) = 116 - IATOE(116) = 163 - IETOA(164) = 117 - IATOE(117) = 164 - IETOA(165) = 118 - IATOE(118) = 165 - IETOA(166) = 119 - IATOE(119) = 166 - IETOA(167) = 120 - IATOE(120) = 167 - IETOA(168) = 121 - IATOE(121) = 168 - IETOA(169) = 122 - IATOE(122) = 169 - IETOA(173) = 91 - IATOE( 91) = 173 - IETOA(176) = 48 - IATOE( 48) = 176 - IETOA(177) = 49 - IATOE( 49) = 177 - IETOA(178) = 50 - IATOE( 50) = 178 - IETOA(179) = 51 - IATOE( 51) = 179 - IETOA(180) = 52 - IATOE( 52) = 180 - IETOA(181) = 53 - IATOE( 53) = 181 - IETOA(182) = 54 - IATOE( 54) = 182 - IETOA(183) = 55 - IATOE( 55) = 183 - IETOA(184) = 56 - IATOE( 56) = 184 - IETOA(185) = 57 - IATOE( 57) = 185 - IETOA(189) = 93 - IATOE( 93) = 189 - IETOA(192) = 123 - IATOE(123) = 192 - IETOA(193) = 65 - IATOE( 65) = 193 - IETOA(194) = 66 - IATOE( 66) = 194 - IETOA(195) = 67 - IATOE( 67) = 195 - IETOA(196) = 68 - IATOE( 68) = 196 - IETOA(197) = 69 - IATOE( 69) = 197 - IETOA(198) = 70 - IATOE( 70) = 198 - IETOA(199) = 71 - IATOE( 71) = 199 - IETOA(200) = 72 - IATOE( 72) = 200 - IETOA(201) = 73 - IATOE( 73) = 201 - IETOA(208) = 125 - IATOE(125) = 208 - IETOA(209) = 74 - IATOE( 74) = 209 - IETOA(210) = 75 - IATOE( 75) = 210 - IETOA(211) = 76 - IATOE( 76) = 211 - IETOA(212) = 77 - IATOE( 77) = 212 - IETOA(213) = 78 - IATOE( 78) = 213 - IETOA(214) = 79 - IATOE( 79) = 214 - IETOA(215) = 80 - IATOE( 80) = 215 - IETOA(216) = 81 - IATOE( 81) = 216 - IETOA(217) = 82 - IATOE( 82) = 217 - IETOA(224) = 92 - IATOE( 92) = 224 - IETOA(226) = 83 - IATOE( 83) = 226 - IETOA(227) = 84 - IATOE( 84) = 227 - IETOA(228) = 85 - IATOE( 85) = 228 - IETOA(229) = 86 - IATOE( 86) = 229 - IETOA(230) = 87 - IATOE( 87) = 230 - IETOA(231) = 88 - IATOE( 88) = 231 - IETOA(232) = 89 - IATOE( 89) = 232 - IETOA(233) = 90 - IATOE( 90) = 233 - IETOA(240) = 48 - IATOE( 48) = 240 - IETOA(241) = 49 - IATOE( 49) = 241 - IETOA(242) = 50 - IATOE( 50) = 242 - IETOA(243) = 51 - IATOE( 51) = 243 - IETOA(244) = 52 - IATOE( 52) = 244 - IETOA(245) = 53 - IATOE( 53) = 245 - IETOA(246) = 54 - IATOE( 54) = 246 - IETOA(247) = 55 - IATOE( 55) = 247 - IETOA(248) = 56 - IATOE( 56) = 248 - IETOA(249) = 57 - IATOE( 57) = 249 - -C SHOW SOME RESULTS -C ----------------- - - IF(PRINT) THEN - CALL BVERS(CVSTR) -#ifdef BIG_ENDIAN - CNDIAN = ' BIG ' -#else - CNDIAN = 'LITTLE' -#endif - ERRSTR = '=============== ' // - . 'WELCOME TO THE BUFR ARCHIVE LIBRARY' // ' ==============' - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I2)' ) - . ' MACHINE CHARACTERISTICS: NUMBER OF BYTES PER WORD =', NBYTW - CALL ERRWRT(ERRSTR) - WRITE ( UNIT=ERRSTR, FMT='(A,I3)' ) - . ' NUMBER OF BITS PER WORD =', NBITW - CALL ERRWRT(ERRSTR) - ERRSTR = ' BYTE ORDER IS ' // CNDIAN // - . ' ENDIAN' - CALL ERRWRT(ERRSTR) - ERRSTR = ' ' // CLANG // - . ' IS THE NATIVE LANGUAGE' - CALL ERRWRT(ERRSTR) - ERRSTR = '====================== VERSION: ' // CVSTR // - . '==========================' - CALL ERRWRT(ERRSTR) - CALL ERRWRT(' ') - ENDIF - -C EXITS -C ----- - - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH IS '// - . 'LIMITED TO 64 BITS (THIS MACHINE APPARENTLY HAS",I4," BIT '// - . 'WORDS!)")') I - CALL BORT(BORT_STR) - 901 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH (",I4,"'// - . ') IS NOT A MULTIPLE OF 8 (THIS MACHINE HAS WORDS NOT ON WHOLE'// - . ' BYTE BOUNDARIES!)")') I - CALL BORT(BORT_STR) - 902 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - BYTE ORDER CHECKING MISTAKE'// - . ', LOOP INDEX J (HERE =",I3,") IS .GT. NO. OF BYTES PER WORD '// - . 'ON THIS MACHINE (",I3,")")') J,NBYTW - CALL BORT(BORT_STR) - 903 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - CAN''T DETERMINE MACHINE '// - . 'NATIVE LANGUAGE (CHAR. A UNPACKS TO INT.",I4," NEITHER ASCII '// - . ' (65) NOR EBCDIC (193)")') IA - CALL BORT(BORT_STR) - END diff --git a/src/bufr/wrdxtb.f b/src/bufr/wrdxtb.f deleted file mode 100644 index 5d010cb037..0000000000 --- a/src/bufr/wrdxtb.f +++ /dev/null @@ -1,182 +0,0 @@ - SUBROUTINE WRDXTB(LUNDX,LUNOT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRDXTB -C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 -C -C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES -C ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE BUFR FILE IN LUNOT. -C BOTH UNITS MUST BE OPENED VIA PREVIOUS CALLS TO BUFR ARCHIVE -C LIBRARY SUBROUTINE OPENBF, AND IN PARTICULAR LUNOT MUST HAVE -C BEEN OPENED FOR OUTPUT. THE TABLE MESSAGES ARE GENERATED FROM -C ARRAYS IN INTERNAL MEMORY (COMMON BLOCK /TABABD/). LUNDX CAN BE -C THE SAME AS LUNOT IF IT IS DESIRED TO APPEND TO LUNOT WITH BUFR -C MESSAGES GENERATED FROM ITS OWN INTERNAL TABLES. -C -C PROGRAM HISTORY LOG: -C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC FROM WRITDX -C 2012-04-06 J. ATOR -- PREVENT STORING OF MORE THAN 255 TABLE A, -C TABLE B OR TABLE D DESCRIPTORS IN ANY -C SINGLE DX MESSAGE -C -C USAGE: CALL WRDXTB (LUNDX,LUNOT) -C INPUT ARGUMENT LIST: -C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED -C WITH DX (DICTIONARY) TABLES TO BE WRITTEN OUT; -C CAN BE SAME AS LUNOT -C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C TO BE APPENDED WITH TABLES ASSOCIATED WITH LUNDX -C -C REMARKS: -C THIS ROUTINE CALLS: ADN30 BORT CPBFDX DXMINI -C GETLENS IPKM IUPM MSGFULL -C MSGWRT PKB PKC STATUS -C THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), - . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), - . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), - . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), - . TABD(MAXTBD,NFILES) - COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), - . LD30(10),DXSTR(10) - - CHARACTER*600 TABD - CHARACTER*128 BORT_STR - CHARACTER*128 TABB - CHARACTER*128 TABA - CHARACTER*56 DXSTR - CHARACTER*6 ADN30 - CHARACTER*1 MOCT(MXMSGL) - - LOGICAL MSGFULL - - DIMENSION MBAY(MXMSGLD4) - - EQUIVALENCE (MOCT(1),MBAY(1)) - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK FILE STATUSES -C ------------------- - - CALL STATUS(LUNOT,LOT,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - - CALL STATUS(LUNDX,LDX,IL,IM) - IF(IL.EQ.0) GOTO 902 - -C IF FILES ARE DIFFERENT, COPY INTERNAL TABLE -C INFORMATION FROM LUNDX TO LUNOT -C ------------------------------------------- - - IF(LUNDX.NE.LUNOT) CALL CPBFDX(LDX,LOT) - -C GENERATE AND WRITE OUT BUFR DICTIONARY MESSAGES TO LUNOT -C -------------------------------------------------------- - - CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) - - LDA = LDXA(IDXV+1) - LDB = LDXB(IDXV+1) - LDD = LDXD(IDXV+1) - L30 = LD30(IDXV+1) - -C Table A information - - DO I=1,NTBA(LOT) - IF(MSGFULL(MBYT,LDA,MAXDX).OR. - + (IUPM(MOCT(MBYA),8).EQ.255)) THEN - CALL MSGWRT(LUNOT,MBAY,MBYT) - CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) - ENDIF - CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDA) - CALL IPKM(MOCT(MBYA),1,IUPM(MOCT(MBYA), 8)+ 1) - MBIT = 8*(MBYB-1) - CALL PKC(TABA(I,LOT),LDA,MBAY,MBIT) - CALL PKB( 0, 8,MBAY,MBIT) - CALL PKB( 0, 8,MBAY,MBIT) - MBYT = MBYT+LDA - MBYB = MBYB+LDA - MBYD = MBYD+LDA - ENDDO - -C Table B information - - DO I=1,NTBB(LOT) - IF(MSGFULL(MBYT,LDB,MAXDX).OR. - + (IUPM(MOCT(MBYB),8).EQ.255)) THEN - CALL MSGWRT(LUNOT,MBAY,MBYT) - CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) - ENDIF - CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDB) - CALL IPKM(MOCT(MBYB),1,IUPM(MOCT(MBYB), 8)+ 1) - MBIT = 8*(MBYD-1) - CALL PKC(TABB(I,LOT),LDB,MBAY,MBIT) - CALL PKB( 0, 8,MBAY,MBIT) - MBYT = MBYT+LDB - MBYD = MBYD+LDB - ENDDO - -C Table D information - - DO I=1,NTBD(LOT) - NSEQ = IUPM(TABD(I,LOT)(LDD+1:LDD+1),8) - LEND = LDD+1 + L30*NSEQ - IF(MSGFULL(MBYT,LEND,MAXDX).OR. - + (IUPM(MOCT(MBYD),8).EQ.255)) THEN - CALL MSGWRT(LUNOT,MBAY,MBYT) - CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) - ENDIF - CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LEND) - CALL IPKM(MOCT(MBYD),1,IUPM(MOCT(MBYD), 8)+ 1) - MBIT = 8*(MBYT-4) - CALL PKC(TABD(I,LOT),LDD,MBAY,MBIT) - CALL PKB( NSEQ, 8,MBAY,MBIT) - DO J=1,NSEQ - JJ = LDD+2 + (J-1)*2 - IDN = IUPM(TABD(I,LOT)(JJ:JJ),16) - CALL PKC(ADN30(IDN,L30),L30,MBAY,MBIT) - ENDDO - MBYT = MBYT+LEND - ENDDO - -C Write the unwritten (leftover) message. - - CALL MSGWRT(LUNOT,MBAY,MBYT) - -C Write out one additional (dummy) DX message containing zero -C subsets. This will serve as a delimiter for this set of -C table messages within output unit LUNOT, just in case the -C next thing written to LUNOT ends up being another set of -C table messages. - - CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) - CALL GETLENS(MBAY,2,LEN0,LEN1,LEN2,L3,L4,L5) - MBIT = (LEN0+LEN1+LEN2+4)*8 - CALL PKB(0,16,MBAY,MBIT) - CALL MSGWRT(LUNOT,MBAY,MBYT) - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT '// - . 'MUST BE OPEN') - END diff --git a/src/bufr/writcp.f b/src/bufr/writcp.f deleted file mode 100644 index 0dd3cad62f..0000000000 --- a/src/bufr/writcp.f +++ /dev/null @@ -1,51 +0,0 @@ - SUBROUTINE WRITCP(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRITCP -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C LUNIT HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT NOW SIMPLY CALLS -C BUFR ARCHIVE LIBRARY SUBROUTINE CMPMSG TO TOGGLE ON MESSAGE -C COMPRESSION, FOLLOWED BY A CALL TO WRITSB TO PACK UP THE CURRENT -C SUBSET WITHIN MEMORY AND TRY TO ADD IT TO THE COMPRESSED BUFR -C MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT, -C FOLLOWED BY ANOTHER CALL TO CMPMSG TO TOGGLE OFF MESSAGE -C COMPRESSION. THIS SUBROUTINE USES THE SAME INPUT AND OUTPUT -C PARAMETERS AS WRITSB. -C -C PROGRAM HISTORY LOG: -C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2005-03-09 J. ATOR -- MODIFIED TO USE CMPMSG AND WRITSB -C -C USAGE: CALL WRITCP (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: CMPMSG WRITSB -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CALL CMPMSG('Y') - - CALL WRITSB(LUNIT) - - CALL CMPMSG('N') - - RETURN - END diff --git a/src/bufr/writdx.f b/src/bufr/writdx.f deleted file mode 100644 index 47c9cc1682..0000000000 --- a/src/bufr/writdx.f +++ /dev/null @@ -1,88 +0,0 @@ - SUBROUTINE WRITDX(LUNIT,LUN,LUNDX) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRITDX -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES TO -C THE BEGINNING OF AN OUTPUT BUFR FILE IN LUNIT. THE TABLE MESSAGES -C ARE READ FROM ARRAYS IN INTERNAL MEMORY (COMMON BLOCK /TABABD/). -C AN INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READDX GENERATES -C THESE INTERNAL ARRAYS. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE -C ARRAYS IN ORDER TO HANDLE BIGGER FILES -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2009-03-23 J. ATOR -- USE WRDXTB -C -C USAGE: CALL WRITDX (LUNIT, LUN, LUNDX) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C BEING WRITTEN -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) -C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING -C DICTIONARY TABLE INFORMATION TO BE USED (BY READDX) TO -C CREATE INTERNAL TABLES WRITTEN TO LUNIT (SEE READDX); -C IF SET EQUAL TO LUNIT, THIS SUBROUTINE CALLS BORT -C -C REMARKS: -C THIS ROUTINE CALLS: BORT READDX WRDXTB -C THIS ROUTINE IS CALLED BY: OPENBF -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK UNITS, TABLE MUST BE COMING FROM AN INPUT FILE -C ---------------------------------------------------- - - IF(LUNIT.EQ.LUNDX) GOTO 900 - -C MUST FIRST CALL READDX TO GENERATE INTERNAL DICTIONARY TABLE ARRAYS -C ------------------------------------------------------------------- - - CALL READDX(LUNIT,LUN,LUNDX) - -C NOW CALL WRDXTB TO WRITE OUT DICTIONARY MESSAGES FROM THESE ARRAYS -C ------------------------------------------------------------------ - - CALL WRDXTB(LUNIT,LUNIT) - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: WRITDX - FILES CONTAINING BUFR DATA '// - . 'AND DICTIONARY TABLE CANNOT BE THE SAME (HERE BOTH SHARE '// - . 'FORTRAN UNIT NUMBER ",I3,")")') LUNIT - CALL BORT(BORT_STR) - END diff --git a/src/bufr/writlc.f b/src/bufr/writlc.f deleted file mode 100644 index b4de2442a3..0000000000 --- a/src/bufr/writlc.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE WRITLC(LUNIT,CHR,STR) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRITLC -C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 -C -C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER DATA ELEMENT ASSOCIATED -C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER -C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS DESIGNED TO BE USED -C TO STORE CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT -C BYTES. NOTE THAT SUBROUTINE WRITSB OR WRITSA MUST HAVE ALREADY -C BEEN CALLED TO STORE ALL OTHER ELEMENTS OF THE SUBSET BEFORE THIS -C SUBROUTINE CAN BE CALLED TO FILL IN ANY LONG CHARACTER STRINGS. -C -C PROGRAM HISTORY LOG: -C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-11-29 J. ATOR -- USE GETLENS -C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR -C 2009-03-23 J. ATOR -- ADDED '#' OPTION FOR MORE THAN ONE -C OCCURRENCE OF STR -c 2009-08-11 J. WOOLLEN -- ADDED COMMON COMPRS ALONG WITH LOGIC TO -c WRITE LONG STRINGS INTO COMPRESSED SUBSETS -C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS -C WHEN USED WITH '#' OCCURRENCE CODE -C -C USAGE: CALL WRITLC (LUNIT, CHR, STR) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., -C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) -C STR - CHARACTER*(*): MNEMONIC ASSOCIATED WITH STRING IN CHR -C -C REMARKS: -C THIS ROUTINE CALLS: BORT GETLENS IUPBS3 PARSTR -C PARUTG PKC STATUS UPB -C UPBB USRTPL -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), - . INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB) - - CHARACTER*(*) CHR,STR - CHARACTER*128 BORT_STR - CHARACTER*(MXLCC) CATX - CHARACTER*10 TAG,CTAG - CHARACTER*14 TGS(10) - CHARACTER*3 TYP - REAL*8 VAL - - DATA MAXTG /10/ - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE) -C ------------------------------------------------------------------ - - CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) - IF(NTG.GT.1) GOTO 903 - -C Check if a specific occurrence of the input string was requested; -C if not, then the default is to write the first occurrence. - - CALL PARUTG(LUN,1,TGS(1),NNOD,KON,ROID) - IF(KON.EQ.6) THEN - IOID=NINT(ROID) - IF(IOID.LE.0) IOID = 1 - CTAG = ' ' - II = 1 - DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#')) - CTAG(II:II)=TGS(1)(II:II) - II = II + 1 - ENDDO - ELSE - IOID = 1 - CTAG = TGS(1)(1:10) - ENDIF - -C USE THIS LEG FOR STRINGING COMPRESSED DATA (UP TO MXLCC CHARACTERS) -C ---------------------------------------------------------------- - - IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN - N = 1 - ITAGCT = 0 - CALL USRTPL(LUN,N,N) - DO WHILE (N+1.LE.NVAL(LUN)) - N = N+1 - NODE = INV(N,LUN) - IF(ITP(NODE).EQ.1) THEN - CALL USRTPL(LUN,N,MATX(N,NCOL)) - ELSEIF(CTAG.EQ.TAG(NODE)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IOID) THEN - IF(ITP(NODE).NE.3) GOTO 904 - CATX(N,NCOL)=' ' -C -------------------------------------------------- -C Note: the following stmt enforces a limit of MXLCC -C characters per long character string when writing -C compressed messages. This limit keeps the static -C array CATX to a reasonable dimensioned size. -C -------------------------------------------------- - NCHR=MIN(MXLCC,IBT(NODE)/8) - CATX(N,NCOL)=CHR(1:NCHR) - CALL USRTPL(LUN,1,1) - GOTO 100 - ENDIF - ENDIF - ENDDO - GOTO 906 - ENDIF - -C OTHERWISE LOCATE THE BEGINNING OF THE DATA (SECTION 4) IN THE MESSAGE -C --------------------------------------------------------------------- - - CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5) - MBYTE = LEN0 + LEN1 + LEN2 + LEN3 + 4 - NSUBS = 1 - -C FIND THE MOST RECENTLY WRITTEN SUBSET IN THE MESSAGE -C ---------------------------------------------------- - - DO WHILE(NSUBS.LT.NSUB(LUN)) - IBIT = MBYTE*8 - CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) - MBYTE = MBYTE + NBYT - NSUBS = NSUBS + 1 - ENDDO - - IF(NSUBS.NE.NSUB(LUN)) GOTO 905 - -C LOCATE AND WRITE THE LONG CHARACTER STRING WITHIN THIS SUBSET -C ------------------------------------------------------------- - - ITAGCT = 0 - MBIT = MBYTE*8 + 16 - NBIT = 0 - N = 1 - CALL USRTPL(LUN,N,N) - DO WHILE (N+1.LE.NVAL(LUN)) - N = N+1 - NODE = INV(N,LUN) - MBIT = MBIT+NBIT - NBIT = IBT(NODE) - IF(ITP(NODE).EQ.1) THEN - CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) - CALL USRTPL(LUN,N,IVAL) - ELSEIF(CTAG.EQ.TAG(NODE)) THEN - ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IOID) THEN - IF(ITP(NODE).NE.3) GOTO 904 - NCHR = NBIT/8 - IBIT = MBIT - DO J=1,NCHR - CALL PKC(' ',1,MBAY(1,LUN),IBIT) - ENDDO - CALL PKC(CHR,NCHR,MBAY(1,LUN),MBIT) - CALL USRTPL(LUN,1,1) - GOTO 100 - ENDIF - ENDIF - ENDDO - GOTO 906 - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') -903 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// - . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'// - . ',")")') STR,NTG - CALL BORT(BORT_STR) -904 WRITE(BORT_STR,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '// - . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') TGS(1),TYP(NODE) - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '// - . ' SUBSET NO. (",I3,") IN MSG .NE. THE STORED VALUE FOR THE NO.'// - . ' OF SUBSETS (",I3,") IN MSG")') NSUBS,NSUB(LUN) - CALL BORT(BORT_STR) -906 WRITE(BORT_STR,'("BUFRLB: WRITLC - UNABLE TO FIND ",A," IN '// - . 'SUBSET")') TGS(1) - CALL BORT(BORT_STR) - END diff --git a/src/bufr/writsa.f b/src/bufr/writsa.f deleted file mode 100644 index 2f253501e7..0000000000 --- a/src/bufr/writsa.f +++ /dev/null @@ -1,180 +0,0 @@ - SUBROUTINE WRITSA(LUNXX,LMSGT,MSGT,MSGL) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRITSA -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C ABS(LUNXX) HAS BEEN OPENED FOR OUTPUT OPERATIONS. -C -C WHEN LUNXX IS GREATER THAN ZERO, IT PACKS UP THE CURRENT SUBSET -C WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE BUFR MESSAGE THAT IS -C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNXX). THE DETERMINATION AS -C TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO THE MESSAGE IS MADE -C VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE LIBRARY SUBROUTINES -C WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT THE MESSAGE IS -C COMPRESSED. IF IT TURNS OUT THAT THE SUBSET CANNOT BE ADDED TO THE -C CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO ABS(LUNXX) -C AND A NEW ONE IS CREATED IN ORDER TO HOLD THE SUBSET. AS LONG AS -C LUNXX IS GREATER THAN ZERO, WRITSA FUNCTIONS EXACTLY LIKE BUFR -C ARCHIVE LIBRARY SUBROUTINE WRITSB, EXCEPT THAT WRITSA ALSO RETURNS -C A COPY OF EACH COMPLETED BUFR MESSAGE TO THE APPLICATION PROGRAM -C IN THE FIRST MSGL WORDS OF ARRAY MSGT. -C -C ALTERNATIVELY, WHEN LUNXX IS LESS THAN ZERO, THIS IS A SIGNAL TO -C FORCE ANY CURRENT MESSAGE IN MEMORY TO BE FLUSHED TO ABS(LUNXX) AND -C RETURNED IN ARRAY MSGT. IN SUCH CASES, ANY CURRENT SUBSET IN MEMORY -C IS IGNORED. THIS OPTION IS NECESSARY BECAUSE ANY MESSAGE RETURNED -C IN MSGT FROM A CALL TO THIS ROUTINE NEVER CONTAINS THE ACTUAL SUBSET -C THAT WAS PACKED UP AND STORED DURING THE SAME CALL TO THIS ROUTINE. -C THEREFORE, THE ONLY WAY TO ENSURE THAT EVERY LAST BUFR SUBSET IS -C RETURNED WITHIN A BUFR MESSAGE IN MSGT BEFORE, E.G., EXITING THE -C APPLICATION PROGRAM, IS TO DO ONE FINAL CALL TO THIS ROUTINE WITH -C LUNXX LESS THAN ZERO IN ORDER TO FORCIBLY FLUSH OUT AND RETURN ONE -C FINAL BUFR MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED -C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS -C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE -C TERMINATES ABNORMALLY -C 2004-08-18 J. ATOR -- ADD POST-MSGUPD CHECK FOR AND RETURN OF -C MESSAGE WITHIN MSGT IN ORDER TO PREVENT -C LOSS OF MESSAGE IN CERTAIN SITUATIONS; -C MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2005-03-09 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES -C 2009-03-23 J. ATOR -- ADDED LMSGT ARGUMENT AND CHECK -C -C USAGE: CALL WRITSA (LUNXX, LMSGT, MSGT, MSGL) -C INPUT ARGUMENT LIST: -C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER -C FOR BUFR FILE {IF LUNXX IS LESS THAN ZERO, THEN ANY -C CURRENT MESSAGE IN MEMORY WILL BE FORCIBLY FLUSHED TO -C ABS(LUNXX) AND TO ARRAY MSGT} -C LMSGT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGT; -C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT -C OVERFLOW THE MSGT ARRAY -C -C OUTPUT ARGUMENT LIST: -C MSGT - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR -C MESSAGE (FIRST MSGL WORDS FILLED) -C MSGL - INTEGER: NUMBER OF WORDS FILLED IN MSGT -C 0 = no message was returned -C -C REMARKS: -C THIS ROUTINE CALLS: BORT CLOSMG MSGUPD STATUS -C WRCMPS WRTREE -C THIS ROUTINE IS CALLED BY: None -C Normally called only by application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) - COMMON /MSGCMP/ CCMF - - CHARACTER*1 CCMF - - DIMENSION MSGT(*) - -C---------------------------------------------------------------------- -C---------------------------------------------------------------------- - - LUNIT = ABS(LUNXX) - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C IF LUNXX < 0, FORCE MEMORY MSG TO BE WRITTEN (W/O ANY CURRENT SUBSET) -C --------------------------------------------------------------------- - - IF(LUNXX.LT.0) CALL CLOSMG(LUNIT) - -C IS THERE A COMPLETED BUFR MESSAGE TO BE RETURNED? -C ------------------------------------------------- - - IF(MSGLEN.GT.0) THEN - IF(MSGLEN.GT.LMSGT) GOTO 904 - MSGL = MSGLEN - DO N=1,MSGL - MSGT(N) = MSGTXT(N) - ENDDO - MSGLEN = 0 - ELSE - MSGL = 0 - ENDIF - - IF(LUNXX.LT.0) GOTO 100 - -C PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE -C ---------------------------------------------- - - CALL WRTREE(LUN) - IF( CCMF.EQ.'Y' ) THEN - CALL WRCMPS(LUNIT) - ELSE - CALL MSGUPD(LUNIT,LUN) - ENDIF - -C IF THE JUST-COMPLETED CALL TO WRCMPS OR MSGUPD FOR THIS SUBSET CAUSED -C A PREVIOUS MESSAGE TO BE FLUSHED TO ABS(LUNXX), THEN RETRIEVE AND -C RETURN THAT MESSAGE NOW. OTHERWISE, WE RUN THE RISK THAT THE NEXT -C CALL TO OPENMB OR OPENMG MIGHT CAUSE A NEWER MESSAGE (WHICH WOULD -C CONTAIN THE CURRENT SUBSET!) TO BE FLUSHED AND THUS OVERWRITE THE -C PREVIOUS MESSAGE WITHIN ARRAY MSGTXT BEFORE WE HAD THE CHANCE TO -C RETRIEVE IT DURING THE NEXT CALL TO WRITSA! - -C NOTE ALSO THAT, IF THE MOST RECENT CALL TO OPENMB OR OPENMG HAD -C CAUSED A MESSAGE TO BE FLUSHED, IT WOULD HAVE DONE SO IN ORDER TO -C CREATE A NEW MESSAGE TO HOLD THE CURRENT SUBSET. THUS, IN SUCH -C CASES, IT SHOULD NOT BE POSSIBLE THAT THE JUST-COMPLETED CALL TO -C WRCMPS OR MSGUPD (FOR THIS SAME SUBSET!) WOULD HAVE ALSO CAUSED A -C MESSAGE TO BE FLUSHED, AND THUS IT SHOULD NOT BE POSSIBLE TO HAVE -C TWO (2) SEPARATE BUFR MESSAGES RETURNED FROM ONE (1) CALL TO WRITSA! - - IF(MSGLEN.GT.0) THEN - IF(MSGL.NE.0) GOTO 903 - IF(MSGLEN.GT.LMSGT) GOTO 904 - MSGL = MSGLEN - DO N=1,MSGL - MSGT(N) = MSGTXT(N) - ENDDO - MSGLEN = 0 - ENDIF - -C EXITS -C ----- - -100 RETURN -900 CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') -903 CALL BORT('BUFRLIB: WRITSA - TWO BUFR MESSAGES WERE RETRIEVED '// - . 'BY ONE CALL TO THIS ROUTINE') -904 CALL BORT('BUFRLIB: WRITSA - OVERFLOW OF OUTPUT BUFR MESSAGE '// - . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END diff --git a/src/bufr/writsb.f b/src/bufr/writsb.f deleted file mode 100644 index af65d83520..0000000000 --- a/src/bufr/writsb.f +++ /dev/null @@ -1,85 +0,0 @@ - SUBROUTINE WRITSB(LUNIT) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRITSB -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT -C LUNIT HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT PACKS UP THE -C CURRENT SUBSET WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE -C BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT. -C THE DETERMINATION AS TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO -C THE MESSAGE IS MADE VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE -C LIBRARY SUBROUTINES WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT -C THE MESSAGE IS COMPRESSED. IF IT TURNS OUT THAT THE SUBSET CANNOT -C BE ADDED TO THE CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS -C FLUSHED TO LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE -C SUBSET. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C 2005-03-09 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES -C -C USAGE: CALL WRITSB (LUNIT) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C -C REMARKS: -C THIS ROUTINE CALLS: BORT MSGUPD STATUS WRCMPS -C WRTREE -C THIS ROUTINE IS CALLED BY: COPYSB WRITCP -C Also called by application programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - COMMON /MSGCMP/ CCMF - - CHARACTER*1 CCMF - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK THE FILE STATUS -C --------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - IF(IL.LT.0) GOTO 901 - IF(IM.EQ.0) GOTO 902 - -C PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE -C ---------------------------------------------- - - CALL WRTREE(LUN) - IF( CCMF.EQ.'Y' ) THEN - CALL WRCMPS(LUNIT) - ELSE - CALL MSGUPD(LUNIT,LUN) - ENDIF - -C EXITS -C ----- - - RETURN -900 CALL BORT('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS CLOSED, IT '// - . 'MUST BE OPEN FOR OUTPUT') -901 CALL BORT('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS OPEN FOR '// - . 'INPUT, IT MUST BE OPEN FOR OUTPUT') -902 CALL BORT('BUFRLIB: WRITSB - A MESSAGE MUST BE OPEN IN OUTPUT '// - . 'BUFR FILE, NONE ARE') - END diff --git a/src/bufr/wrtree.f b/src/bufr/wrtree.f deleted file mode 100644 index caf7deb207..0000000000 --- a/src/bufr/wrtree.f +++ /dev/null @@ -1,155 +0,0 @@ - SUBROUTINE WRTREE(LUN) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRTREE -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS -C AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- CORRECTED SOME MINOR ERRORS -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 10,000 TO 20,000 BYTES -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) -C INCREASED FROM 15000 TO 16000 (WAS IN -C VERIFICATION VERSION); UNIFIED/PORTABLE FOR -C WRF; ADDED DOCUMENTATION (INCLUDING -C HISTORY); REPL. "IVAL(N)=ANINT(PKS(NODE))" -C WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER -C CAUSED PROBLEMS ON SOME FOREIGN MACHINES) -C 2004-03-10 J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8 -C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM -C 20,000 TO 50,000 BYTES -C 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER -C THAN 8 CHARACTERS; USE FUNCTION IBFMS -C 2009-08-03 J. WOOLLEN -- ADDED CAPABILITY TO COPY LONG STRINGS VIA -C UFBCPY USING FILE POINTER STORED IN NEW -C COMMON UFBCPL -C 2012-03-02 J. ATOR -- USE IPKS TO HANDLE 2-03 OPERATOR CASES -C 2012-06-04 J. ATOR -- ENSURE "MISSING" CHARACTER FIELDS ARE -C PROPERLY ENCODED WITH ALL BITS SET TO 1 -C -C USAGE: CALL WRTREE (LUN) -C INPUT ARGUMENT LIST: -C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS -C -C REMARKS: -C THIS ROUTINE CALLS: IBFMS IPKM PKB PKC -C IPKS READLC -C THIS ROUTINE IS CALLED BY: WRITSA WRITSB -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), - . MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), - . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), - . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), - . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), - . ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) - COMMON /UFBCPL/ LUNCPY(NFILES) - - CHARACTER*120 LSTR - CHARACTER*10 TAG - CHARACTER*8 CVAL - CHARACTER*3 TYP - DIMENSION IVAL(MAXSS) - EQUIVALENCE (CVAL,RVAL) - REAL*8 VAL,RVAL - -C----------------------------------------------------------------------- - -C CONVERT USER NUMBERS INTO SCALED INTEGERS -C ----------------------------------------- - - DO N=1,NVAL(LUN) - NODE = INV(N,LUN) - IF(ITP(NODE).EQ.1) THEN - IVAL(N) = VAL(N,LUN) - ELSEIF(TYP(NODE).EQ.'NUM') THEN - IF(IBFMS(VAL(N,LUN)).EQ.0) THEN - IVAL(N) = IPKS(VAL(N,LUN),NODE) - ELSE - IVAL(N) = -1 - ENDIF - ENDIF - ENDDO - -C PACK THE USER ARRAY INTO THE SUBSET BUFFER -C ------------------------------------------ - - IBIT = 16 - - DO N=1,NVAL(LUN) - NODE = INV(N,LUN) - IF(ITP(NODE).LT.3) THEN - -C The value to be packed is numeric. - - CALL PKB(IVAL(N),IBT(NODE),IBAY,IBIT) - ELSE - -C The value to be packed is a character string. - - NCR=IBT(NODE)/8 - IF ( NCR.GT.8 .AND. LUNCPY(LUN).NE.0 ) THEN - -C The string is longer than 8 characters and there was a -C preceeding call to UFBCPY involving this output unit, so -C read the long string with READLC and write it into the -C output buffer using PKC. - - CALL READLC(LUNCPY(LUN),LSTR,TAG(NODE)) - CALL PKC(LSTR,NCR,IBAY,IBIT) - ELSE - RVAL = VAL(N,LUN) - IF(IBFMS(RVAL).NE.0) THEN - -C The value is "missing", so set all bits to 1 before -C packing the field as a character string. - - NUMCHR = MIN(NCR,LEN(LSTR)) - DO JJ = 1, NUMCHR - CALL IPKM(LSTR(JJ:JJ),1,255) - ENDDO - CALL PKC(LSTR,NUMCHR,IBAY,IBIT) - ELSE - -C The value is not "missing", so pack the equivalenced -C character string. Note that a maximum of 8 characters -C will be packed here, so a separate subsequent call to -C BUFR archive library subroutine WRITLC will be needed to -C fully encode any string longer than 8 characters. - - CALL PKC(CVAL,NCR,IBAY,IBIT) - ENDIF - ENDIF - - ENDIF - ENDDO - -C RESET UFBCPY FILE POINTER -C ------------------------- - - LUNCPY(LUN)=0 - - RETURN - END diff --git a/src/bufr/wtstat.f b/src/bufr/wtstat.f deleted file mode 100644 index 6fb685af2a..0000000000 --- a/src/bufr/wtstat.f +++ /dev/null @@ -1,121 +0,0 @@ - SUBROUTINE WTSTAT(LUNIT,LUN,IL,IM) - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WTSTAT -C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 -C -C ABSTRACT: THIS SUBROUTINE EITHER DISCONNECTS THE INPUT LOGICAL UNIT -C NUMBER LUNIT (AND ITS ASSOCIATED BUFR FILE) FROM THE BUFR ARCHIVE -C LIBRARY SOFTWARE OR IT CONNECTS IT AS EITHER AN INPUT OR OUPUT FILE -C AND DEFINES A BUFR MESSAGE AS BEING EITHER OPENED OR CLOSED IN -C MEMORY FOR THE BUFR FILE IN LUNIT. THIS INFORMATION IS STORED IN -C THE INTERNAL ARRAYS IOLUN AND IOMSG IN COMMON BLOCK /STBFR/. -C -C PROGRAM HISTORY LOG: -C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR -C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE -C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB -C ROUTINE "BORT" -C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE -C OPENED AT ONE TIME INCREASED FROM 10 TO 32 -C (NECESSARY IN ORDER TO PROCESS MULTIPLE -C BUFR FILES UNDER THE MPI) -C 2003-11-04 J. ATOR -- CORRECTED A "TYPO" IN TEST FOR VALID VALUE -C FOR "IM"; ADDED DOCUMENTATION -C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE -C INTERDEPENDENCIES -C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY -C DOCUMENTATION; OUTPUTS MORE COMPLETE -C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES -C ABNORMALLY -C -C USAGE: CALL WTSTAT (LUNIT, LUN, IL, IM) -C INPUT ARGUMENT LIST: -C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE -C LUN - INTEGER: I/O STREAM INDEX ASSOCIATED WITH LOGICAL UNIT -C LUNIT -C IL - INTEGER: LOGICAL UNIT STATUS INDICATOR: -C 0 = disconnect LUNIT w.r.t. BUFR Archive -C Library software (all information -C associated with LUNIT is deleted from -C within internal arrays) -C 1 = connect LUNIT as an output file w.r.t. to -C BUFR Archive Library software -C -1 = connect LUNIT as an input file w.r.t. to -C BUFR Archive Library software -C IM - INTEGER: DEFINES WHETHER THERE IS A BUFR MESSAGE -C CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT (IF IT IS -C CONNECTED, I.E., IL .NE. ZERO): -C 0 = no -C 1 = yes -C -C REMARKS: -C THIS ROUTINE CALLS: BORT -C THIS ROUTINE IS CALLED BY: CLOSBF CLOSMG OPENBF OPENMB -C OPENMG RDMEMM READERME REWNBF -C READMG -C Normally not called by any application -C programs. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: PORTABLE TO ALL PLATFORMS -C -C$$$ - - INCLUDE 'bufrlib.prm' - - COMMON /STBFR/ IOLUN(NFILES),IOMSG(NFILES) - - CHARACTER*128 BORT_STR - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - -C CHECK ON THE ARGUMENTS -C ---------------------- - - IF(LUNIT.LE.0) GOTO 900 - IF(LUN .LE.0) GOTO 901 - IF(IL.LT.-1 .OR. IL.GT.1) GOTO 902 - IF(IM.LT. 0 .OR. IM.GT.1) GOTO 903 - -C CHECK ON LUNIT-LUN COMBINATION -C ------------------------------ - - IF(ABS(IOLUN(LUN)).NE.LUNIT) THEN - IF(IOLUN(LUN).NE.0) GOTO 905 - ENDIF - -C RESET THE FILE STATUSES -C ----------------------- - - IF(IL.NE.0) THEN - IOLUN(LUN) = SIGN(LUNIT,IL) - IOMSG(LUN) = IM - ELSE - IOLUN(LUN) = 0 - IOMSG(LUN) = 0 - ENDIF - -C EXITS -C ----- - - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED '// - . ' INTO FIRST ARGUMENT (INPUT) (=",I3,")")') LUNIT - CALL BORT(BORT_STR) -901 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID I/O STREAM INDEX '// - . 'PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') LUN - CALL BORT(BORT_STR) -902 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS'// - . ' INDICATOR PASSED INTO THIRD ARGUMENT (INPUT) (=",I4,")")') IL - CALL BORT(BORT_STR) -903 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS'// - . ' INDICATOR PASSED INTO FOURTH ARGUMENT (INPUT) (=",I4,")")') IM - CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE '// - . 'EXISTING FILE UNIT (LOGICAL UNIT NUMBER ",I3,")")') IOLUN(LUN) - CALL BORT(BORT_STR) - END diff --git a/src/gsi/.CMakeLists.txt.swp b/src/gsi/.CMakeLists.txt.swp deleted file mode 100644 index 0159a8f5a989dc0467b329ac421a6265fb0b4394..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 16384 zcmeHNPmJSM8F#x-SYQhjkSG%DBeT%VFinQtvSpDd^*GK<*h~_fWV#C#uE%*v%sNi6 zot+u2M!P^I)B^{~g`zHk3j%}$stOmx38~_SsMIa$a^i%<1ynAj2l#!@&xw=CWM;}1 zfn-ZR&DehLd+&Y!zt7oP*(`0ahjR}pxZa~EwST<)<@;BL*J||BvhcKfPN~z72dGcmmi2P5`&=Rg`CeA@B%r8u;@mMR^YJ z0Ts9lP=H^(OHsZBTm!1W8Gr$&ftTKicfg~--`}AqKLWl7JOg|axD4a~1-NxmQCz5u+6X36(~n}7>k0qVd9 zfuEw$@)Mu|ycZz8zY;fFaNIk1F=n+|rt56^mcN@la}7VVsIRMrUMQDV_gKB5HcA>3 zkDHBB*{mDd9$Qox3wW4Kj%6AAGy`PJpzF8JTx;>IVaE)H?Y6VCmtmT!t?R5*Y3N2p zEwfB!QCVp5w&QUYb~*E`9%sXVw^+OHGmvHVuI1wv1exWvXphVZ*|rmQ*}(4)xF0$^ z5U(81c84v_T8Ts|Y%(Bna1b$B*|`SH?><}u7WkR~0UsW=lI zK0d&}3cKP2#9Cs4*fJOnO1LXljYhNcBo-F(a_k_k-g(B~be z?^$jhFAvx!i`ZJx3MF+-*dK$7Af6cdMs*Vg-q1IajA5C1JojvP39Dmn`%cKsUcZ%V zUs#Fk`i{``xz(B^3n@*XVS)L)*T2eHbgE@Yl3bkw@5V^G`X2W}wl#Fz5M1f;?JoB@ z<8HunB)~{?!p27`Ep$aZ8d<1(bg=#f;c(0Jf>3hd(DAeMmEoGl@8p~b4U!WllxR}- z=Smrx)bX9xm|X#$7!g;svRbc`Y6?XGuU#udV2SNYgpgQ!mzfoSh}U*HL*LqRIer1f zh9SZlMVn<|@IA}%7-Ex@8X}h8?};})4?@;&Ppa+$v)UotgXOwo$|3ZewfF$WN3ym1 z2wz!}Eh8z2E!hLtUtDHeR=}CduW}bVNf>;j9>f${k%&td%OJlYBETq++I{TR=?z@o z!&(+C9V{mm=U|n%;&`nK&w9GnUwI=z<@Y%}Y z|0s>2%pmOg{b8p&$@66v4DBun87^jdWNlJ(bT!7%eW+0Ayo^Y9MScgIFUT#%#;OcEv)_CFB$Rm>#q!-rzFZ?m9Skq;Ubu!UG57 zexXn?Cl6OBaBXR^m~cY}YZHwBs8Xk)Ff;PT&=4u}*t=ohlo8^j;@~3rlU9iH zBxDpFFrGGfz{py9jFy2gVA_J5NI~(hOie*gzocuzT!PStRI_kf`Xxl0T3OX}ma$zc z2r~E!b48Xb9hitZvESLtEHZ4xhO|QtpPn>Y7$>|2Tzrc(Mi7&s8ONTxAUTT6*o#q^ zJN|;g+eE1V6YFLvVPPXmbDg=^?b3x6L?F0dWJFU(14l+@p*14fU}=*=Fue@vVWi$0)j|`Avq7!r0^xMd>8gU{|>xPy{-cJD)qNMCpuc~7Pt?19d-U~;6>m!z)j$3U>E2CXMrs60PqrO z{}+HR@EU6UUjt78RQvxP^*#sA03QPG2krrWj5>b@co_IF@K@CM&ja58bl^5>`lo=? zzz2Z$1OGxD|2u$c{I3BwfFh(52 zeE1lUUMUC09H3-|F4fT1OPe}FXQ5H5pn(E2irqx1f|g3TY}O3DSh}>AN5+y5C@r(2 zM4skHvHtQ==PNXaE~8m#ls1mG?v~>z)GNW-uA6PB#+u%cO#ljcdw40YsC`f_$l4vv z6H$Gcql|<)By078R<1S+^66!I_C<`C9JTGYab9|-UuqaCUREyZM$~|q?z4=^j~RoB zWwoYi7n5WkEa&nEQd}<-Kb0H|F*J?x)D!9qjh6#0k#SL}*_hyi>>7=Rn#f>j+tbhK znOHb(d#q2bnCuIUsO>TEJhXg-Qncf|E3zj??JFSyAr??Zj7v1=#64)xn$vHP=IM=R4dUhN2Rh3|7Wr?n=tJ2xHDJbIgQIvZ%meWB4rxc$N_y`7=d6) zt+`r8=lVz#XYW0-sEF9OYkEiaK4srCY**+M){ct4y?F+6pbm^!HFLQ+(?~%g*C4+L zh_T6U0b+ZjZvjz_HsNkWi=WhuvgSx8qb~$eEAlAc2#5e}X6%P#J3HYF;{q>gT8|c_ z5hQ)Ay{gvry{Y9QZ`mwT5Z?cJ0+X0N@_np=&l5uVU0_k31J|Z%5)then; call getqset7( qset7); if(nrand>7)call getqset13(qset13) else; call getqset5(nrand,qset5) endif -if(nrand>91) call getqset5(3,qset5) +if(nrand>91) call getqset5(3,qset3(:,:)) ! Project the data onto nrand differently-oriented Hilbert curves and sum diff --git a/src/gsi/pietc.f90 b/src/gsi/pietc.f90 index 43e7421f3d..59df1b65f2 100755 --- a/src/gsi/pietc.f90 +++ b/src/gsi/pietc.f90 @@ -10,7 +10,7 @@ module pietc ! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, ! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. !============================================================================= -use kinds, only: dp,dpc +use kinds, only: r_kind, dp, dpc implicit none logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops real(dp),parameter:: & diff --git a/src/gsi/pvqc_tables.f90 b/src/gsi/pvqc_tables.f90 index 25bf8ca9ed..6f8da834c9 100755 --- a/src/gsi/pvqc_tables.f90 +++ b/src/gsi/pvqc_tables.f90 @@ -27,7 +27,7 @@ module pvqc_tables ! na: size [0:na] of one-sided table in alpha ! linitvqc: logical flag, true only when tables are initialized !============================================================================= -use kinds, only: dp,i_kind +use kinds, only: r_kind,dp,i_kind implicit none public real(dp),allocatable,dimension(:,:,:):: sgt,swt diff --git a/src/wrflib/CMakeLists.txt b/src/wrflib/CMakeLists.txt deleted file mode 100644 index a7bb3ceb43..0000000000 --- a/src/wrflib/CMakeLists.txt +++ /dev/null @@ -1,11 +0,0 @@ -cmake_minimum_required(VERSION 2.6) -file(GLOB WRFLIB_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*90) -file(GLOB WRFLIB_C_SRC ${CMAKE_CURRENT_SOURCE_DIR}/*.c) -set_source_files_properties( ${WRFLIB_SRC} PROPERTIES COMPILE_FLAGS ${WRFLIB_Fortran_FLAGS} ) -set(WRFLIB_C_FLAGS "${WRFLIB_C_INCLUDES} -DLINUX -Dfunder -DFortranByte=char -DFortranInt=int -DFortranLlong='long long'") -set_source_files_properties( ${WRFLIB_C_SRC} PROPERTIES COMPILE_FLAGS ${WRFLIB_C_FLAGS} ) -set( wrflib "WRFLIB" CACHE INTERNAL "WRF Library for I/O" ) -include_directories(${NETCDF_INCLUDES}) -add_library( ${wrflib} STATIC ${WRFLIB_SRC} ${WRFLIB_C_SRC} ) -set_target_properties( ${wrflib} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - diff --git a/src/wrflib/ext_ncd_get_dom_ti.code b/src/wrflib/ext_ncd_get_dom_ti.code deleted file mode 100644 index fe365f153c..0000000000 --- a/src/wrflib/ext_ncd_get_dom_ti.code +++ /dev/null @@ -1,157 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - TYPE_BUFFER - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,Buffer) -#else - Data = '' - stat = NF_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - COPY - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif -ENDIF - return diff --git a/src/wrflib/ext_ncd_get_var_td.code b/src/wrflib/ext_ncd_get_var_td.code deleted file mode 100644 index bd28dc38a3..0000000000 --- a/src/wrflib/ext_ncd_get_var_td.code +++ /dev/null @@ -1,227 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - TYPE_BUFFER ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = LENGTH - VCount(2) = 1 -#ifndef CHAR_TYPE - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE (NCID,VarID,VStart,VCount,Buffer) -#else - if(Len1 > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -#ifndef CHAR_TYPE - COPY - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return diff --git a/src/wrflib/ext_ncd_get_var_ti.code b/src/wrflib/ext_ncd_get_var_ti.code deleted file mode 100644 index 47a161ba99..0000000000 --- a/src/wrflib/ext_ncd_get_var_ti.code +++ /dev/null @@ -1,174 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - TYPE_OUTCOUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - TYPE_BUFFER - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_TYPE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - endif -#ifndef CHAR_TYPE - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) -#else - if(XLen > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - endif - COPY -#ifndef CHAR_TYPE - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/src/wrflib/ext_ncd_put_dom_ti.code b/src/wrflib/ext_ncd_put_dom_ti.code deleted file mode 100644 index 2d5b1a3e9e..0000000000 --- a/src/wrflib/ext_ncd_put_dom_ti.code +++ /dev/null @@ -1,164 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (DH%NCID,NF_GLOBAL,Element,ARGS) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif -ENDIF - return diff --git a/src/wrflib/ext_ncd_put_var_td.code b/src/wrflib/ext_ncd_put_var_td.code deleted file mode 100644 index 750e1ecd37..0000000000 --- a/src/wrflib/ext_ncd_put_var_td.code +++ /dev/null @@ -1,233 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(LENGTH < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == LENGTH) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),LENGTH,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = LENGTH - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = LENGTH - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_TYPE,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - enddo - if(LENGTH > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(LENGTH < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = LENGTH - VCount(2) = 1 -#ifdef LOG - allocate(Buffer(LENGTH), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#else - stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/src/wrflib/ext_ncd_put_var_ti.code b/src/wrflib/ext_ncd_put_var_ti.code deleted file mode 100644 index 05bfc64ca3..0000000000 --- a/src/wrflib/ext_ncd_put_var_ti.code +++ /dev/null @@ -1,144 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - TYPE_DATA - TYPE_COUNT - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo -#ifdef LOG - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo -#endif -#ifdef CHAR_TYPE - if(len_trim(Data).le.0) then - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) - else - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) - endif -#else - stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), ARGS ) -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif -#ifdef LOG - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif -#endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return diff --git a/src/wrflib/field_routines.F90 b/src/wrflib/field_routines.F90 deleted file mode 100644 index cd9bcfa7bf..0000000000 --- a/src/wrflib/field_routines.F90 +++ /dev/null @@ -1,175 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- -subroutine ext_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - real, dimension(*) ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_RealFieldIO - -subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - real*8 ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_DoubleFieldIO - -subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer ,dimension(NVarDims),intent(in) :: VStart - integer ,dimension(NVarDims),intent(in) :: VCount - integer ,intent(inout) :: Data - integer ,intent(out) :: Status - integer :: stat - - if(IO == 'write') then - stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data) - else - stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - endif - return -end subroutine ext_ncd_IntFieldIO - -subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(NVarDims) ,intent(in) :: VStart - integer,dimension(NVarDims) ,intent(in) :: VCount - logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data - integer ,intent(out) :: Status - integer,dimension(:,:,:),allocatable :: Buffer - integer :: stat - integer :: i,j,k - - allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - if(IO == 'write') then - do k=1,VCount(3) - do j=1,VCount(2) - do i=1,VCount(1) - if(data(i,j,k)) then - Buffer(i,j,k)=1 - else - Buffer(i,j,k)=0 - endif - enddo - enddo - enddo - stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer) - else - stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer) - Data = Buffer == 1 - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , msg) - return - endif - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_LogicalFieldIO diff --git a/src/wrflib/io_int_stubs.f90 b/src/wrflib/io_int_stubs.f90 deleted file mode 100755 index 83c580a57d..0000000000 --- a/src/wrflib/io_int_stubs.f90 +++ /dev/null @@ -1,157 +0,0 @@ -! Stubs version of wrf io spi subroutines -! -!--- get_dom_ti_real -SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) :: Element - REAL , INTENT(INOUT) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER , INTENT(INOUT) :: Outcount - INTEGER , INTENT(INOUT) :: Status - - write(6,*) 'Calling dummy 1' -RETURN -END SUBROUTINE ext_int_get_dom_ti_real - - -SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) - - write(6,*) 'Calling dummy 2' -RETURN -END SUBROUTINE ext_int_get_dom_ti_integer - - -!--- get_dom_ti_char -SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element, Data, Status ) - write(6,*) 'Calling dummy 3' - -RETURN -END SUBROUTINE ext_int_get_dom_ti_char - - -!--- get_var_info -SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & - DomainStart , DomainEnd , WrfType, Status ) - - write(6,*) 'Calling dummy 4' -RETURN -END SUBROUTINE ext_int_get_var_info - - -!--- read_field -SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd , & - Status ) - write(6,*) 'Calling dummy 5' - RETURN - -END SUBROUTINE ext_int_read_field - - -!--- close -SUBROUTINE ext_int_ioclose ( DataHandle, Status ) - - write(6,*) 'Calling dummy 6' - RETURN -END SUBROUTINE ext_int_ioclose - - -!--- initialize -SUBROUTINE ext_int_ioinit( SysDepInfo, Status ) - - write(6,*) 'Calling dummy 7' -END SUBROUTINE ext_int_ioinit - - - -!--- open_for_read -SUBROUTINE ext_int_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & - DataHandle , Status ) - - write(6,*) 'Calling dummy 8' - RETURN -END SUBROUTINE ext_int_open_for_read - - - -!SUBROUTINE int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & -! DataHandle, Data, Count, code ) - -! write(6,*) 'Calling dummy 9' -!RETURN -!END SUBROUTINE int_get_ti_header_c - - -! NETCDF STUBS -!SUBROUTINE ext_ncd_ioinit(SysDepInfo, Status) - -!RETURN -!END SUBROUTINE ext_ncd_ioinit - - -!subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - -!RETURN -!END subroutine ext_ncd_open_for_read - - -!subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) - -!RETURN -!END subroutine ext_ncd_get_dom_ti_integer - - -!subroutine ext_ncd_ioclose(DataHandle, Status) - -! return -!end subroutine ext_ncd_ioclose - - -!subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) - -! return -!end subroutine ext_ncd_get_dom_ti_char - - -!subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,Status) - -! return -!end subroutine ext_ncd_get_dom_ti_real - - -!subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder, & -! Stagger,DomainStart,DomainEnd,WrfType,Status) - -! return -!end subroutine ext_ncd_get_var_info - - -!subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & -! IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & -! DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - -! return -!end subroutine ext_ncd_read_field - - -!subroutine wrf_error_fatal(massage) - -!stop -!end subroutine wrf_error_fatal - - -!subroutine int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & -! DataHandle, Data, Count, code ) -! write(6,*) 'Calling dummy 10' -!RETURN -!END SUBROUTINE int_gen_ti_header_c - - - - - - - diff --git a/src/wrflib/model_data_order.inc b/src/wrflib/model_data_order.inc deleted file mode 100644 index 91a5098b8f..0000000000 --- a/src/wrflib/model_data_order.inc +++ /dev/null @@ -1,8 +0,0 @@ -!STARTOFREGISTRYGENERATEDINCLUDE 'inc/model_data_order.inc' -! -! WARNING This file is generated automatically by use_registry -! using the data base in the file named Registry. -! Do not edit. Your changes to this file will be lost. -! -INTEGER , PARAMETER :: model_data_order = DATA_ORDER_XZY -!ENDOFREGISTRYGENERATEDINCLUDE diff --git a/src/wrflib/module_driver_constants.F90 b/src/wrflib/module_driver_constants.F90 deleted file mode 100644 index e5e7f71872..0000000000 --- a/src/wrflib/module_driver_constants.F90 +++ /dev/null @@ -1,180 +0,0 @@ -!WRF:DRIVER_LAYER:CONSTANTS -! -! This MODULE contains all of the constants used in the model. These -! are separated by usage within the code. - -#define MAX_DOMAINS_F 21 -# define IWORDSIZE 4 -# define DWORDSIZE 8 -# define RWORDSIZE 4 -# define LWORDSIZE 4 - -MODULE module_driver_constants - - ! 0. The following tells the rest of the model what data ordering we are - ! using - - INTEGER , PARAMETER :: DATA_ORDER_XYZ = 1 - INTEGER , PARAMETER :: DATA_ORDER_YXZ = 2 - INTEGER , PARAMETER :: DATA_ORDER_ZXY = 3 - INTEGER , PARAMETER :: DATA_ORDER_ZYX = 4 - INTEGER , PARAMETER :: DATA_ORDER_XZY = 5 - INTEGER , PARAMETER :: DATA_ORDER_YZX = 6 - INTEGER , PARAMETER :: DATA_ORDER_XY = DATA_ORDER_XYZ - INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ - - -#include "model_data_order.inc" - - ! 1. Following are constants for use in defining maximal values for array - ! definitions. - ! - - ! The maximum number of levels in the model is how deeply the domains may - ! be nested. - - INTEGER , PARAMETER :: max_levels = 20 - - ! The maximum number of nests that can depend on a single parent and other way round - - INTEGER , PARAMETER :: max_nests = 20 - - ! The maximum number of parents that a nest can have (simplified assumption -> one only) - - INTEGER , PARAMETER :: max_parents = 1 - - ! The maximum number of domains is how many grids the model will be running. - - INTEGER , PARAMETER :: max_domains = ( MAX_DOMAINS_F - 1 ) / 2 + 1 - - ! The maximum number of nest move specifications allowed in a namelist - - INTEGER , PARAMETER :: max_moves = 50 - - ! The maximum number of eta levels - !DJW 140701 Increased from 501 to 1001 since I can imagine using more than - !501 total vertical levels across multiple nested domains. Now that the - !code is modified to allow specification of all domains eta_levels using a - !array of length max_eta, this will need to be larger. I'll also add a check - !in module_initialize_real to ensure we don't exceed this value. - - INTEGER , PARAMETER :: max_eta = 1001 - - ! The maximum number of ocean levels in the 3d U Miami ocean. - - INTEGER , PARAMETER :: max_ocean = 501 - - ! The maximum number of pressure levels to interpolate to, for diagnostics - - INTEGER , PARAMETER :: max_plevs = 100 - - ! The maximum number of height levels to interpolate to, for diagnostics - - INTEGER , PARAMETER :: max_zlevs = 100 - - ! The maximum number of trackchem - - INTEGER , PARAMETER :: max_trackchem = 100 - - ! The maximum number of outer iterations (for DA minimisation) - - INTEGER , PARAMETER :: max_outer_iterations = 100 - - ! The maximum number of instruments (for radiance DA) - - INTEGER , PARAMETER :: max_instruments = 30 - - ! The maximum number of obs indexes (for conventional DA obs) - - INTEGER , PARAMETER :: num_ob_indexes = 28 - - - ! The maximum number of bogus storms - - INTEGER , PARAMETER :: max_bogus = 5 - - ! The maximum number of fields that can be sent or received in coupled mode - - INTEGER , PARAMETER :: max_cplfld = 20 - - ! The maximum number of domains used by the external model with which wrf is communicating in coupled mode - - INTEGER , PARAMETER :: max_extdomains = 5 - - ! 2. Following related to driver level data structures for DM_PARALLEL communications - -#ifdef DM_PARALLEL - INTEGER , PARAMETER :: max_comms = 1024 -#else - INTEGER , PARAMETER :: max_comms = 1 -#endif - - ! 3. Following is information related to the file I/O. - - ! These are the bounds of the available FORTRAN logical unit numbers for the file I/O. - ! Only logical unit numbers within these bounds will be chosen for I/O unit numbers. - - INTEGER , PARAMETER :: min_file_unit = 10 - INTEGER , PARAMETER :: max_file_unit = 99 - - ! 4. Unfortunately, the following definition is needed here (rather - ! than the more logical place in share/module_model_constants.F) - ! for the namelist reads in frame/module_configure.F, and for some - ! conversions in share/set_timekeeping.F - ! Actually, using it here will mean that we don't need to set it - ! in share/module_model_constants.F, since this file will be - ! included (USEd) in: - ! frame/module_configure.F - ! which will be USEd in: - ! share/module_bc.F - ! which will be USEd in: - ! phys/module_radiation_driver.F - ! which is the other important place for it to be, and where - ! it is passed as a subroutine parameter to any physics subroutine. - ! - ! P2SI is the number of SI seconds in an planetary solar day - ! divided by the number of SI seconds in an earth solar day -#if defined MARS - ! For Mars, P2SI = 88775.2/86400. - REAL , PARAMETER :: P2SI = 1.0274907 -#elif defined TITAN - ! For Titan, P2SI = 1378080.0/86400. - REAL , PARAMETER :: P2SI = 15.95 -#else - ! Default for Earth - REAL , PARAMETER :: P2SI = 1.0 -#endif - CONTAINS - SUBROUTINE init_module_driver_constants - END SUBROUTINE init_module_driver_constants - END MODULE module_driver_constants - -! routines that external packages can call to get at WRF stuff that isn't available -! through argument lists; since they are external we don't want them using WRF -! modules unnecessarily (complicates the build even more) - SUBROUTINE inquire_of_wrf_data_order_xyz( data_order ) - USE module_driver_constants, ONLY : DATA_ORDER_XYZ - IMPLICIT NONE - INTEGER, INTENT(OUT) :: data_order - data_order = DATA_ORDER_XYZ - END SUBROUTINE inquire_of_wrf_data_order_xyz - - SUBROUTINE inquire_of_wrf_data_order_xzy( data_order ) - USE module_driver_constants, ONLY : DATA_ORDER_XZY - IMPLICIT NONE - INTEGER, INTENT(OUT) :: data_order - data_order = DATA_ORDER_XZY - END SUBROUTINE inquire_of_wrf_data_order_xzy - - SUBROUTINE inquire_of_wrf_iwordsize( iwordsz ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: iwordsz - iwordsz = IWORDSIZE - END SUBROUTINE inquire_of_wrf_iwordsize - - SUBROUTINE inquire_of_wrf_rwordsize( rwordsz ) - IMPLICIT NONE - INTEGER, INTENT(OUT) :: rwordsz - rwordsz = RWORDSIZE - END SUBROUTINE inquire_of_wrf_rwordsize - diff --git a/src/wrflib/module_machine.F90 b/src/wrflib/module_machine.F90 deleted file mode 100644 index 1888337f39..0000000000 --- a/src/wrflib/module_machine.F90 +++ /dev/null @@ -1,175 +0,0 @@ -!WRF:DRIVER_LAYER:DECOMPOSITION -! -# define IWORDSIZE 4 -# define DWORDSIZE 8 -# define RWORDSIZE 4 -# define LWORDSIZE 4 - -MODULE module_machine - - USE module_driver_constants - - ! Machine characteristics and utilities here. - - ! Tile strategy defined constants - INTEGER, PARAMETER :: TILE_NONE = 0, TILE_X = 1, TILE_Y = 2, TILE_XY = 3 - - CONTAINS - - RECURSIVE SUBROUTINE rlocproc(p,maxi,nproc,ml,mr,ret) - IMPLICIT NONE - INTEGER, INTENT(IN) :: p, maxi, nproc, ml, mr - INTEGER, INTENT(OUT) :: ret - INTEGER :: width, rem, ret2, bl, br, mid, adjust, & - p_r, maxi_r, nproc_r, zero - adjust = 0 - rem = mod( maxi, nproc ) - width = maxi / nproc - mid = maxi / 2 - IF ( rem>0 .AND. (((mod(rem,2).EQ.0).OR.(rem.GT.2)).OR.(p.LE.mid))) THEN - width = width + 1 - END IF - IF ( p.LE.mid .AND. mod(rem,2).NE.0 ) THEN - adjust = adjust + 1 - END IF - bl = max(width,ml) ; - br = max(width,mr) ; - IF (pmaxi-br-1) THEN - ret = nproc-1 - ELSE - p_r = p - bl - maxi_r = maxi-bl-br+adjust - nproc_r = max(nproc-2,1) - zero = 0 - CALL rlocproc( p_r, maxi_r, nproc_r, zero, zero, ret2 ) ! Recursive - ret = ret2 + 1 - END IF - RETURN - END SUBROUTINE rlocproc - - INTEGER FUNCTION locproc( i, m, numpart ) - implicit none - integer, intent(in) :: i, m, numpart - integer :: retval, ii, im, inumpart, zero - ii = i - im = m - inumpart = numpart - zero = 0 - CALL rlocproc( ii, im, inumpart, zero, zero, retval ) - locproc = retval - RETURN - END FUNCTION locproc - - SUBROUTINE patchmap( res, y, x, py, px ) - implicit none - INTEGER, INTENT(IN) :: y, x, py, px - INTEGER, DIMENSION(x,y), INTENT(OUT) :: res - INTEGER :: i, j, p_min, p_maj - DO j = 0,y-1 - p_maj = locproc( j, y, py ) - DO i = 0,x-1 - p_min = locproc( i, x, px ) - res(i+1,j+1) = p_min + px*p_maj - END DO - END DO - RETURN - END SUBROUTINE patchmap - - SUBROUTINE region_bounds( region_start, region_end, & - num_p, p, & - patch_start, patch_end ) - ! 1-D decomposition routine: Given starting and ending indices of a - ! vector, the number of patches dividing the vector, and the number of - ! the patch, give the start and ending indices of the patch within the - ! vector. This will work with tiles too. Implementation note. This is - ! implemented somewhat inefficiently, now, with a loop, so we can use the - ! locproc function above, which returns processor number for a given - ! index, whereas what we want is index for a given processor number. - ! With a little thought and a lot of debugging, we can come up with a - ! direct expression for what we want. For time being, we loop... - ! Remember that processor numbering starts with zero. - - IMPLICIT NONE - INTEGER, INTENT(IN) :: region_start, region_end, num_p, p - INTEGER, INTENT(OUT) :: patch_start, patch_end - INTEGER :: offset, i - patch_end = -999999999 - patch_start = 999999999 - offset = region_start - do i = 0, region_end - offset - if ( locproc( i, region_end-region_start+1, num_p ) == p ) then - patch_end = max(patch_end,i) - patch_start = min(patch_start,i) - endif - enddo - patch_start = patch_start + offset - patch_end = patch_end + offset - RETURN - END SUBROUTINE region_bounds - - SUBROUTINE least_aspect( nparts, minparts_y, minparts_x, nparts_y, nparts_x ) - IMPLICIT NONE - ! Input data. - INTEGER, INTENT(IN) :: nparts, & - minparts_y, minparts_x - ! Output data. - INTEGER, INTENT(OUT) :: nparts_y, nparts_x - ! Local data. - INTEGER :: x, y, mini - mini = 2*nparts - nparts_y = 1 - nparts_x = nparts - DO y = 1, nparts - IF ( mod( nparts, y ) .eq. 0 ) THEN - x = nparts / y - IF ( abs( y-x ) .LT. mini & - .AND. y .GE. minparts_y & - .AND. x .GE. minparts_x ) THEN - mini = abs( y-x ) - nparts_y = y - nparts_x = x - END IF - END IF - END DO - END SUBROUTINE least_aspect - - SUBROUTINE init_module_machine - RETURN - END SUBROUTINE init_module_machine - -END MODULE module_machine - -SUBROUTINE wrf_sizeof_integer( retval ) - IMPLICIT NONE - INTEGER retval -! IWORDSIZE is defined by CPP - retval = IWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_integer - -SUBROUTINE wrf_sizeof_real( retval ) - IMPLICIT NONE - INTEGER retval -! RWORDSIZE is defined by CPP - retval = RWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_real - -SUBROUTINE wrf_sizeof_doubleprecision( retval ) - IMPLICIT NONE - INTEGER retval -! DWORDSIZE is defined by CPP - retval = DWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_doubleprecision - -SUBROUTINE wrf_sizeof_logical( retval ) - IMPLICIT NONE - INTEGER retval -! LWORDSIZE is defined by CPP - retval = LWORDSIZE - RETURN -END SUBROUTINE wrf_sizeof_logical - diff --git a/src/wrflib/pack_utils.c b/src/wrflib/pack_utils.c deleted file mode 100644 index 3caa8cc04f..0000000000 --- a/src/wrflib/pack_utils.c +++ /dev/null @@ -1,390 +0,0 @@ -#ifndef MS_SUA -# include -# include -#endif -#include -#include "streams.h" - -#ifndef CRAY -# ifdef NOUNDERSCORE -# define INT_PACK_DATA int_pack_data -# define INT_GET_TI_HEADER_C int_get_ti_header_c -# define INT_GEN_TI_HEADER_C int_gen_ti_header_c -# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c -# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c -# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c -# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field -# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field -# define PERTURB_REAL perturb_real -# define INSPECT_HEADER inspect_header -# define RESET_MASK reset_mask -# define SET_MASK set_mask -# define GET_MASK get_mask -# else -# ifdef F2CSTYLE -# define INT_PACK_DATA int_pack_data__ -# define INT_GET_TI_HEADER_C int_get_ti_header_c__ -# define INT_GEN_TI_HEADER_C int_gen_ti_header_c__ -# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c__ -# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c__ -# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c__ -# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field__ -# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field__ -# define PERTURB_REAL perturb_real__ -# define INSPECT_HEADER inspect_header__ -# define RESET_MASK reset_mask__ -# define SET_MASK set_mask__ -# define GET_MASK get_mask__ -# else -# define INT_PACK_DATA int_pack_data_ -# define INT_GET_TI_HEADER_C int_get_ti_header_c_ -# define INT_GEN_TI_HEADER_C int_gen_ti_header_c_ -# define ADD_TO_BUFSIZE_FOR_FIELD_C add_to_bufsize_for_field_c_ -# define STORE_PIECE_OF_FIELD_C store_piece_of_field_c_ -# define RETRIEVE_PIECES_OF_FIELD_C retrieve_pieces_of_field_c_ -# define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field_ -# define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field_ -# define PERTURB_REAL perturb_real_ -# define INSPECT_HEADER inspect_header_ -# define RESET_MASK reset_mask_ -# define SET_MASK set_mask_ -# define GET_MASK get_mask_ -# endif -# endif -#endif - -#ifdef MEMCPY_FOR_BCOPY -# define bcopy(A,B,C) memcpy((B),(A),(C)) -#endif - -/* CALL int_pack_data ( hdrbuf , hdrbufsiz * inttypesize , int_local_output_buffer, int_local_output_cursor ) */ - -void INT_PACK_DATA ( unsigned char *buf , int *ninbytes , unsigned char *obuf, int *cursor ) -{ - int i, lcurs ; - lcurs = *cursor - 1 ; - for ( i = 0 ; i < *ninbytes ; i++ ) - { - obuf[lcurs++] = buf[i] ; - } - *cursor = lcurs+1 ; -} - -int -INT_GEN_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, /* hdrbufsize is in bytes */ - int * itypesize, int * typesize, - int * DataHandle, char * Data, - int * Count, int * code ) -{ - int i ; - char * p ; - p = hdrbuf ; - p += sizeof(int) ; - bcopy( code, p, sizeof(int) ) ; p += sizeof(int) ; /* 2 */ - bcopy( DataHandle, p, sizeof(int) ) ; p += sizeof(int) ; /* 3 */ - bcopy( typesize, p, sizeof(int) ) ; p += sizeof(int) ; /* 4 */ - bcopy( Count, p, sizeof(int) ) ; p += sizeof(int) ; /* 5 */ - bcopy( Data, p, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */ - *hdrbufsize = (int) (p - hdrbuf) ; - bcopy( hdrbufsize, hdrbuf, sizeof(int) ) ; - return(0) ; -} - -int -INT_GET_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, int * n, /* hdrbufsize and n are in bytes */ - int * itypesize, int * typesize, - int * DataHandle, char * Data, - int * Count, int * code ) -{ - int i ; - char * p ; - p = hdrbuf ; - bcopy( p, hdrbufsize, sizeof(int) ) ; p += sizeof(int) ; /* 1 */ - bcopy( p, code, sizeof(int) ) ; p += sizeof(int) ; /* 2 */ - bcopy( p, DataHandle, sizeof(int) ) ; p += sizeof(int) ; /* 3 */ - bcopy( p, typesize, sizeof(int) ) ; p += sizeof(int) ; /* 4 */ - bcopy( p, Count, sizeof(int) ) ; p += sizeof(int) ; /* 5 */ - if ( *Count * *typesize > 0 ) { - bcopy( p, Data, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */ - } - *n = (int)( p - hdrbuf ) ; - return(0) ; -} - -#define MAX_FLDS 2000 -static char fld_name[MAX_FLDS][256] ; -static char *fld_cache[MAX_FLDS] ; -static int fld_curs[MAX_FLDS] ; -static int fld_bufsize[MAX_FLDS] ; -static int fld = 0 ; -static int numflds = 0 ; -static int frst = 1 ; - -int INIT_STORE_PIECE_OF_FIELD () -{ - int i ; - if ( frst ) { - for ( i = 0 ; i < MAX_FLDS ; i++ ) { - fld_cache[i] = NULL ; - } - frst = 0 ; - } - numflds = 0 ; - for ( i = 0 ; i < MAX_FLDS ; i++ ) { - strcpy( fld_name[i], "" ) ; - if ( fld_cache[i] != NULL ) free( fld_cache[i] ) ; - fld_cache[i] = NULL ; - fld_curs[i] = 0 ; - fld_bufsize[i] = 0 ; - } - return(0) ; -} - -int INIT_RETRIEVE_PIECES_OF_FIELD () -{ - fld = 0 ; - return(0) ; -} - -int -ADD_TO_BUFSIZE_FOR_FIELD_C ( int varname[], int * chunksize ) -{ - int i, n ; - int found ; - char vname[256] ; - - n = varname[0] ; - for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; } - vname[n] = '\0' ; - - found = -1 ; - for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } } - if ( found == -1 ) { - found = numflds++ ; - strcpy( fld_name[found], vname ) ; - fld_bufsize[found] = *chunksize ; - } - else - { - fld_bufsize[found] += *chunksize ; - } - if ( fld_cache[found] != NULL ) { free( fld_cache[found] ) ; } - fld_cache[found] = NULL ; - return(0) ; -} - -int -STORE_PIECE_OF_FIELD_C ( char * buf , int varname[], int * chunksize, int *retval ) -{ - int i, n ; - int found ; - char vname[256] ; - - n = varname[0] ; - for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; } - vname[n] = '\0' ; - - found = -1 ; - for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } } - if ( found == -1 ) { -#ifndef MS_SUA - fprintf(stderr,"frame/pack_utils.c: field (%s) not found; was not set up with add_to_bufsize_for_field\n",vname ) ; -#endif - *retval = 1 ; - return(0) ; - } - - if ( fld_cache[found] == NULL ) { - fld_cache[found] = (char *) malloc( fld_bufsize[found] ) ; - fld_curs[found] = 0 ; - } - - if ( fld_curs[found] + *chunksize > fld_bufsize[found] ) { -#ifndef MS_SUA - fprintf(stderr, -"frame/pack_utils.c: %s would overwrite %d + %d > %d [%d]\n",vname, fld_curs[found], *chunksize, fld_bufsize[found], found ) ; -#endif - *retval = 1 ; - return(0) ; - } - - bcopy( buf, fld_cache[found]+fld_curs[found], *chunksize ) ; - fld_curs[found] += *chunksize ; - *retval = 0 ; - return(0) ; -} - -int -RETRIEVE_PIECES_OF_FIELD_C ( char * buf , int varname[], int * insize, int * outsize, int *retval ) -{ - int i, n ; - int found ; - char vname[256] ; - - if ( fld < numflds ) { -#ifndef MS_SUA - if ( fld_curs[fld] > *insize ) { - fprintf(stderr,"retrieve: fld_curs[%d] (%d) > *insize (%d)\n",fld,fld_curs[fld], *insize ) ; - } -#endif - *outsize = ( fld_curs[fld] <= *insize ) ? fld_curs[fld] : *insize ; - bcopy( fld_cache[fld], buf, *outsize ) ; - varname[0] = (int) strlen( fld_name[fld] ) ; - for ( i = 1 ; i <= varname[0] ; i++ ) varname[i] = fld_name[fld][i-1] ; - if ( fld_cache[fld] != NULL ) free ( fld_cache[fld] ) ; - fld_cache[fld] = NULL ; - fld_bufsize[fld] = 0 ; - fld++ ; - *retval = 0 ; - } - else { - numflds = 0 ; - *retval = -1 ; - } - return(0) ; -} - -#define INDEX_2(A,B,NB) ( (B) + (A)*(NB) ) -#define INDEX_3(A,B,C) INDEX_2( (A), INDEX_2( (B), (C), (me[1]-ms[1]+1) ), (me[1]-ms[1]+1)*(me[0]-ms[0]+1) ) -/* flip low order bit of fp number */ -int -PERTURB_REAL ( float * field, int ds[], int de[], int ms[], int me[], int ps[], int pe[] ) -{ - int i,j,k ; - int le ; /* index of little end */ - float x = 2.0 ; - unsigned int y ; - unsigned char a[4], *p ; - if ( sizeof(float) != 4 ) return(-1) ; - /* check endianness of machine */ - bcopy ( &x, a, 4 ) ; - le = 0 ; - if ( a[0] == 0x40 ) le = 3 ; - for ( k = ps[2]-ms[2] ; k <= pe[2]-ms[2] ; k++ ) - for ( j = ps[1]-ms[1] ; j <= pe[1]-ms[1] ; j++ ) - for ( i = ps[0]-ms[0] ; i <= pe[0]-ms[0] ; i++ ) - { - /* do not change zeros */ - if ( field[ INDEX_3(k,j,i) ] != 0.0 ) { - p = (unsigned char *)&(field[ INDEX_3(k,j,i) ] ) ; - if ( *(p+le) & 1 ) { *(p+le) &= 0x7e ; } - else { *(p+le) |= 1 ; } - } - } - return(0) ; -} - -int INSPECT_HEADER ( char * buf, int * sz, int * line ) -{ - int i ; -#ifndef MS_SUA - fprintf(stderr,"INSPECT_HEADER: line = %d ", *line ) ; - if ( buf != NULL && sz != NULL ) { - for ( i = 0 ; i < *sz && i < 256 ; i++ ) { if ( (buf[i] >= 'a' && buf[i] <= 'z') || buf[i] == '_' || - (buf[i] >= 'A' && buf[i] <= 'Z') || - (buf[i] >= '0' && buf[i] <= '9') ) fprintf(stderr,"%c",buf[i]) ; - } - fprintf(stderr,"\n") ; - } -#endif - return(0) ; -} - -/* note that these work the same as the routines in tools/misc.c, but are Fortran callable. - They must be kept in sync, functionally. */ - -void -RESET_MASK ( unsigned int * mask , int *e ) -{ - int w ; - unsigned int m, n ; - - w = *e / (8*sizeof(int)-1) ; - n = 1 ; - m = ~( n << *e % (8*sizeof(int)-1) ) ; - if ( w >= 0 && w < IO_MASK_SIZE ) { - mask[w] &= m ; - } -} - -void -SET_MASK ( unsigned int * mask , int *e ) -{ - int w ; - unsigned int m, n ; - - w = *e / (8*sizeof(int)-1) ; - n = 1 ; - m = ( n << *e % (8*sizeof(int)-1) ) ; - if ( w >= 0 && w < IO_MASK_SIZE ) { - mask[w] |= m ; - } -} - -/* this is slightly different from in tools dir since it returns result as argument, not function */ -/* definition of IO_MASK_SIZE comes from build and must be uniform with frame/module_domain_type.F and - version of this function in tools dir */ -void -GET_MASK ( unsigned int * mask , int *e , int * retval ) -{ - int w ; - unsigned int m, n ; - - w = *e / (8*sizeof(int)-1) ; /* 8 is number of bits per byte */ - if ( w >= 0 && w < IO_MASK_SIZE ) { - m = mask[w] ; - n = ( 1 << *e % (8*sizeof(int)-1) ) ;; - *retval = ( (m & n) != 0 ) ; - } else { - *retval = 0 ; - } -} - -#ifdef WRAP_MALLOC -# ifndef WRAP_MALLOC_ALIGNMENT -# define WRAP_MALLOC_ALIGNMENT 128 -# endif -# define _XOPEN_SOURCE 600 -# include -void *malloc(size_t size) -{ - void *tmp; - if (posix_memalign(&tmp, WRAP_MALLOC_ALIGNMENT, size) == 0) - return tmp; - else { - errno = ENOMEM; - return NULL; - } -} -#endif - -#ifndef DM_PARALLEL -# ifndef CRAY -# ifdef NOUNDERSCORE -# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock -# else -# ifdef F2CSTYLE -# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock__ -# else -# define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock_ -# endif -# endif -# endif -# if !defined(MS_SUA) && !defined(_WIN32) -# include -int RSL_INTERNAL_MICROCLOCK () -{ - struct timeval tb ; - struct timezone tzp ; - int isec ; /* seconds */ - int usec ; /* microseconds */ - int msecs ; - gettimeofday( &tb, &tzp ) ; - isec = tb.tv_sec ; - usec = tb.tv_usec ; - msecs = 1000000 * isec + usec ; - return(msecs) ; -} -# endif -#endif - diff --git a/src/wrflib/streams.h b/src/wrflib/streams.h deleted file mode 100644 index 645b02d855..0000000000 --- a/src/wrflib/streams.h +++ /dev/null @@ -1,16 +0,0 @@ -#ifndef MAX_HISTORY -# define MAX_HISTORY 12 -#endif -#ifndef IWORDSIZE -# define IWORDSIZE 4 -#endif -#define HISTORY_STREAM 0 -#define INPUT_STREAM ((HISTORY_STREAM)+(MAX_HISTORY)) -#if 0 - max streams is MAX_HISTORY plus equal number of input streams plus 1 restart + 1 boundary -#endif -#define MAX_STREAMS (2*(MAX_HISTORY)+2) -#define BOUNDARY_STREAM (2*(MAX_HISTORY)+1) -#define RESTART_STREAM (2*(MAX_HISTORY)+2) -#define IO_MASK_SIZE ((MAX_STREAMS)/(IWORDSIZE*8)+1) - diff --git a/src/wrflib/transpose.code b/src/wrflib/transpose.code deleted file mode 100644 index 746be42fcb..0000000000 --- a/src/wrflib/transpose.code +++ /dev/null @@ -1,40 +0,0 @@ - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 - -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - DFIELD = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = DFIELD - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - - return diff --git a/src/wrflib/wrf_io.F90.orig b/src/wrflib/wrf_io.F90.orig deleted file mode 100644 index 4288b98e68..0000000000 --- a/src/wrflib/wrf_io.F90.orig +++ /dev/null @@ -1,3685 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - -module wrf_data - - integer , parameter :: FATAL = 1 - integer , parameter :: WARN = 1 - integer , parameter :: WrfDataHandleMax = 99 - integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS -#if(WRF_CHEM == 1) - integer , parameter :: MaxVars = 10000 -#else - integer , parameter :: MaxVars = 3000 -#endif - integer , parameter :: MaxTimes = 10000 - integer , parameter :: DateStrLen = 19 - integer , parameter :: VarNameLen = 31 - integer , parameter :: NO_DIM = 0 - integer , parameter :: NVarDims = 4 - integer , parameter :: NMDVarDims = 2 - character (8) , parameter :: NO_NAME = 'NULL' - character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' - -#include "wrf_io_flags.h" - - character (256) :: msg - logical :: WrfIOnotInitialized = .true. - - type :: wrf_data_handle - character (255) :: FileName - integer :: FileStatus - integer :: Comm - integer :: NCID - logical :: Free - logical :: Write - character (5) :: TimesName - integer :: TimeIndex - integer :: CurrentTime !Only used for read - integer :: NumberTimes !Only used for read - character (DateStrLen), pointer :: Times(:) - integer :: TimesVarID - integer , pointer :: DimLengths(:) - integer , pointer :: DimIDs(:) - character (31) , pointer :: DimNames(:) - integer :: DimUnlimID - character (9) :: DimUnlimName - integer , dimension(NVarDims) :: DimID - integer , dimension(NVarDims) :: Dimension - integer , pointer :: MDVarIDs(:) - integer , pointer :: MDVarDimLens(:) - character (80) , pointer :: MDVarNames(:) - integer , pointer :: VarIDs(:) - integer , pointer :: VarDimLens(:,:) - character (VarNameLen), pointer :: VarNames(:) - integer :: CurrentVariable !Only used for read - integer :: NumVars -! first_operation is set to .TRUE. when a new handle is allocated -! or when open-for-write or open-for-read are committed. It is set -! to .FALSE. when the first field is read or written. - logical :: first_operation - logical :: R4OnOutput - logical :: nofill - logical :: use_netcdf_classic - end type wrf_data_handle - type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) -end module wrf_data - -module ext_ncd_support_routines - - implicit none - -CONTAINS - -subroutine allocHandle(DataHandle,DH,Comm,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(out) :: DataHandle - type(wrf_data_handle),pointer :: DH - integer ,intent(IN) :: Comm - integer ,intent(out) :: Status - integer :: i - integer :: stat - - do i=1,WrfDataHandleMax - if(WrfDataHandles(i)%Free) then - DH => WrfDataHandles(i) - DataHandle = i - allocate(DH%Times(MaxTimes), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimLengths(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimIDs(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimNames(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarDimLens(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - exit - endif - if(i==WrfDataHandleMax) then - Status = WRF_WARN_TOO_MANY_FILES - write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) 'Did you call ext_ncd_ioinit?' - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - DH%Free =.false. - DH%Comm = Comm - DH%Write =.false. - DH%first_operation = .TRUE. - DH%R4OnOutput = .false. - DH%nofill = .false. - Status = WRF_NO_ERR -end subroutine allocHandle - -subroutine deallocHandle(DataHandle, Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN - if(.NOT. WrfDataHandles(DataHandle)%Free) then - DH => WrfDataHandles(DataHandle) - deallocate(DH%Times, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimLengths, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - DH%Free =.TRUE. - endif - ENDIF - Status = WRF_NO_ERR -end subroutine deallocHandle - -subroutine GetDH(DataHandle,DH,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - type(wrf_data_handle) ,pointer :: DH - integer ,intent(out) :: Status - - if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - DH => WrfDataHandles(DataHandle) - if(DH%Free) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - Status = WRF_NO_ERR - return -end subroutine GetDH - -subroutine DateCheck(Date,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Date - integer ,intent(out) :: Status - - if(len(Date) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - else - Status = WRF_NO_ERR - endif - return -end subroutine DateCheck - -subroutine GetName(Element,Var,Name,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Name - integer ,intent(out) :: Status - character (VarNameLen) :: VarName - character (1) :: c - integer :: i - integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - - VarName = Var - Name = 'MD___'//trim(Element)//VarName - do i=1,len(Name) - c=Name(i:i) - if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) - if(c=='-'.or.c==':') Name(i:i)='_' - enddo - Status = WRF_NO_ERR - return -end subroutine GetName - -subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: TimeIndex - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VStart(2) - integer :: VCount(2) - integer :: stat - integer :: i - - DH => WrfDataHandles(DataHandle) - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - Status = WRF_WARN_DATESTR_ERROR - write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(IO == 'write') then - TimeIndex = DH%TimeIndex - if(TimeIndex <= 0) then - TimeIndex = 1 - elseif(DateStr == DH%Times(TimeIndex)) then - Status = WRF_NO_ERR - return - else - TimeIndex = TimeIndex +1 - if(TimeIndex > MaxTimes) then - Status = WRF_WARN_TIME_EOF - write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - DH%TimeIndex = TimeIndex - DH%Times(TimeIndex) = DateStr - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = DateStrLen - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - Status = WRF_NO_ERR - TimeIndex = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - return -end subroutine GetTimeIndex - -subroutine GetDim(MemoryOrder,NDim,Status) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(out) :: NDim - integer ,intent(out) :: Status - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - NDim = 3 - case ('xy','yx','xs','xe','ys','ye','cc') - NDim = 2 - case ('z','c') - NDim = 1 - case ('0') ! NDim=0 for scalars. TBH: 20060502 - NDim = 0 - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine GetDim - -#ifdef USE_NETCDF4_FEATURES -subroutine set_chunking(MemoryOrder,need_chunking) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - logical ,intent(out) :: need_chunking - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - if(len(MemOrd) >= 2) then - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - need_chunking = .true. - case ('xy','yx') - need_chunking = .true. - case default - need_chunking = .false. - return - end select - endif -end subroutine set_chunking -#endif - -subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) - integer ,intent(in) :: NDim - integer ,dimension(*),intent(in) :: Start,End - integer ,intent(out) :: i1,i2,j1,j2,k1,k2 - - i1=1 - i2=1 - j1=1 - j2=1 - k1=1 - k2=1 - if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 - i1 = Start(1) - i2 = End (1) - if(NDim == 1) return - j1 = Start(2) - j2 = End (2) - if(NDim == 2) return - k1 = Start(3) - k2 = End (3) - return -end subroutine GetIndices - -logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(in) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - logical zero_length - - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - zero_length = .false. - select case (MemOrd) - case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy','yzx') - zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 - case ('xy','yx','xyz','yxz') - zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 - case ('zxy','zyx') - zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 - case default - Status = WRF_WARN_BAD_MEMORYORDER - ZeroLengthHorzDim = .true. - return - end select - Status = WRF_NO_ERR - ZeroLengthHorzDim = zero_length - return -end function ZeroLengthHorzDim - -subroutine ExtOrder(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(inout) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - Vector(2) = temp(3) - Vector(3) = temp(2) - case ('yxz') - Vector(1) = temp(2) - Vector(2) = temp(1) - case ('yzx') - Vector(1) = temp(3) - Vector(2) = temp(1) - Vector(3) = temp(2) - case ('zxy') - Vector(1) = temp(2) - Vector(2) = temp(3) - Vector(3) = temp(1) - case ('zyx') - Vector(1) = temp(3) - Vector(3) = temp(1) - case ('yx') - Vector(1) = temp(2) - Vector(2) = temp(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrder - -subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - character*(*),dimension(*) ,intent(in) :: Vector - character(80),dimension(NVarDims),intent(out) :: ROVector - integer ,intent(out) :: Status - integer :: NDim - character*3 :: MemOrd - - call GetDim(MemoryOrder,NDim,Status) - ROVector(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - ROVector(2) = Vector(3) - ROVector(3) = Vector(2) - case ('yxz') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case ('yzx') - ROVector(1) = Vector(3) - ROVector(2) = Vector(1) - ROVector(3) = Vector(2) - case ('zxy') - ROVector(1) = Vector(2) - ROVector(2) = Vector(3) - ROVector(3) = Vector(1) - case ('zyx') - ROVector(1) = Vector(3) - ROVector(3) = Vector(1) - case ('yx') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrderStr - - -subroutine LowerCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - integer :: i,N - - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) - enddo - return -end subroutine LowerCase - -subroutine UpperCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') - integer :: i,N - - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) - enddo - return -end subroutine UpperCase - -subroutine netcdf_err(err,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: err - integer ,intent(out) :: Status - character(len=80) :: errmsg - integer :: stat - - if( err==NF_NOERR )then - Status = WRF_NO_ERR - else - errmsg = NF_STRERROR(err) - write(msg,*) 'NetCDF error: ',errmsg - call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_WARN_NETCDF - endif - return -end subroutine netcdf_err - -subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & - ,FieldType,NCID,VarID,XField,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer,dimension(NVarDims),intent(in) :: Length - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: FieldType - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(*) ,intent(inout) :: XField - integer ,intent(out) :: Status - integer :: TimeIndex - integer :: NDim - integer,dimension(NVarDims) :: VStart - integer,dimension(NVarDims) :: VCount -! include 'wrf_io_flags.h' - - call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' Bad time index for DateStr = ',DateStr - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - VStart(:) = 1 - VCount(:) = 1 - VStart(1:NDim) = 1 - VCount(1:NDim) = Length(1:NDim) - VStart(NDim+1) = TimeIndex - VCount(NDim+1) = 1 - - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_DOUBLE) THEN - call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_INTEGER) THEN - call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_LOGICAL) THEN - call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - if(Status /= WRF_NO_ERR) return - ELSE - write(6,*) 'WARNING---- some missing calls commented out' - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - - return -end subroutine FieldIO - -subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) -!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) - integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - -#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - - case ('xzy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,k,j)) -#include "transpose.code" - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,j,k)) -#include "transpose.code" - case ('yxz') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - case ('zxy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,i,j)) -#include "transpose.code" - case ('yzx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,k,i)) -#include "transpose.code" - case ('zyx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,j,i)) -#include "transpose.code" - case ('yx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - end select - return -end subroutine Transpose - -subroutine reorder (MemoryOrder,MemO) - character*(*) ,intent(in) :: MemoryOrder - character*3 ,intent(out) :: MemO - character*3 :: MemOrd - integer :: N,i,i1,i2,i3 - - MemO = MemoryOrder - N = len_trim(MemoryOrder) - if(N == 1) return - call lowercase(MemoryOrder,MemOrd) -! never invert the boundary codes - select case ( MemOrd ) - case ( 'xsz','xez','ysz','yez' ) - return - case default - continue - end select - i1 = 1 - i3 = 1 - do i=2,N - if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i - if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i - enddo - if(N == 2) then - i2=i3 - else - i2 = 6-i1-i3 - endif - MemO(1:1) = MemoryOrder(i1:i1) - MemO(2:2) = MemoryOrder(i2:i2) - if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) - if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then - MemO(1:N-1) = MemO(2:N) - MemO(N:N ) = MemoryOrder(i1:i1) - endif - return -end subroutine reorder - -! Returns .TRUE. iff it is OK to write time-independent domain metadata to the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, first_output, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - first_output = ncd_is_first_operation( DataHandle ) - retval = .NOT. dryrun .AND. first_output - ENDIF - ncd_ok_to_put_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_put_dom_ti - -! Returns .TRUE. iff it is OK to read time-independent domain metadata from the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - retval = .NOT. dryrun - ENDIF - ncd_ok_to_get_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_get_dom_ti - -! Returns .TRUE. iff nothing has been read from or written to the file -! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. -LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) - USE wrf_data - INCLUDE 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - TYPE(wrf_data_handle) ,POINTER :: DH - INTEGER :: Status - LOGICAL :: retval - CALL GetDH( DataHandle, DH, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & - ', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - retval = DH%first_operation - ENDIF - ncd_is_first_operation = retval - RETURN -END FUNCTION ncd_is_first_operation - -subroutine upgrade_filename(FileName) - implicit none - - character*(*), intent(inout) :: FileName - integer :: i - - do i = 1, len(trim(FileName)) - if(FileName(i:i) == '-') then - FileName(i:i) = '_' - else if(FileName(i:i) == ':') then - FileName(i:i) = '_' - endif - enddo - -end subroutine upgrade_filename - -end module ext_ncd_support_routines - -subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - - use ext_ncd_support_routines - - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) - real*4 ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - -!#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - - case ('xzy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,k,j)) -#include "transpose.code" - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(i,j,k)) -#include "transpose.code" - case ('yxz') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - case ('zxy') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,i,j)) -#include "transpose.code" - case ('yzx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,k,i)) -#include "transpose.code" - case ('zyx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(k,j,i)) -#include "transpose.code" - case ('yx') -#undef DFIELD -#define DFIELD XField(1:di,XDEX(j,i,k)) -#include "transpose.code" - end select - return -end subroutine TransposeToR4 - -subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), INTENT(IN) :: DatasetName - integer , INTENT(IN) :: Comm1, Comm2 - character *(*), INTENT(IN) :: SysDepInfo - integer , INTENT(OUT) :: DataHandle - integer , INTENT(OUT) :: Status - DataHandle = 0 ! dummy setting to quiet warning message - CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) - IF ( Status .EQ. WRF_NO_ERR ) THEN - CALL ext_ncd_open_for_read_commit( DataHandle, Status ) - ENDIF - return -end subroutine ext_ncd_open_for_read - -!ends training phase; switches internal flag to enable input -!must be paired with call to ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_read_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer, intent(in) :: DataHandle - integer, intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_READ - DH%first_operation = .TRUE. - Status = WRF_NO_ERR - return -end subroutine ext_ncd_open_for_read_commit - -subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - -#ifdef USE_NETCDF4_FEATURES - integer :: open_mode -#endif - - !call upgrade_filename(FileName) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_read_begin - -subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - -#ifdef USE_NETCDF4_FEATURES - integer :: open_mode -#endif - - !call upgrade_filename(FileName) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_update - - -SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(inout) :: FileName - integer ,intent(in) :: Comm - integer ,intent(in) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - character (7) :: Buffer - integer :: VDimIDs(2) - -#ifdef USE_NETCDF4_FEATURES - integer :: create_mode - integer, parameter :: cache_size = 32, & - cache_nelem = 37, & - cache_preemption = 100 -#endif - - !call upgrade_filename(FileName) - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - DH%TimeIndex = 0 - DH%Times = ZeroDate -#ifdef USE_NETCDF4_FEATURES -! create_mode = IOR(nf_netcdf4, nf_classic_model) - if ( DH%use_netcdf_classic ) then - write(msg,*) 'output will be in classic NetCDF format' - call wrf_debug ( WARN , TRIM(msg)) -#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT - stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) -#else - stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) -#endif - else - create_mode = nf_netcdf4 - stat = NF_CREATE(FileName, create_mode, DH%NCID) - stat = NF_SET_CHUNK_CACHE(cache_size, cache_nelem, cache_preemption) - endif -#else -#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT - stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID) -#else - stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) -#endif -#endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarNames (1:MaxVars) = NO_NAME - DH%MDVarNames(1:MaxVars) = NO_NAME - do i=1,MaxDims - write(Buffer,FMT="('DIM',i4.4)") i - DH%DimNames (i) = Buffer - DH%DimLengths(i) = NO_DIM - enddo - DH%DimNames(1) = 'DateStrLen' - stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VDimIDs(1) = DH%DimIDs(1) - VDimIDs(2) = DH%DimUnlimID - stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(1) = DateStrLen - - if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then - DH%R4OnOutput = .true. - end if -!toggle on nofill mode - if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then - DH%nofill = .true. - end if - - return -end subroutine ext_ncd_open_for_write_begin - -!stub -!opens a file for writing or coupler datastream for sending messages. -!no training phase for this version of the open stmt. -subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & - SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), intent(in) ::DatasetName - integer , intent(in) ::Comm1, Comm2 - character *(*), intent(in) ::SysDepInfo - integer , intent(out) :: DataHandle - integer , intent(out) :: Status - Status=WRF_WARN_NOOP - DataHandle = 0 ! dummy setting to quiet warning message - return -end subroutine ext_ncd_open_for_write - -SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - integer :: oldmode ! for nf_set_fill, not used - - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if ( DH%nofill ) then - Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode ) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName) - call wrf_debug ( WARN , TRIM(msg)) - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - DH%first_operation = .TRUE. - return -end subroutine ext_ncd_open_for_write_commit - -subroutine ext_ncd_ioclose(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_CLOSE - write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - - stat = NF_CLOSE(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_ioclose ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - CALL deallocHandle( DataHandle, Status ) - DH%Free=.true. - return -end subroutine ext_ncd_ioclose - -subroutine ext_ncd_iosync( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_SYNC(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_iosync ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - return -end subroutine ext_ncd_iosync - - - -subroutine ext_ncd_redef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - return -end subroutine ext_ncd_redef - -subroutine ext_ncd_enddef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - return -end subroutine ext_ncd_enddef - -subroutine ext_ncd_ioinit(SysDepInfo, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - CHARACTER*(*), INTENT(IN) :: SysDepInfo - INTEGER ,INTENT(INOUT) :: Status - - WrfIOnotInitialized = .false. - WrfDataHandles(1:WrfDataHandleMax)%Free = .true. - WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' - WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' - WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED - if(trim(SysDepInfo) == "use_netcdf_classic" ) then - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true. - else - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false. - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_ioinit - - -subroutine ext_ncd_inquiry (Inquiry, Result, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - character *(*), INTENT(IN) :: Inquiry - character *(*), INTENT(OUT) :: Result - integer ,INTENT(INOUT) :: Status - SELECT CASE (Inquiry) - CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") - Result='ALLOW' - CASE ("OPEN_READ","OPEN_COMMIT_WRITE") - Result='REQUIRE' - CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") - Result='NO' - CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") - Result='YES' - CASE ("MEDIUM") - Result ='FILE' - CASE DEFAULT - Result = 'No Result for that inquiry!' - END SELECT - Status=WRF_NO_ERR - return -end subroutine ext_ncd_inquiry - - - - -subroutine ext_ncd_ioexit(Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer , INTENT(INOUT) ::Status - integer :: error - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - do i=1,WrfDataHandleMax - CALL deallocHandle( i , stat ) - enddo - return -end subroutine ext_ncd_ioexit - -subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real,intent(out) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCOunt -#define TYPE_BUFFER real,allocatable :: Buffer(:) -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_ATT_REAL -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_real - -subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_integer - -subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8,intent(out) :: Data(*) -#define TYPE_BUFFER real*8,allocatable :: Buffer(:) -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_ATT_DOUBLE -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_double - -subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 -#include "ext_ncd_get_dom_ti.code" -end subroutine ext_ncd_get_dom_ti_logical - -subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef TYPE_BUFFER -#undef NF_TYPE -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*),intent(out) :: Data -#define TYPE_COUNT -#define TYPE_OUTCOUNT -#define TYPE_BUFFER -#define NF_TYPE NF_CHAR -#define CHAR_TYPE -#include "ext_ncd_get_dom_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_dom_ti_char - -subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_REAL -#define ARGS NF_FLOAT,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_real - -subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_integer - -subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_DOUBLE -#define ARGS NF_DOUBLE,Count,Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_double - -subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(in) :: Data(*) -#define TYPE_COUNT integer,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Buffer -#define LOG -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_logical - -subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*),intent(in) :: Data -#define TYPE_COUNT integer,parameter :: Count=1 -#define NF_ROUTINE NF_PUT_ATT_TEXT -#define ARGS len_trim(Data),Data -#include "ext_ncd_put_dom_ti.code" -end subroutine ext_ncd_put_dom_ti_char - -subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_REAL -#define ARGS NF_FLOAT,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_real - -subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_REAL -#define NF_TYPE NF_FLOAT -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_real - -subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_DOUBLE -#define ARGS NF_DOUBLE,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_double - -subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_DOUBLE -#define NF_TYPE NF_DOUBLE -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_double - -subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define ARGS NF_INT,Count,Data -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_integer - -subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_INT -#define NF_TYPE NF_INT -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_integer - -subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_ATT_INT -#define LOG -#define ARGS NF_INT,Count,Buffer -#include "ext_ncd_put_var_ti.code" -end subroutine ext_ncd_put_var_ti_logical - -subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical ,intent(in) :: Data(*) -#define TYPE_COUNT integer ,intent(in) :: Count -#define NF_ROUTINE NF_PUT_VARA_INT -#define NF_TYPE NF_INT -#define LOG -#define LENGTH Count -#define ARG -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_logical - -subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef ARGS -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(in) :: Data -#define TYPE_COUNT -#define NF_ROUTINE NF_PUT_ATT_TEXT -#define ARGS len_trim(Data),trim(Data) -#define CHAR_TYPE -#include "ext_ncd_put_var_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_put_var_ti_char - -subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_COUNT -#undef NF_ROUTINE -#undef NF_TYPE -#undef LENGTH -#undef ARG -#undef LOG -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(in) :: Data -#define TYPE_COUNT -#define NF_ROUTINE NF_PUT_VARA_TEXT -#define NF_TYPE NF_CHAR -#define LENGTH len(Data) -#include "ext_ncd_put_var_td.code" -end subroutine ext_ncd_put_var_td_char - -subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(out) :: Data(*) -#define TYPE_BUFFER real ,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_ATT_REAL -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_real - -subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'REAL' -#define TYPE_DATA real ,intent(out) :: Data(*) -#define TYPE_BUFFER real -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_FLOAT -#define NF_ROUTINE NF_GET_VARA_REAL -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_real - -subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(out) :: Data(*) -#define TYPE_BUFFER real*8 ,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_ATT_DOUBLE -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_double - -subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'DOUBLE' -#define TYPE_DATA real*8 ,intent(out) :: Data(*) -#define TYPE_BUFFER real*8 -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_DOUBLE -#define NF_ROUTINE NF_GET_VARA_DOUBLE -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_double - -subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_integer - -subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'INTEGER' -#define TYPE_DATA integer,intent(out) :: Data(*) -#define TYPE_BUFFER integer -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_VARA_INT -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_integer - -subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer,allocatable :: Buffer(:) -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_ATT_INT -#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 -#include "ext_ncd_get_var_ti.code" -end subroutine ext_ncd_get_var_ti_logical - -subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#undef COPY -#define ROUTINE_TYPE 'LOGICAL' -#define TYPE_DATA logical,intent(out) :: Data(*) -#define TYPE_BUFFER integer -#define TYPE_COUNT integer,intent(in) :: Count -#define TYPE_OUTCOUNT integer,intent(out) :: OutCount -#define NF_TYPE NF_INT -#define NF_ROUTINE NF_GET_VARA_INT -#define LENGTH min(Count,Len1) -#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 -#include "ext_ncd_get_var_td.code" -end subroutine ext_ncd_get_var_td_logical - -subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef COPY -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(out) :: Data -#define TYPE_BUFFER -#define TYPE_COUNT integer :: Count = 1 -#define TYPE_OUTCOUNT -#define NF_TYPE NF_CHAR -#define NF_ROUTINE NF_GET_ATT_TEXT -#define COPY -#define CHAR_TYPE -#include "ext_ncd_get_var_ti.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_var_ti_char - -subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -#undef ROUTINE_TYPE -#undef TYPE_DATA -#undef TYPE_BUFFER -#undef TYPE_COUNT -#undef TYPE_OUTCOUNT -#undef NF_TYPE -#undef NF_ROUTINE -#undef LENGTH -#define ROUTINE_TYPE 'CHAR' -#define TYPE_DATA character*(*) ,intent(out) :: Data -#define TYPE_BUFFER character (80) -#define TYPE_COUNT integer :: Count = 1 -#define TYPE_OUTCOUNT -#define NF_TYPE NF_CHAR -#define NF_ROUTINE NF_GET_VARA_TEXT -#define LENGTH Len1 -#define CHAR_TYPE -#include "ext_ncd_get_var_td.code" -#undef CHAR_TYPE -end subroutine ext_ncd_get_var_td_char - -subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_real - -subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_integer - -subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_double - -subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_logical - -subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Data - integer ,intent(out) :: Status - - call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_put_dom_td_char - -subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_real - -subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_integer - -subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_double - -subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_logical - -subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(out) :: Data - integer ,intent(out) :: Status - call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_get_dom_td_char - -subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, & - Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(inout) :: Field(*) - integer ,intent(in) :: FieldTypeIn - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) ,dimension(*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - integer :: FieldType - character (3) :: MemoryOrder - type(wrf_data_handle) ,pointer :: DH - integer :: NCID - integer :: NDim - character (VarNameLen) :: VarName - character (3) :: MemO - character (3) :: UCMemO - integer :: VarID - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - character(80),dimension(NVarDims) :: RODimNames - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(:,:,:,:),allocatable :: XField - integer :: stat - integer :: NVar - integer :: i,j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - integer :: XType - integer :: di - character (80) :: NullName - logical :: NotFound - -#ifdef USE_NETCDF4_FEATURES - integer, parameter :: cache_size = 32000000 - integer,dimension(NVarDims) :: chunks - logical :: need_chunking - integer :: compression_level - integer :: block_size -#endif - - MemoryOrder = trim(adjustl(MemoryOrdIn)) - NullName=char(0) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NCID = DH%NCID - -#ifdef USE_NETCDF4_FEATURES -if ( .not. DH%use_netcdf_classic ) then - call set_chunking(MemoryOrder,need_chunking) - compression_level = 2 -else - need_chunking = .false. -endif -#endif - - if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then - FieldType = WRF_REAL - else - FieldType = FieldTypeIn - end if - - write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) - -!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - - IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN - write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring' - call wrf_debug ( WARN , TRIM(msg)) - return - ENDIF - - call ExtOrder(MemoryOrder,Length,Status) - call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(DH%VarNames(NVar) == VarName ) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%VarNames(NVar) == NO_NAME) then - DH%VarNames(NVar) = VarName - DH%NumVars = NVar - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - do j = 1,NDim - if(RODimNames(j) == NullName .or. RODimNames(j) == '') then - do i=1,MaxDims - if(DH%DimLengths(i) == Length(j)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else !look for input name and check if already defined - NotFound = .true. - do i=1,MaxDims - if (DH%DimNames(i) == RODimNames(j)) then - if (DH%DimLengths(i) == Length(j)) then - NotFound = .false. - exit - else - Status = WRF_WARN_DIMNAME_REDEFINED - write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & - TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - enddo - if (NotFound) then - do i=1,MaxDims - if (DH%DimLengths(i) == NO_DIM) then - DH%DimNames(i) = RODimNames(j) - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - endif - VDimIDs(j) = DH%DimIDs(i) - DH%VarDimLens(j,NVar) = Length(j) - enddo - VDimIDs(NDim+1) = DH%DimUnlimID - - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - XType = NF_FLOAT - ELSE IF (FieldType == WRF_DOUBLE) THEN - Xtype = NF_DOUBLE - ELSE IF (FieldType == WRF_INTEGER) THEN - XType = NF_INT - ELSE IF (FieldType == WRF_LOGICAL) THEN - XType = NF_INT - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - - stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - -#ifdef USE_NETCDF4_FEATURES - if(need_chunking) then - chunks(1:NDim) = Length(1:NDim) - chunks(NDim+1) = 1 - chunks(1) = (Length(1) + 1)/2 - chunks(2) = (Length(2) + 1)/2 - - block_size = 1 - do i = 1, NDim - block_size = block_size * chunks(i) - end do - - do while (block_size > cache_size) - chunks(1) = (chunks(1) + 1)/2 - chunks(2) = (chunks(2) + 1)/2 - - block_size = 1 - do i = 1, NDim - block_size = block_size * chunks(i) - end do - end do - -! write(unit=0, fmt='(2x, 3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ -! write(unit=0, fmt='(2x, 3a)') TRIM(VarName),':' -! write(unit=0, fmt='(10x, 2(a,i6))') 'length 1 = ', Length(1), ', chunk 1 = ', chunks(1) -! write(unit=0, fmt='(10x, 2(a,i6))') 'length 2 = ', Length(2), ', chunk 2 = ', chunks(2) -! write(unit=0, fmt='(10x, 2(a,i6))') 'length NDim+1 = ', Length(NDim+1), ', chunk NDim+1 = ', chunks(NDim+1) -! write(unit=0, fmt='(10x, a,i6)') 'compression_level = ', compression_level - - stat = NF_DEF_VAR_CHUNKING(NCID, VarID, NF_CHUNKED, chunks(1:NDim+1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF def chunking error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - stat = NF_DEF_VAR_DEFLATE(NCID, VarID, 1, 1, compression_level) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF def compression error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif -#endif - - DH%VarIDs(NVar) = VarID - stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call reorder(MemoryOrder,MemO) - call uppercase(MemO,UCMemO) - stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - VarID = DH%VarIDs(NVar) - do j=1,NDim - if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then - Status = WRF_WARN_WRTLEN_NE_DRRUNLEN - write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & - VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) - call wrf_debug ( WARN , TRIM(msg)) - return -!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then - elseif(PatchStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & - '| in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) - call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then - call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - else - call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - end if - call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , TRIM(msg)) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_write_field - -subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & - IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(out) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - character (3) :: MemoryOrder - character (NF_MAX_NAME) :: dimname - type(wrf_data_handle) ,pointer :: DH - integer :: NDim - integer :: NCID - character (VarNameLen) :: VarName - integer :: VarID - integer ,dimension(NVarDims) :: VCount - integer ,dimension(NVarDims) :: VStart - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - integer ,dimension(NVarDims) :: MemS - integer ,dimension(NVarDims) :: MemE - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(NVarDims) :: StoredLen - integer ,dimension(:,:,:,:) ,allocatable :: XField - integer :: NVar - integer :: j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - character (VarNameLen) :: Name - integer :: XType - integer :: StoredDim - integer :: NAtts - integer :: Len - integer :: stat - integer :: di - integer :: FType - - MemoryOrder = trim(adjustl(MemoryOrdIn)) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & - TRIM(Var),'| in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & - '| in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. -! Status = WRF_WARN_DRYRUN_READ -! write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ -! call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_NO_ERR - RETURN - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - NCID = DH%NCID - -!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - call ExtOrder(MemoryOrder,Length,Status) - stat = NF_INQ_VARID(NCID,VarName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif -! allow coercion between double and single prec real -!jm if(FieldType /= Ftype) then - if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then - if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else if(FieldType /= Ftype) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE IF (FieldType == WRF_DOUBLE) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE IF (FieldType == WRF_INTEGER) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE IF (FieldType == WRF_LOGICAL) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ - endif - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - END IF - - if(Status /= WRF_NO_ERR) then - call wrf_debug ( WARN , TRIM(msg)) - return - endif - ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 - IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN - stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - IF ( dimname(1:10) == 'ext_scalar' ) THEN - NDim = 1 - Length(1) = 1 - ENDIF - ENDIF - if(StoredDim /= NDim+1) then - Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM - write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) - call wrf_debug ( FATAL , msg) - write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 - call wrf_debug ( FATAL , msg) - return - endif - do j=1,NDim - stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(Length(j) > StoredLen(j)) then - Status = WRF_WARN_READ_PAST_EOF - write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Length(j) <= 0) then - Status = WRF_WARN_ZERO_LENGTH_READ - write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DomainStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & - ') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) -! return - endif - enddo - - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) -!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) - call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) - - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_read_field - -subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(inout) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - !call upgrade_filename(FileName) - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - FileStatus = WRF_FILE_NOT_OPENED - return - endif - if(trim(FileName) /= trim(DH%FileName)) then - FileStatus = WRF_FILE_NOT_OPENED - else - FileStatus = DH%FileStatus - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_opened - -subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - FileStatus = WRF_FILE_NOT_OPENED - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - FileName = trim(DH%FileName) - FileStatus = DH%FileStatus - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_filename - -subroutine ext_ncd_set_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: i - - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - DH%CurrentTime = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - return - endif - enddo - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_set_time - -subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - if(DH%CurrentTime >= DH%NumberTimes) then - Status = WRF_WARN_TIME_EOF - return - endif - DH%CurrentTime = DH%CurrentTime +1 - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'DH%FileStatus ',DH%FileStatus - call wrf_debug ( FATAL , msg) - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_time - -subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - if(DH%CurrentTime.GT.0) then - DH%CurrentTime = DH%CurrentTime -1 - endif - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_previous_time - -subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: VarName - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - character (80) :: Name - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - - DH%CurrentVariable = DH%CurrentVariable +1 - if(DH%CurrentVariable > DH%NumVars) then - Status = WRF_WARN_VAR_EOF - return - endif - VarName = DH%VarNames(DH%CurrentVariable) - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_var - -subroutine ext_ncd_end_of_frame(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - - call GetDH(DataHandle,DH,Status) - return -end subroutine ext_ncd_end_of_frame - -! NOTE: For scalar variables NDim is set to zero and DomainStart and -! NOTE: DomainEnd are left unmodified. -subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Name - integer ,intent(out) :: NDim - character*(*) ,intent(out) :: MemoryOrder - character*(*) :: Stagger ! Dummy for now - integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd - integer ,intent(out) :: WrfType - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VarID - integer ,dimension(NVarDims) :: VDimIDs - integer :: j - integer :: stat - integer :: XType - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_INQ_VARID(DH%NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - select case (XType) - case (NF_BYTE) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_CHAR) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_SHORT) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_INT) - if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_FLOAT) - if(WrfType /= WRF_REAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_DOUBLE) - if(WrfType /= WRF_DOUBLE) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - end select - - stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - do j = 1, NDim - DomainStart(j) = 1 - stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_info - -subroutine ext_ncd_warning_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - - SELECT CASE (Code) - CASE (0) - ReturnString='No error' - Status=WRF_NO_ERR - return - CASE (-1) - ReturnString= 'File not found (or file is incomplete)' - Status=WRF_NO_ERR - return - CASE (-2) - ReturnString='Metadata not found' - Status=WRF_NO_ERR - return - CASE (-3) - ReturnString= 'Timestamp not found' - Status=WRF_NO_ERR - return - CASE (-4) - ReturnString= 'No more timestamps' - Status=WRF_NO_ERR - return - CASE (-5) - ReturnString= 'Variable not found' - Status=WRF_NO_ERR - return - CASE (-6) - ReturnString= 'No more variables for the current time' - Status=WRF_NO_ERR - return - CASE (-7) - ReturnString= 'Too many open files' - Status=WRF_NO_ERR - return - CASE (-8) - ReturnString= 'Data type mismatch' - Status=WRF_NO_ERR - return - CASE (-9) - ReturnString= 'Attempt to write read-only file' - Status=WRF_NO_ERR - return - CASE (-10) - ReturnString= 'Attempt to read write-only file' - Status=WRF_NO_ERR - return - CASE (-11) - ReturnString= 'Attempt to access unopened file' - Status=WRF_NO_ERR - return - CASE (-12) - ReturnString= 'Attempt to do 2 trainings for 1 variable' - Status=WRF_NO_ERR - return - CASE (-13) - ReturnString= 'Attempt to read past EOF' - Status=WRF_NO_ERR - return - CASE (-14) - ReturnString= 'Bad data handle' - Status=WRF_NO_ERR - return - CASE (-15) - ReturnString= 'Write length not equal to training length' - Status=WRF_NO_ERR - return - CASE (-16) - ReturnString= 'More dimensions requested than training' - Status=WRF_NO_ERR - return - CASE (-17) - ReturnString= 'Attempt to read more data than exists' - Status=WRF_NO_ERR - return - CASE (-18) - ReturnString= 'Input dimensions inconsistent' - Status=WRF_NO_ERR - return - CASE (-19) - ReturnString= 'Input MemoryOrder not recognized' - Status=WRF_NO_ERR - return - CASE (-20) - ReturnString= 'A dimension name with 2 different lengths' - Status=WRF_NO_ERR - return - CASE (-21) - ReturnString= 'String longer than provided storage' - Status=WRF_NO_ERR - return - CASE (-22) - ReturnString= 'Function not supportable' - Status=WRF_NO_ERR - return - CASE (-23) - ReturnString= 'Package implements this routine as NOOP' - Status=WRF_NO_ERR - return - -!netcdf-specific warning messages - CASE (-1007) - ReturnString= 'Bad data type' - Status=WRF_NO_ERR - return - CASE (-1008) - ReturnString= 'File not committed' - Status=WRF_NO_ERR - return - CASE (-1009) - ReturnString= 'File is opened for reading' - Status=WRF_NO_ERR - return - CASE (-1011) - ReturnString= 'Attempt to write metadata after open commit' - Status=WRF_NO_ERR - return - CASE (-1010) - ReturnString= 'I/O not initialized' - Status=WRF_NO_ERR - return - CASE (-1012) - ReturnString= 'Too many variables requested' - Status=WRF_NO_ERR - return - CASE (-1013) - ReturnString= 'Attempt to close file during a dry run' - Status=WRF_NO_ERR - return - CASE (-1014) - ReturnString= 'Date string not 19 characters in length' - Status=WRF_NO_ERR - return - CASE (-1015) - ReturnString= 'Attempt to read zero length words' - Status=WRF_NO_ERR - return - CASE (-1016) - ReturnString= 'Data type not found' - Status=WRF_NO_ERR - return - CASE (-1017) - ReturnString= 'Badly formatted date string' - Status=WRF_NO_ERR - return - CASE (-1018) - ReturnString= 'Attempt at read during a dry run' - Status=WRF_NO_ERR - return - CASE (-1019) - ReturnString= 'Attempt to get zero words' - Status=WRF_NO_ERR - return - CASE (-1020) - ReturnString= 'Attempt to put zero length words' - Status=WRF_NO_ERR - return - CASE (-1021) - ReturnString= 'NetCDF error' - Status=WRF_NO_ERR - return - CASE (-1022) - ReturnString= 'Requested length <= 1' - Status=WRF_NO_ERR - return - CASE (-1023) - ReturnString= 'More data available than requested' - Status=WRF_NO_ERR - return - CASE (-1024) - ReturnString= 'New date less than previous date' - Status=WRF_NO_ERR - return - - CASE DEFAULT - ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this warning code.' - Status=WRF_NO_ERR - END SELECT - - return -end subroutine ext_ncd_warning_str - -!returns message string for all WRF and netCDF warning/error status codes -!Other i/o packages must provide their own routines to return their own status messages -subroutine ext_ncd_error_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - - SELECT CASE (Code) - CASE (-100) - ReturnString= 'Allocation Error' - Status=WRF_NO_ERR - return - CASE (-101) - ReturnString= 'Deallocation Error' - Status=WRF_NO_ERR - return - CASE (-102) - ReturnString= 'Bad File Status' - Status=WRF_NO_ERR - return - CASE (-1004) - ReturnString= 'Variable on disk is not 3D' - Status=WRF_NO_ERR - return - CASE (-1005) - ReturnString= 'Metadata on disk is not 1D' - Status=WRF_NO_ERR - return - CASE (-1006) - ReturnString= 'Time dimension too small' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this error code.' - Status=WRF_NO_ERR - END SELECT - - return -end subroutine ext_ncd_error_str diff --git a/src/wrflib/wrf_io.f90 b/src/wrflib/wrf_io.f90 deleted file mode 100644 index 278249138e..0000000000 --- a/src/wrflib/wrf_io.f90 +++ /dev/null @@ -1,8169 +0,0 @@ -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - -module wrf_data - - integer , parameter :: FATAL = 1 - integer , parameter :: WARN = 1 - integer , parameter :: WrfDataHandleMax = 99 - integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS - - - - integer , parameter :: MaxVars = 3000 - - integer , parameter :: MaxTimes = 10000 - integer , parameter :: DateStrLen = 19 - integer , parameter :: VarNameLen = 31 - integer , parameter :: NO_DIM = 0 - integer , parameter :: NVarDims = 4 - integer , parameter :: NMDVarDims = 2 - character (8) , parameter :: NO_NAME = 'NULL' - character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' - integer, parameter :: WRF_FILE_NOT_OPENED = 100 - integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 - integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 - integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 - integer, parameter :: WRF_REAL = 104 - integer, parameter :: WRF_DOUBLE = 105 - integer, parameter :: WRF_FLOAT=WRF_REAL - integer, parameter :: WRF_INTEGER = 106 - integer, parameter :: WRF_LOGICAL = 107 - integer, parameter :: WRF_COMPLEX = 108 - integer, parameter :: WRF_DOUBLE_COMPLEX = 109 - integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 -! This bit is for backwards compatibility with old variants of these flags -! that are still being used in io_grib1 and io_phdf5. It should be removed! - integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 - character (256) :: msg - logical :: WrfIOnotInitialized = .true. - type :: wrf_data_handle - character (255) :: FileName - integer :: FileStatus - integer :: Comm - integer :: NCID - logical :: Free - logical :: Write - character (5) :: TimesName - integer :: TimeIndex - integer :: CurrentTime !Only used for read - integer :: NumberTimes !Only used for read - character (DateStrLen), pointer :: Times(:) - integer :: TimesVarID - integer , pointer :: DimLengths(:) - integer , pointer :: DimIDs(:) - character (31) , pointer :: DimNames(:) - integer :: DimUnlimID - character (9) :: DimUnlimName - integer , dimension(NVarDims) :: DimID - integer , dimension(NVarDims) :: Dimension - integer , pointer :: MDVarIDs(:) - integer , pointer :: MDVarDimLens(:) - character (80) , pointer :: MDVarNames(:) - integer , pointer :: VarIDs(:) - integer , pointer :: VarDimLens(:,:) - character (VarNameLen), pointer :: VarNames(:) - integer :: CurrentVariable !Only used for read - integer :: NumVars -! first_operation is set to .TRUE. when a new handle is allocated -! or when open-for-write or open-for-read are committed. It is set -! to .FALSE. when the first field is read or written. - logical :: first_operation - logical :: R4OnOutput - logical :: nofill - logical :: use_netcdf_classic - end type wrf_data_handle - type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) -end module wrf_data -module ext_ncd_support_routines - implicit none -CONTAINS -subroutine allocHandle(DataHandle,DH,Comm,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(out) :: DataHandle - type(wrf_data_handle),pointer :: DH - integer ,intent(IN) :: Comm - integer ,intent(out) :: Status - integer :: i - integer :: stat - do i=1,WrfDataHandleMax - if(WrfDataHandles(i)%Free) then - DH => WrfDataHandles(i) - DataHandle = i - allocate(DH%Times(MaxTimes), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 124 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimLengths(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 131 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimIDs(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%DimNames(MaxDims), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 145 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarDimLens(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 159 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%MDVarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 166 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarIDs(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 173 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - allocate(DH%VarNames(MaxVars), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 187 - call wrf_debug ( FATAL , msg) - return - endif - exit - endif - if(i==WrfDataHandleMax) then - Status = WRF_WARN_TOO_MANY_FILES - write(msg,*) 'Warning TOO MANY FILES in ',"wrf_io.F90",', line', 195 - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) 'Did you call ext_ncd_ioinit?' - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - DH%Free =.false. - DH%Comm = Comm - DH%Write =.false. - DH%first_operation = .TRUE. - DH%R4OnOutput = .false. - DH%nofill = .false. - Status = WRF_NO_ERR -end subroutine allocHandle -subroutine deallocHandle(DataHandle, Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN - if(.NOT. WrfDataHandles(DataHandle)%Free) then - DH => WrfDataHandles(DataHandle) - deallocate(DH%Times, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 226 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimLengths, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 233 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 240 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%DimNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 247 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 254 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 261 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%MDVarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 268 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarIDs, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 275 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarDimLens, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 282 - call wrf_debug ( FATAL , msg) - return - endif - deallocate(DH%VarNames, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 289 - call wrf_debug ( FATAL , msg) - return - endif - DH%Free =.TRUE. - endif - ENDIF - Status = WRF_NO_ERR -end subroutine deallocHandle -subroutine GetDH(DataHandle,DH,Status) - use wrf_data - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - type(wrf_data_handle) ,pointer :: DH - integer ,intent(out) :: Status - if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - DH => WrfDataHandles(DataHandle) - if(DH%Free) then - Status = WRF_WARN_BAD_DATA_HANDLE - return - endif - Status = WRF_NO_ERR - return -end subroutine GetDH -subroutine DateCheck(Date,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Date - integer ,intent(out) :: Status - if(len(Date) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - else - Status = WRF_NO_ERR - endif - return -end subroutine DateCheck - -subroutine GetName(Element,Var,Name,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Name - integer ,intent(out) :: Status - character (VarNameLen) :: VarName - character (1) :: c - integer :: i - integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - - VarName = Var - Name = 'MD___' - do i=1,len(Name) - c=Name(i:i) - if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) - if(c=='-'.or.c==':') Name(i:i)='_' - enddo - Status = WRF_NO_ERR - return -end subroutine GetName - -subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: TimeIndex - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VStart(2) - integer :: VCount(2) - integer :: stat - integer :: i - - DH => WrfDataHandles(DataHandle) - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - Status = WRF_WARN_DATESTR_ERROR - write(msg,*) 'Warning DATE STRING ERROR in ',"wrf_io.F90",', line', 375 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(IO == 'write') then - TimeIndex = DH%TimeIndex - if(TimeIndex <= 0) then - TimeIndex = 1 - elseif(DateStr == DH%Times(TimeIndex)) then - Status = WRF_NO_ERR - return - else - TimeIndex = TimeIndex +1 - if(TimeIndex > MaxTimes) then - Status = WRF_WARN_TIME_EOF - write(msg,*) 'Warning TIME EOF in ',"wrf_io.F90",', line', 390 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - DH%TimeIndex = TimeIndex - DH%Times(TimeIndex) = DateStr - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = DateStrLen - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 404 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - Status = WRF_NO_ERR - TimeIndex = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"wrf_io.F90",', line', 417 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - return -end subroutine GetTimeIndex - -subroutine GetDim(MemoryOrder,NDim,Status) - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(out) :: NDim - integer ,intent(out) :: Status - character*3 :: MemOrd - - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') - NDim = 3 - case ('xy','yx','xs','xe','ys','ye','cc') - NDim = 2 - case ('z','c') - NDim = 1 - case ('0') ! NDim=0 for scalars. TBH: 20060502 - NDim = 0 - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine GetDim -subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) - integer ,intent(in) :: NDim - integer ,dimension(*),intent(in) :: Start,End - integer ,intent(out) :: i1,i2,j1,j2,k1,k2 - i1=1 - i2=1 - j1=1 - j2=1 - k1=1 - k2=1 - if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 - i1 = Start(1) - i2 = End (1) - if(NDim == 1) return - j1 = Start(2) - j2 = End (2) - if(NDim == 2) return - k1 = Start(3) - k2 = End (3) - return -end subroutine GetIndices -logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(in) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - logical zero_length - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - zero_length = .false. - select case (MemOrd) - case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy','yzx') - zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 - case ('xy','yx','xyz','yxz') - zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 - case ('zxy','zyx') - zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 - case default - Status = WRF_WARN_BAD_MEMORYORDER - ZeroLengthHorzDim = .true. - return - end select - Status = WRF_NO_ERR - ZeroLengthHorzDim = zero_length - return -end function ZeroLengthHorzDim -subroutine ExtOrder(MemoryOrder,Vector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - integer,dimension(*) ,intent(inout) :: Vector - integer ,intent(out) :: Status - integer :: NDim - integer,dimension(NVarDims) :: temp - character*3 :: MemOrd - call GetDim(MemoryOrder,NDim,Status) - temp(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - Vector(2) = temp(3) - Vector(3) = temp(2) - case ('yxz') - Vector(1) = temp(2) - Vector(2) = temp(1) - case ('yzx') - Vector(1) = temp(3) - Vector(2) = temp(1) - Vector(3) = temp(2) - case ('zxy') - Vector(1) = temp(2) - Vector(2) = temp(3) - Vector(3) = temp(1) - case ('zyx') - Vector(1) = temp(3) - Vector(3) = temp(1) - case ('yx') - Vector(1) = temp(2) - Vector(2) = temp(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrder -subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) - use wrf_data - include 'wrf_status_codes.h' - character*(*) ,intent(in) :: MemoryOrder - character*(*),dimension(*) ,intent(in) :: Vector - character(80),dimension(NVarDims),intent(out) :: ROVector - integer ,intent(out) :: Status - integer :: NDim - character*3 :: MemOrd - call GetDim(MemoryOrder,NDim,Status) - ROVector(1:NDim) = Vector(1:NDim) - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') - continue - case ('0') - continue ! NDim=0 for scalars. TBH: 20060502 - case ('xzy') - ROVector(2) = Vector(3) - ROVector(3) = Vector(2) - case ('yxz') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case ('yzx') - ROVector(1) = Vector(3) - ROVector(2) = Vector(1) - ROVector(3) = Vector(2) - case ('zxy') - ROVector(1) = Vector(2) - ROVector(2) = Vector(3) - ROVector(3) = Vector(1) - case ('zyx') - ROVector(1) = Vector(3) - ROVector(3) = Vector(1) - case ('yx') - ROVector(1) = Vector(2) - ROVector(2) = Vector(1) - case default - Status = WRF_WARN_BAD_MEMORYORDER - return - end select - Status = WRF_NO_ERR - return -end subroutine ExtOrderStr -subroutine LowerCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') - integer :: i,N - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) - enddo - return -end subroutine LowerCase -subroutine UpperCase(MemoryOrder,MemOrd) - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(out) :: MemOrd - character*1 :: c - integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') - integer :: i,N - MemOrd = ' ' - N = len(MemoryOrder) - MemOrd(1:N) = MemoryOrder(1:N) - do i=1,N - c = MemoryOrder(i:i) - if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) - enddo - return -end subroutine UpperCase -subroutine netcdf_err(err,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: err - integer ,intent(out) :: Status - character(len=80) :: errmsg - integer :: stat - if( err==NF_NOERR )then - Status = WRF_NO_ERR - else - errmsg = NF_STRERROR(err) - write(msg,*) 'NetCDF error: ',errmsg - call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_WARN_NETCDF - endif - return -end subroutine netcdf_err -subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder & - ,FieldType,NCID,VarID,XField,Status) - use wrf_data - include 'wrf_status_codes.h' - include 'netcdf.inc' - character (*) ,intent(in) :: IO - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer,dimension(NVarDims),intent(in) :: Length - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: FieldType - integer ,intent(in) :: NCID - integer ,intent(in) :: VarID - integer,dimension(*) ,intent(inout) :: XField - integer ,intent(out) :: Status - integer :: TimeIndex - integer :: NDim - integer,dimension(NVarDims) :: VStart - integer,dimension(NVarDims) :: VCount -! include 'wrf_io_flags.h' - call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning in ',"wrf_io.F90",', line', 704 - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' Bad time index for DateStr = ',DateStr - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - VStart(:) = 1 - VCount(:) = 1 - VStart(1:NDim) = 1 - VCount(1:NDim) = Length(1:NDim) - VStart(NDim+1) = TimeIndex - VCount(NDim+1) = 1 - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_DOUBLE) THEN - call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_INTEGER) THEN - call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - ELSE IF (FieldType == WRF_LOGICAL) THEN - call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) - if(Status /= WRF_NO_ERR) return - ELSE - write(6,*) 'WARNING---- some missing calls commented out' - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 731 - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - return -end subroutine FieldIO -subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) -!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2) - integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - case ('xzy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yxz') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zxy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yzx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zyx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - end select - return -end subroutine Transpose -subroutine reorder (MemoryOrder,MemO) - character*(*) ,intent(in) :: MemoryOrder - character*3 ,intent(out) :: MemO - character*3 :: MemOrd - integer :: N,i,i1,i2,i3 - MemO = MemoryOrder - N = len_trim(MemoryOrder) - if(N == 1) return - call lowercase(MemoryOrder,MemOrd) -! never invert the boundary codes - select case ( MemOrd ) - case ( 'xsz','xez','ysz','yez' ) - return - case default - continue - end select - i1 = 1 - i3 = 1 - do i=2,N - if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i - if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i - enddo - if(N == 2) then - i2=i3 - else - i2 = 6-i1-i3 - endif - MemO(1:1) = MemoryOrder(i1:i1) - MemO(2:2) = MemoryOrder(i2:i2) - if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) - if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then - MemO(1:N-1) = MemO(2:N) - MemO(N:N ) = MemoryOrder(i1:i1) - endif - return -end subroutine reorder -! Returns .TRUE. iff it is OK to write time-independent domain metadata to the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, first_output, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & - ', line', 846 - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - first_output = ncd_is_first_operation( DataHandle ) - retval = .NOT. dryrun .AND. first_output - ENDIF - ncd_ok_to_put_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_put_dom_ti -! Returns .TRUE. iff it is OK to read time-independent domain metadata from the -! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is -! returned. -LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) - USE wrf_data - include 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - CHARACTER*80 :: fname - INTEGER :: filestate - INTEGER :: Status - LOGICAL :: dryrun, retval - call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & - ', line', 872 - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) - retval = .NOT. dryrun - ENDIF - ncd_ok_to_get_dom_ti = retval - RETURN -END FUNCTION ncd_ok_to_get_dom_ti -! Returns .TRUE. iff nothing has been read from or written to the file -! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned. -LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) - USE wrf_data - INCLUDE 'wrf_status_codes.h' - INTEGER, INTENT(IN) :: DataHandle - TYPE(wrf_data_handle) ,POINTER :: DH - INTEGER :: Status - LOGICAL :: retval - CALL GetDH( DataHandle, DH, Status ) - IF ( Status /= WRF_NO_ERR ) THEN - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90", & - ', line', 895 - call wrf_debug ( WARN , TRIM(msg) ) - retval = .FALSE. - ELSE - retval = DH%first_operation - ENDIF - ncd_is_first_operation = retval - RETURN -END FUNCTION ncd_is_first_operation -subroutine upgrade_filename(FileName) - implicit none - character*(*), intent(inout) :: FileName - integer :: i - do i = 1, len(trim(FileName)) - if(FileName(i:i) == '-') then - FileName(i:i) = '_' - else if(FileName(i:i) == ':') then - FileName(i:i) = '_' - endif - enddo -end subroutine upgrade_filename -end module ext_ncd_support_routines -subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - use ext_ncd_support_routines - character*(*) ,intent(in) :: IO - character*(*) ,intent(in) :: MemoryOrder - integer ,intent(in) :: l1,l2,m1,m2,n1,n2 - integer ,intent(in) :: di - integer ,intent(in) :: x1,x2,y1,y2,z1,z2 - integer ,intent(in) :: i1,i2,j1,j2,k1,k2 - real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2) - real*4 ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1)) - character*3 :: MemOrd - character*3 :: MemO - integer ,parameter :: MaxUpperCase=IACHAR('Z') - integer :: i,j,k,ix,jx,kx - call LowerCase(MemoryOrder,MemOrd) - select case (MemOrd) -!#define A-A1+1+(A2-A1+1)*((B-B1)+(C-C1)*(B2-B1+1)) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) -! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) - case ('xzy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yxz') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zxy') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yzx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('zyx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - case ('yx') - ix=0 - jx=0 - kx=0 - call reorder(MemoryOrder,MemO) - if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1 - if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1 - if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1 -! pjj/cray - if(IO == 'write') then -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) - enddo - enddo - enddo -!$OMP END PARALLEL DO -else -!!dir$ concurrent -!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) - do k=k1,k2 - do j=j1,j2 -!!dir$ prefervector -!!dir$ concurrent -!cdir select(vector) - do i=i1,i2 - Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))) - enddo - enddo - enddo -!$OMP END PARALLEL DO -endif - return - end select - return -end subroutine TransposeToR4 -subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), INTENT(IN) :: DatasetName - integer , INTENT(IN) :: Comm1, Comm2 - character *(*), INTENT(IN) :: SysDepInfo - integer , INTENT(OUT) :: DataHandle - integer , INTENT(OUT) :: Status - DataHandle = 0 ! dummy setting to quiet warning message - CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) - IF ( Status .EQ. WRF_NO_ERR ) THEN - CALL ext_ncd_open_for_read_commit( DataHandle, Status ) - ENDIF - return -end subroutine ext_ncd_open_for_read -!ends training phase; switches internal flag to enable input -!must be paired with call to ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_read_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer, intent(in) :: DataHandle - integer, intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1013 - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1019 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_READ - DH%first_operation = .TRUE. - Status = WRF_NO_ERR - return -end subroutine ext_ncd_open_for_read_commit -subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - !call upgrade_filename(FileName) - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1064 - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 1070 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1078 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1085 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1092 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 1098 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1105 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',"wrf_io.F90",', line', 1111 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1118 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',"wrf_io.F90",', line', 1124 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1133 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1140 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1149 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_read_begin -subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(INOUT) :: FileName - integer ,intent(IN) :: Comm - integer ,intent(IN) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: VarID - integer :: StoredDim - integer :: NAtts - integer :: DimIDs(2) - integer :: VStart(2) - integer :: VLen(2) - integer :: TotalNumVars - integer :: NumVars - integer :: i - character (NF_MAX_NAME) :: Name - !call upgrade_filename(FileName) - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1204 - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 1210 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_OPEN(FileName, NF_WRITE, DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1217 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1224 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1231 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 1237 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1244 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(1) /= DateStrLen) then - Status = WRF_WARN_DATESTR_BAD_LENGTH - write(msg,*) 'Warning DATESTR BAD LENGTH in ',"wrf_io.F90",', line', 1250 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1257 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(VLen(2) > MaxTimes) then - Status = WRF_ERR_FATAL_TOO_MANY_TIMES - write(msg,*) 'Fatal TOO MANY TIME VALUES in ',"wrf_io.F90",', line', 1263 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - VStart(1) = 1 - VStart(2) = 1 - stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1272 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_NVARS(DH%NCID,TotalNumVars) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1279 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NumVars = 0 - do i=1,TotalNumVars - stat = NF_INQ_VARNAME(DH%NCID,i,Name) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1288 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then - NumVars = NumVars+1 - DH%VarNames(NumVars) = Name - DH%VarIDs(NumVars) = i - endif - enddo - DH%NumVars = NumVars - DH%NumberTimes = VLen(2) - DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE - DH%FileName = trim(FileName) - DH%CurrentVariable = 0 - DH%CurrentTime = 0 - DH%TimesVarID = VarID - DH%TimeIndex = 0 - return -end subroutine ext_ncd_open_for_update -SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character*(*) ,intent(inout) :: FileName - integer ,intent(in) :: Comm - integer ,intent(in) :: IOComm - character*(*) ,intent(in) :: SysDepInfo - integer ,intent(out) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - character (7) :: Buffer - integer :: VDimIDs(2) - !call upgrade_filename(FileName) - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1338 - call wrf_debug ( FATAL , msg) - return - endif - call allocHandle(DataHandle,DH,Comm,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1344 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - DH%TimeIndex = 0 - DH%Times = ZeroDate - stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1374 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = trim(FileName) - stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1383 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarNames (1:MaxVars) = NO_NAME - DH%MDVarNames(1:MaxVars) = NO_NAME - do i=1,MaxDims - write(Buffer,FMT="('DIM',i4.4)") i - DH%DimNames (i) = Buffer - DH%DimLengths(i) = NO_DIM - enddo - DH%DimNames(1) = 'DateStrLen' - stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1398 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VDimIDs(1) = DH%DimIDs(1) - VDimIDs(2) = DH%DimUnlimID - stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',"wrf_io.F90",', line', 1407 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(1) = DateStrLen - if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then - DH%R4OnOutput = .true. - end if -!toggle on nofill mode - if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then - DH%nofill = .true. - end if - return -end subroutine ext_ncd_open_for_write_begin -!stub -!opens a file for writing or coupler datastream for sending messages. -!no training phase for this version of the open stmt. -subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, & - SysDepInfo, DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - character *(*), intent(in) ::DatasetName - integer , intent(in) ::Comm1, Comm2 - character *(*), intent(in) ::SysDepInfo - integer , intent(out) :: DataHandle - integer , intent(out) :: Status - Status=WRF_WARN_NOOP - DataHandle = 0 ! dummy setting to quiet warning message - return -end subroutine ext_ncd_open_for_write -SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - integer :: oldmode ! for nf_set_fill, not used - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1459 - call wrf_debug ( FATAL , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',"wrf_io.F90",', line', 1465 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if ( DH%nofill ) then - Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode ) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',"wrf_io.F90",', line', 1472 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName) - call wrf_debug ( WARN , TRIM(msg)) - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',"wrf_io.F90",', line', 1482 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - DH%first_operation = .TRUE. - return -end subroutine ext_ncd_open_for_write_commit -subroutine ext_ncd_ioclose(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',"wrf_io.F90",', line', 1504 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',"wrf_io.F90",', line', 1510 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_CLOSE - write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',"wrf_io.F90",', line', 1514 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',"wrf_io.F90",', line', 1524 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_CLOSE(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_ioclose ',"wrf_io.F90",', line', 1532 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - CALL deallocHandle( DataHandle, Status ) - DH%Free=.true. - return -end subroutine ext_ncd_ioclose -subroutine ext_ncd_iosync( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',"wrf_io.F90",', line', 1554 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',"wrf_io.F90",', line', 1560 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',"wrf_io.F90",', line', 1564 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - continue - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',"wrf_io.F90",', line', 1572 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_SYNC(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ext_ncd_iosync ',"wrf_io.F90",', line', 1579 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - return -end subroutine ext_ncd_iosync -subroutine ext_ncd_redef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1601 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 1607 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 1611 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',"wrf_io.F90",', line', 1619 - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 1623 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1630 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - return -end subroutine ext_ncd_redef -subroutine ext_ncd_enddef( DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle),pointer :: DH - integer :: stat - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 1651 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 1657 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 1661 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - continue - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_FILE_OPEN_FOR_READ - write(msg,*) 'Warning FILE OPEN FOR READ in ',"wrf_io.F90",', line', 1667 - call wrf_debug ( WARN , TRIM(msg)) - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 1671 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 1678 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE - return -end subroutine ext_ncd_enddef -subroutine ext_ncd_ioinit(SysDepInfo, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - CHARACTER*(*), INTENT(IN) :: SysDepInfo - INTEGER ,INTENT(INOUT) :: Status - WrfIOnotInitialized = .false. - WrfDataHandles(1:WrfDataHandleMax)%Free = .true. - WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' - WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' - WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED - if(trim(SysDepInfo) == "use_netcdf_classic" ) then - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .true. - else - WrfDataHandles(1:WrfDataHandleMax)%use_netcdf_classic = .false. - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_ioinit -subroutine ext_ncd_inquiry (Inquiry, Result, Status) - use wrf_data - implicit none - include 'wrf_status_codes.h' - character *(*), INTENT(IN) :: Inquiry - character *(*), INTENT(OUT) :: Result - integer ,INTENT(INOUT) :: Status - SELECT CASE (Inquiry) - CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") - Result='ALLOW' - CASE ("OPEN_READ","OPEN_COMMIT_WRITE") - Result='REQUIRE' - CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") - Result='NO' - CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") - Result='YES' - CASE ("MEDIUM") - Result ='FILE' - CASE DEFAULT - Result = 'No Result for that inquiry!' - END SELECT - Status=WRF_NO_ERR - return -end subroutine ext_ncd_inquiry -subroutine ext_ncd_ioexit(Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer , INTENT(INOUT) ::Status - integer :: error - type(wrf_data_handle),pointer :: DH - integer :: i - integer :: stat - if(WrfIOnotInitialized) then - Status = WRF_IO_NOT_INITIALIZED - write(msg,*) 'ext_ncd_ioinit was not called ',"wrf_io.F90",', line', 1749 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,WrfDataHandleMax - CALL deallocHandle( i , stat ) - enddo - return -end subroutine ext_ncd_ioexit -subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - real,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_FLOAT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_REAL (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','REAL',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_real -subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - integer,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - integer,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','INTEGER',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_integer -subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real*8,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - real*8,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_DOUBLE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','DOUBLE',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_double -subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - logical,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCOunt - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - integer,allocatable :: Buffer(:) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Len), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 116 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT (DH%NCID,NF_GLOBAL,Element,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 - deallocate(Buffer, STAT=stat) - if(stat/= WRF_NO_ERR) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 138 - call wrf_debug ( FATAL , msg) - return - endif - if(Len > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','LOGICAL',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_logical -subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*),intent(out) :: Data - - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XType - integer :: Len - integer :: stat - - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 57 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to read time-independent domain metadata. -IF ( ncd_ok_to_get_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 66 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 71 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WRITE ONLY FILE in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 76 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 83,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 91 - call wrf_debug ( WARN , msg) - return - endif - else - if( XType/=NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 99 - call wrf_debug ( WARN , msg) - return - endif - endif - if(Len<=0) then - Status = WRF_WARN_LENGTH_LESS_THAN_1 - write(msg,*) & -'Warning LENGTH < 1 in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 107 - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_ATT_TEXT(DH%NCID,NF_GLOBAL,Element,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_dom_ti.code",' ','CHAR',', line', 153 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_get_dom_ti_char -subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real ,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_REAL (DH%NCID,NF_GLOBAL,Element,NF_FLOAT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_REAL (DH%NCID,NF_GLOBAL,Element,NF_FLOAT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','REAL',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_real -subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - integer,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','INTEGER',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_integer -subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - real*8 ,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,NF_DOUBLE,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_DOUBLE (DH%NCID,NF_GLOBAL,Element,NF_DOUBLE,Count,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','DOUBLE',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_double -subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - logical,intent(in) :: Data(*) - integer,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 77 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 92 - call wrf_debug ( FATAL , msg) - return - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 119 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_ATT_INT (DH%NCID,NF_GLOBAL,Element,NF_INT,Count,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 135 - call wrf_debug ( FATAL , msg) - return - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','LOGICAL',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_logical -subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*),intent(in) :: Data - integer,parameter :: Count=1 - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 56 - call wrf_debug ( WARN , msg) - return - endif -! Do nothing unless it is time to write time-independent domain metadata. -IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 65 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - STATUS = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 70 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - stat = NF_PUT_ATT_TEXT (DH%NCID,NF_GLOBAL,Element,len_trim(Data),Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 101,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_REDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 110,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_PUT_ATT_TEXT (DH%NCID,NF_GLOBAL,Element,len_trim(Data),Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_ENDDEF(DH%NCID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 153,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_dom_ti.code",' ','CHAR',', line', 160 - call wrf_debug ( FATAL , msg) - endif -ENDIF - return -end subroutine ext_ncd_put_dom_ti_char -subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_PUT_ATT_REAL(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_FLOAT,Count,Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','REAL',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_real -subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_FLOAT,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - stat = NF_PUT_VARA_REAL (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','REAL',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_real -subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_PUT_ATT_DOUBLE(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_DOUBLE,Count,Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','DOUBLE',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_double -subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real*8,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_DOUBLE,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - stat = NF_PUT_VARA_DOUBLE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','DOUBLE',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_double -subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_PUT_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_INT,Count,Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','INTEGER',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_integer -subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_INT,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - stat = NF_PUT_VARA_INT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','INTEGER',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_integer -subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 99 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), NF_INT,Count,Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 124 - call wrf_debug ( WARN , msg) - endif - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 132 - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','LOGICAL',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_logical -subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == Count) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Count,DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = Count - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = Count - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_INT,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(Count > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(Count < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Count - VCount(2) = 1 - allocate(Buffer(Count), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 196 - call wrf_debug ( FATAL , msg) - return - endif - do i=1,Count - if(data(i)) then - Buffer(i)=1 - else - Buffer(i)=0 - endif - enddo - stat = NF_PUT_VARA_INT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer) - deallocate(Buffer, STAT=stat2) - if(stat2/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 212 - call wrf_debug ( FATAL , msg) - return - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','LOGICAL',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_logical -subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(in) :: Data - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: NVar - character*1 :: null - null=char(0) - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 61 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 68 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 73 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_MD_AFTER_OPEN - write(msg,*) & -'Warning WRITE METADATA AFTER OPEN in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 78 - call wrf_debug ( WARN , msg) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 88 & - ,NVar,VarName - call wrf_debug ( WARN , msg) - return - endif - enddo - if(len_trim(Data).le.0) then - stat = NF_PUT_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element),len_trim(null),null) - else - stat = NF_PUT_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element), len_trim(Data),trim(Data) ) - endif - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error for Var ',TRIM(Var),& - ' Element ',trim(Element),' in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 124 - call wrf_debug ( WARN , msg) - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_ti.code",' ','CHAR',', line', 140 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_ti_char -subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - character*(*) ,intent(in) :: Data - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - integer :: stat - integer :: stat2 - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 67 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 74 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 82 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 89 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) & -'Warning WRITE READ ONLY FILE in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 94 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - if(len(Data) < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - return - endif - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - return - elseif(DH%MDVarNames(NVar) == NO_NAME) then - DH%MDVarNames(NVar) = Name - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 111 - call wrf_debug ( WARN , msg) - return - endif - enddo - do i=1,MaxDims - if(DH%DimLengths(i) == len(Data)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),len(Data),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 124,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - DH%DimLengths(i) = len(Data) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) & -'Warning TOO MANY DIMENSIONS in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 133 - call wrf_debug ( WARN , msg) - return - endif - enddo - DH%MDVarDimLens(NVar) = len(Data) - VDims(1) = DH%DimIDs(i) - VDims(2) = DH%DimUnlimID - stat = NF_DEF_VAR(NCID,Name,NF_CHAR,2,VDims,DH%MDVarIDs(NVar)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 145,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - do NVar=1,MaxVars - if(DH%MDVarNames(NVar) == Name) then - exit - elseif(DH%MDVarNames(NVar) == NO_NAME) then - Status = WRF_WARN_MD_NF - write(msg,*) & -'Warning METADATA NOT FOUND in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 156 - call wrf_debug ( WARN , msg) - return - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) & -'Warning TOO MANY VARIABLES in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 162 - call wrf_debug ( WARN , msg) - return - endif - enddo - if(len(Data) > DH%MDVarDimLens(NVar)) then - Status = WRF_WARN_COUNT_TOO_LONG - write(msg,*) & -'Warning COUNT TOO LONG in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 170 - call wrf_debug ( WARN , msg) - return - elseif(len(Data) < 1) then - Status = WRF_WARN_ZERO_LENGTH_PUT - write(msg,*) & -'Warning ZERO LENGTH PUT in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 176 - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 183 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = len(Data) - VCount(2) = 1 - stat = NF_PUT_VARA_TEXT (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 222,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_put_var_td.code",' ','CHAR',', line', 229 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_put_var_td_char -subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - real ,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_FLOAT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_REAL(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','REAL',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_real -subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - real ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_FLOAT == NF_DOUBLE .OR. NF_FLOAT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_FLOAT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_REAL (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','REAL',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_real -subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - real*8 ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - real*8 ,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_DOUBLE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_DOUBLE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','DOUBLE',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_double -subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - real*8 ,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - real*8 ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_DOUBLE == NF_DOUBLE .OR. NF_DOUBLE == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_DOUBLE) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_DOUBLE (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','DOUBLE',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_double -subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - integer,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - integer,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','INTEGER',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_integer -subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_INT (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','INTEGER',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_integer -subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - logical,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - integer,allocatable :: Buffer(:) - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - allocate(Buffer(XLen), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 128 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 155 - call wrf_debug ( FATAL , msg) - return - endif - if(XLen > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = XLen - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','LOGICAL',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_logical -subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - logical,intent(out) :: Data(*) - integer,intent(in) :: Count - integer,intent(out) :: OutCount - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - integer ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_INT == NF_DOUBLE .OR. NF_INT == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = min(Count,Len1) - VCount(2) = 1 - allocate(Buffer(VCount(1)), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) & -'Fatal ALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 180 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_GET_VARA_INT (NCID,VarID,VStart,VCount,Buffer) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 - deallocate(Buffer, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) & -'Fatal DEALLOCATION ERROR in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 209 - call wrf_debug ( FATAL , msg) - return - endif - if(Len1 > Count) then - OutCount = Count - Status = WRF_WARN_MORE_DATA_IN_FILE - else - OutCount = Len1 - Status = WRF_NO_ERR - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','LOGICAL',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_logical -subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Data - integer :: Count = 1 - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: XLen - - character (VarNameLen) :: VarName - integer :: stat - integer :: NVar - integer :: XType - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 60 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 68 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 75 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 80 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 85 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) & -'Warning VARIABLE NOT FOUND in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 94 - call wrf_debug ( WARN , msg) - return - endif - enddo - stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 103,' Element ',Element - call wrf_debug ( WARN , msg) - endif - if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 110 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 118 - call wrf_debug ( WARN , msg) - return - endif - endif - if(XLen > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 137 - call wrf_debug ( WARN , msg) - return - endif - stat = NF_GET_ATT_TEXT(DH%NCID,DH%VarIDs(NVar),trim(Element), Data ) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 146,' Element ',Element - call wrf_debug ( WARN , msg) - endif - - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_ti.code",' ','CHAR',', line', 170 - call wrf_debug ( FATAL , msg) - return - endif - return -end subroutine ext_ncd_get_var_ti_char -subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) -!*------------------------------------------------------------------------------ -!* Standard Disclaimer -!* -!* Forecast Systems Laboratory -!* NOAA/OAR/ERL/FSL -!* 325 Broadway -!* Boulder, CO 80303 -!* -!* AVIATION DIVISION -!* ADVANCED COMPUTING BRANCH -!* SMS/NNT Version: 2.0.0 -!* -!* This software and its documentation are in the public domain and -!* are furnished "as is". The United States government, its -!* instrumentalities, officers, employees, and agents make no -!* warranty, express or implied, as to the usefulness of the software -!* and documentation for any purpose. They assume no -!* responsibility (1) for the use of the software and documentation; -!* or (2) to provide technical support to users. -!* -!* Permission to use, copy, modify, and distribute this software is -!* hereby granted, provided that this disclaimer notice appears in -!* all copies. All modifications to this software must be clearly -!* documented, and are solely the responsibility of the agent making -!* the modification. If significant modifications or enhancements -!* are made to this software, the SMS Development team -!* (sms-info@fsl.noaa.gov) should be notified. -!* -!*---------------------------------------------------------------------------- -!* -!* WRF NetCDF I/O -! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov -!* Date: October 6, 2000 -!* -!*---------------------------------------------------------------------------- - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character (DateStrLen),intent(in) :: DateStr - character*(*) ,intent(in) :: Var - character*(*) ,intent(out) :: Data - integer :: Count = 1 - - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - character (VarNameLen) :: VarName - character (40+len(Element)) :: Name - character (40+len(Element)) :: FName - integer :: stat - character (80) ,allocatable :: Buffer(:) - integer :: i - integer :: VDims (2) - integer :: VStart(2) - integer :: VCount(2) - integer :: NVar - integer :: TimeIndex - integer :: NCID - integer :: DimIDs(2) - integer :: VarID - integer :: XType - integer :: NDims - integer :: NAtts - integer :: Len1 - if(Count <= 0) then - Status = WRF_WARN_ZERO_LENGTH_GET - write(msg,*) & -'Warning ZERO LENGTH GET in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 73 - call wrf_debug ( WARN , msg) - return - endif - VarName = Var - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning DATE STRING ERROR in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 81 - call wrf_debug ( WARN , msg) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 88 - call wrf_debug ( WARN , msg) - return - endif - NCID = DH%NCID - call GetName(Element, VarName, Name, Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning Status = ',Status,' in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 96 - call wrf_debug ( WARN , msg) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) & -'Warning FILE NOT OPENED in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 103 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) & -'Warning DRYRUN READ in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 108 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) & -'Warning READ WONLY FILE in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 113 - call wrf_debug ( WARN , msg) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - stat = NF_INQ_VARID(NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 120,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - stat = NF_INQ_VAR(NCID,VarID,FName,XType,NDims,DimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 128,' Element ',Element - call wrf_debug ( WARN , msg) - return - endif - if ( NF_CHAR == NF_DOUBLE .OR. NF_CHAR == NF_FLOAT ) then - if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 136 - call wrf_debug ( WARN , msg) - return - endif - else - if(XType /= NF_CHAR) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) & -'Warning TYPE MISMATCH in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 144 - call wrf_debug ( WARN , msg) - return - endif - endif - if(NDims /= NMDVarDims) then - Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D - write(msg,*) & -'Fatal MDVAR DIM NOT 1D in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 152 - call wrf_debug ( FATAL , msg) - return - endif - stat = NF_INQ_DIMLEN(NCID,DimIDs(1),Len1) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 160,' DimIDs(1) ',DimIDs(1) - call wrf_debug ( WARN , msg) - return - endif - call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'Warning in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 167 - call wrf_debug ( WARN , msg) - return - endif - VStart(1) = 1 - VStart(2) = TimeIndex - VCount(1) = Len1 - VCount(2) = 1 - if(Len1 > len(Data)) then - Status = WRF_WARN_CHARSTR_GT_LENDATA - write(msg,*) & -'Warning LEN CHAR STRING > LEN DATA in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 189 - call wrf_debug ( WARN , msg) - return - endif - Data = '' - stat = NF_GET_VARA_TEXT (NCID,VarID,VStart,VCount,Data) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) & -'NetCDF error in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 199 - call wrf_debug ( WARN , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) & -'Fatal error BAD FILE STATUS in ',"ext_ncd_get_var_td.code",' ','CHAR',', line', 224 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_td_char -subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_real -subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_integer -subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_double -subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(in) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: Status - call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) - return -end subroutine ext_ncd_put_dom_td_logical -subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Data - integer ,intent(out) :: Status - call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_put_dom_td_char -subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_real -subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_integer -subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - real*8 ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_double -subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - logical ,intent(out) :: Data(*) - integer ,intent(in) :: Count - integer ,intent(out) :: OutCount - integer ,intent(out) :: Status - call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) - return -end subroutine ext_ncd_get_dom_td_logical -subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status) - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Element - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(out) :: Data - integer ,intent(out) :: Status - call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, & - 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) - return -end subroutine ext_ncd_get_dom_td_char -subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, & - Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(inout) :: Field(*) - integer ,intent(in) :: FieldTypeIn - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) ,dimension(*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - integer :: FieldType - character (3) :: MemoryOrder - type(wrf_data_handle) ,pointer :: DH - integer :: NCID - integer :: NDim - character (VarNameLen) :: VarName - character (3) :: MemO - character (3) :: UCMemO - integer :: VarID - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - character(80),dimension(NVarDims) :: RODimNames - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(:,:,:,:),allocatable :: XField - integer :: stat - integer :: NVar - integer :: i,j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - integer :: XType - integer :: di - character (80) :: NullName - logical :: NotFound - MemoryOrder = trim(adjustl(MemoryOrdIn)) - NullName=char(0) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',"wrf_io.F90",', line', 2482 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',"wrf_io.F90",', line', 2489 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 2496 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - NCID = DH%NCID - if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then - FieldType = WRF_REAL - else - FieldType = FieldTypeIn - end if - write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var) -!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN - write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring' - call wrf_debug ( WARN , TRIM(msg)) - return - ENDIF - call ExtOrder(MemoryOrder,Length,Status) - call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 2533 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - Status = WRF_WARN_WRITE_RONLY_FILE - write(msg,*) 'Warning WRITE READ ONLY FILE in ',"wrf_io.F90",', line', 2537 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - do NVar=1,MaxVars - if(DH%VarNames(NVar) == VarName ) then - Status = WRF_WARN_2DRYRUNS_1VARIABLE - write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',"wrf_io.F90",', line', 2543 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%VarNames(NVar) == NO_NAME) then - DH%VarNames(NVar) = VarName - DH%NumVars = NVar - exit - elseif(NVar == MaxVars) then - Status = WRF_WARN_TOO_MANY_VARIABLES - write(msg,*) 'Warning TOO MANY VARIABLES in ',"wrf_io.F90",', line', 2552 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - do j = 1,NDim - if(RODimNames(j) == NullName .or. RODimNames(j) == '') then - do i=1,MaxDims - if(DH%DimLengths(i) == Length(j)) then - exit - elseif(DH%DimLengths(i) == NO_DIM) then - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2566 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',"wrf_io.F90",', line', 2574 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else !look for input name and check if already defined - NotFound = .true. - do i=1,MaxDims - if (DH%DimNames(i) == RODimNames(j)) then - if (DH%DimLengths(i) == Length(j)) then - NotFound = .false. - exit - else - Status = WRF_WARN_DIMNAME_REDEFINED - write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & - TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', "wrf_io.F90" ,' line', 2589 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - endif - enddo - if (NotFound) then - do i=1,MaxDims - if (DH%DimLengths(i) == NO_DIM) then - DH%DimNames(i) = RODimNames(j) - stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2602 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%DimLengths(i) = Length(j) - exit - elseif(i == MaxDims) then - Status = WRF_WARN_TOO_MANY_DIMS - write(msg,*) 'Warning TOO MANY DIMENSIONS in ',"wrf_io.F90",', line', 2610 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - endif - endif - VDimIDs(j) = DH%DimIDs(i) - DH%VarDimLens(j,NVar) = Length(j) - enddo - VDimIDs(NDim+1) = DH%DimUnlimID - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN - XType = NF_FLOAT - ELSE IF (FieldType == WRF_DOUBLE) THEN - Xtype = NF_DOUBLE - ELSE IF (FieldType == WRF_INTEGER) THEN - XType = NF_INT - ELSE IF (FieldType == WRF_LOGICAL) THEN - XType = NF_INT - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 2633 - call wrf_debug ( WARN , TRIM(msg)) - return - END IF - stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',"wrf_io.F90",', line', 2641 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - DH%VarIDs(NVar) = VarID - stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',"wrf_io.F90",', line', 2697 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call reorder(MemoryOrder,MemO) - call uppercase(MemO,UCMemO) - stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'ext_ncd_write_field: NetCDF error in ',"wrf_io.F90",', line', 2706 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - do NVar=1,DH%NumVars - if(DH%VarNames(NVar) == VarName) then - exit - elseif(NVar == DH%NumVars) then - Status = WRF_WARN_VAR_NF - write(msg,*) 'Warning VARIABLE NOT FOUND in ',"wrf_io.F90",', line', 2716 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - VarID = DH%VarIDs(NVar) - do j=1,NDim - if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then - Status = WRF_WARN_WRTLEN_NE_DRRUNLEN - write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & - VarName,'| dim ',j,' in ',"wrf_io.F90",', line', 2726 - call wrf_debug ( WARN , TRIM(msg)) - write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) - call wrf_debug ( WARN , TRIM(msg)) - return -!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then - elseif(PatchStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & - '| in ',"wrf_io.F90",', line', 2735 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2) - call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 2749 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then - call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - else - call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - end if - call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 2765 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 2772 - call wrf_debug ( FATAL , TRIM(msg)) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 2778 - call wrf_debug ( FATAL , TRIM(msg)) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_write_field -subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & - IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & - DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - character*(*) ,intent(in) :: Var - integer ,intent(out) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrdIn - character*(*) ,intent(in) :: Stagger ! Dummy for now - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - character (3) :: MemoryOrder - character (NF_MAX_NAME) :: dimname - type(wrf_data_handle) ,pointer :: DH - integer :: NDim - integer :: NCID - character (VarNameLen) :: VarName - integer :: VarID - integer ,dimension(NVarDims) :: VCount - integer ,dimension(NVarDims) :: VStart - integer ,dimension(NVarDims) :: Length - integer ,dimension(NVarDims) :: VDimIDs - integer ,dimension(NVarDims) :: MemS - integer ,dimension(NVarDims) :: MemE - integer ,dimension(NVarDims) :: StoredStart - integer ,dimension(NVarDims) :: StoredLen - integer ,dimension(:,:,:,:) ,allocatable :: XField - integer :: NVar - integer :: j - integer :: i1,i2,j1,j2,k1,k2 - integer :: x1,x2,y1,y2,z1,z2 - integer :: l1,l2,m1,m2,n1,n2 - character (VarNameLen) :: Name - integer :: XType - integer :: StoredDim - integer :: NAtts - integer :: Len - integer :: stat - integer :: di - integer :: FType - MemoryOrder = trim(adjustl(MemoryOrdIn)) - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & - TRIM(Var),'| in ext_ncd_read_field ',"wrf_io.F90",', line', 2842 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & - '| in ext_ncd_read_field ',"wrf_io.F90",', line', 2849 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - VarName = Var - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',"wrf_io.F90",', line', 2856 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 2862 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then -! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return. -! Status = WRF_WARN_DRYRUN_READ -! write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 2867 -! call wrf_debug ( WARN , TRIM(msg)) - Status = WRF_NO_ERR - RETURN - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 2873 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - NCID = DH%NCID -!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 - Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 - call ExtOrder(MemoryOrder,Length,Status) - stat = NF_INQ_VARID(NCID,VarName,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2884,' Varname ',Varname - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2891 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2898 - call wrf_debug ( WARN , TRIM(msg)) - return - endif -! allow coercion between double and single prec real -!jm if(FieldType /= Ftype) then - if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then - if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 2907 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - else if(FieldType /= Ftype) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning TYPE MISMATCH in ',"wrf_io.F90",', line', 2913 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE - IF (FieldType == WRF_REAL) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning REAL TYPE MISMATCH in ',"wrf_io.F90",', line', 2923 - endif - ELSE IF (FieldType == WRF_DOUBLE) THEN -! allow coercion between double and single prec real - if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',"wrf_io.F90",', line', 2929 - endif - ELSE IF (FieldType == WRF_INTEGER) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',"wrf_io.F90",', line', 2934 - endif - ELSE IF (FieldType == WRF_LOGICAL) THEN - if(XType /= NF_INT) then - Status = WRF_WARN_TYPE_MISMATCH - write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',"wrf_io.F90",', line', 2939 - endif - ELSE - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 2943 - END IF - if(Status /= WRF_NO_ERR) then - call wrf_debug ( WARN , TRIM(msg)) - return - endif - ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 - IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN - stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2955 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - IF ( dimname(1:10) == 'ext_scalar' ) THEN - NDim = 1 - Length(1) = 1 - ENDIF - ENDIF - if(StoredDim /= NDim+1) then - Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM - write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr) - call wrf_debug ( FATAL , msg) - write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 - call wrf_debug ( FATAL , msg) - return - endif - do j=1,NDim - stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 2976 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(Length(j) > StoredLen(j)) then - Status = WRF_WARN_READ_PAST_EOF - write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j) - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(Length(j) <= 0) then - Status = WRF_WARN_ZERO_LENGTH_READ - write(msg,*) 'Warning ZERO LENGTH READ in ',"wrf_io.F90",', line', 2987 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DomainStart(j) < MemoryStart(j)) then - Status = WRF_WARN_DIMENSION_ERROR - write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), & - ') < MemoryStart (',MemoryStart(j),') in ',"wrf_io.F90",', line', 2993 - call wrf_debug ( WARN , TRIM(msg)) -! return - endif - enddo - StoredStart = 1 - call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) - call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) -!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2) - call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) - di=1 - if(FieldType == WRF_DOUBLE) di=2 - allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_ALLOCATION_ERROR - write(msg,*) 'Fatal ALLOCATION ERROR in ',"wrf_io.F90",', line', 3010 - call wrf_debug ( FATAL , msg) - return - endif - call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, & - FieldType,NCID,VarID,XField,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3017 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & - ,XField,x1,x2,y1,y2,z1,z2 & - ,i1,i2,j1,j2,k1,k2 ) - deallocate(XField, STAT=stat) - if(stat/= 0) then - Status = WRF_ERR_FATAL_DEALLOCATION_ERR - write(msg,*) 'Fatal DEALLOCATION ERROR in ',"wrf_io.F90",', line', 3027 - call wrf_debug ( FATAL , msg) - return - endif - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3033 - call wrf_debug ( FATAL , msg) - endif - DH%first_operation = .FALSE. - return -end subroutine ext_ncd_read_field -subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(inout) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - !call upgrade_filename(FileName) - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - FileStatus = WRF_FILE_NOT_OPENED - return - endif - if(trim(FileName) /= trim(DH%FileName)) then - FileStatus = WRF_FILE_NOT_OPENED - else - FileStatus = DH%FileStatus - endif - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_opened -subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: FileName - integer ,intent(out) :: FileStatus - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - FileStatus = WRF_FILE_NOT_OPENED - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3080 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - FileName = trim(DH%FileName) - FileStatus = DH%FileStatus - Status = WRF_NO_ERR - return -end subroutine ext_ncd_inquire_filename -subroutine ext_ncd_set_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: i - call DateCheck(DateStr,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning DATE STRING ERROR in ',"wrf_io.F90",', line', 3103 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3109 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3115 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_FILE_NOT_COMMITTED - write(msg,*) 'Warning FILE NOT COMMITTED in ',"wrf_io.F90",', line', 3119 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3123 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - do i=1,MaxTimes - if(DH%Times(i)==DateStr) then - DH%CurrentTime = i - exit - endif - if(i==MaxTimes) then - Status = WRF_WARN_TIME_NF - return - endif - enddo - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3140 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_set_time -subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3158 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3164 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3168 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3172 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then - if(DH%CurrentTime >= DH%NumberTimes) then - Status = WRF_WARN_TIME_EOF - return - endif - DH%CurrentTime = DH%CurrentTime +1 - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'DH%FileStatus ',DH%FileStatus - call wrf_debug ( FATAL , msg) - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3187 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_time -subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: DateStr - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3205 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3211 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3215 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3219 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then - if(DH%CurrentTime.GT.0) then - DH%CurrentTime = DH%CurrentTime -1 - endif - DateStr = DH%Times(DH%CurrentTime) - DH%CurrentVariable = 0 - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3230 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_previous_time -subroutine ext_ncd_get_next_var(DataHandle, VarName, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'wrf_status_codes.h' - include 'netcdf.inc' - integer ,intent(in) :: DataHandle - character*(*) ,intent(out) :: VarName - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: stat - character (80) :: Name - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3251 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3257 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3261 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3265 - call wrf_debug ( WARN , TRIM(msg)) - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - DH%CurrentVariable = DH%CurrentVariable +1 - if(DH%CurrentVariable > DH%NumVars) then - Status = WRF_WARN_VAR_EOF - return - endif - VarName = DH%VarNames(DH%CurrentVariable) - Status = WRF_NO_ERR - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3278 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_next_var -subroutine ext_ncd_end_of_frame(DataHandle, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - call GetDH(DataHandle,DH,Status) - return -end subroutine ext_ncd_end_of_frame -! NOTE: For scalar variables NDim is set to zero and DomainStart and -! NOTE: DomainEnd are left unmodified. -subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: Name - integer ,intent(out) :: NDim - character*(*) ,intent(out) :: MemoryOrder - character*(*) :: Stagger ! Dummy for now - integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd - integer ,intent(out) :: WrfType - integer ,intent(out) :: Status - type(wrf_data_handle) ,pointer :: DH - integer :: VarID - integer ,dimension(NVarDims) :: VDimIDs - integer :: j - integer :: stat - integer :: XType - call GetDH(DataHandle,DH,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning Status = ',Status,' in ',"wrf_io.F90",', line', 3323 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - if(DH%FileStatus == WRF_FILE_NOT_OPENED) then - Status = WRF_WARN_FILE_NOT_OPENED - write(msg,*) 'Warning FILE NOT OPENED in ',"wrf_io.F90",', line', 3329 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then - Status = WRF_WARN_DRYRUN_READ - write(msg,*) 'Warning DRYRUN READ in ',"wrf_io.F90",', line', 3334 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then - Status = WRF_WARN_READ_WONLY_FILE - write(msg,*) 'Warning READ WRITE ONLY FILE in ',"wrf_io.F90",', line', 3339 - call wrf_debug ( WARN , TRIM(msg)) - return - elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then - stat = NF_INQ_VARID(DH%NCID,Name,VarID) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3346 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3353 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3360 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - select case (XType) - case (NF_BYTE) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3367 - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_CHAR) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3372 - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_SHORT) - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',"wrf_io.F90",', line', 3377 - call wrf_debug ( WARN , TRIM(msg)) - return - case (NF_INT) - if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3383 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_FLOAT) - if(WrfType /= WRF_REAL) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3390 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case (NF_DOUBLE) - if(WrfType /= WRF_DOUBLE) then - Status = WRF_WARN_BAD_DATA_TYPE - write(msg,*) 'Warning BAD DATA TYPE in ',"wrf_io.F90",', line', 3397 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - case default - Status = WRF_WARN_DATA_TYPE_NOT_FOUND - write(msg,*) 'Warning DATA TYPE NOT FOUND in ',"wrf_io.F90",', line', 3403 - call wrf_debug ( WARN , TRIM(msg)) - return - end select - stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3411 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - call GetDim(MemoryOrder,NDim,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',"wrf_io.F90",', line', 3417 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3424 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - do j = 1, NDim - DomainStart(j) = 1 - stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j)) - call netcdf_err(stat,Status) - if(Status /= WRF_NO_ERR) then - write(msg,*) 'NetCDF error in ',"wrf_io.F90",', line', 3433 - call wrf_debug ( WARN , TRIM(msg)) - return - endif - enddo - else - Status = WRF_ERR_FATAL_BAD_FILE_STATUS - write(msg,*) 'Fatal error BAD FILE STATUS in ',"wrf_io.F90",', line', 3440 - call wrf_debug ( FATAL , msg) - endif - return -end subroutine ext_ncd_get_var_info -subroutine ext_ncd_warning_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - SELECT CASE (Code) - CASE (0) - ReturnString='No error' - Status=WRF_NO_ERR - return - CASE (-1) - ReturnString= 'File not found (or file is incomplete)' - Status=WRF_NO_ERR - return - CASE (-2) - ReturnString='Metadata not found' - Status=WRF_NO_ERR - return - CASE (-3) - ReturnString= 'Timestamp not found' - Status=WRF_NO_ERR - return - CASE (-4) - ReturnString= 'No more timestamps' - Status=WRF_NO_ERR - return - CASE (-5) - ReturnString= 'Variable not found' - Status=WRF_NO_ERR - return - CASE (-6) - ReturnString= 'No more variables for the current time' - Status=WRF_NO_ERR - return - CASE (-7) - ReturnString= 'Too many open files' - Status=WRF_NO_ERR - return - CASE (-8) - ReturnString= 'Data type mismatch' - Status=WRF_NO_ERR - return - CASE (-9) - ReturnString= 'Attempt to write read-only file' - Status=WRF_NO_ERR - return - CASE (-10) - ReturnString= 'Attempt to read write-only file' - Status=WRF_NO_ERR - return - CASE (-11) - ReturnString= 'Attempt to access unopened file' - Status=WRF_NO_ERR - return - CASE (-12) - ReturnString= 'Attempt to do 2 trainings for 1 variable' - Status=WRF_NO_ERR - return - CASE (-13) - ReturnString= 'Attempt to read past EOF' - Status=WRF_NO_ERR - return - CASE (-14) - ReturnString= 'Bad data handle' - Status=WRF_NO_ERR - return - CASE (-15) - ReturnString= 'Write length not equal to training length' - Status=WRF_NO_ERR - return - CASE (-16) - ReturnString= 'More dimensions requested than training' - Status=WRF_NO_ERR - return - CASE (-17) - ReturnString= 'Attempt to read more data than exists' - Status=WRF_NO_ERR - return - CASE (-18) - ReturnString= 'Input dimensions inconsistent' - Status=WRF_NO_ERR - return - CASE (-19) - ReturnString= 'Input MemoryOrder not recognized' - Status=WRF_NO_ERR - return - CASE (-20) - ReturnString= 'A dimension name with 2 different lengths' - Status=WRF_NO_ERR - return - CASE (-21) - ReturnString= 'String longer than provided storage' - Status=WRF_NO_ERR - return - CASE (-22) - ReturnString= 'Function not supportable' - Status=WRF_NO_ERR - return - CASE (-23) - ReturnString= 'Package implements this routine as NOOP' - Status=WRF_NO_ERR - return -!netcdf-specific warning messages - CASE (-1007) - ReturnString= 'Bad data type' - Status=WRF_NO_ERR - return - CASE (-1008) - ReturnString= 'File not committed' - Status=WRF_NO_ERR - return - CASE (-1009) - ReturnString= 'File is opened for reading' - Status=WRF_NO_ERR - return - CASE (-1011) - ReturnString= 'Attempt to write metadata after open commit' - Status=WRF_NO_ERR - return - CASE (-1010) - ReturnString= 'I/O not initialized' - Status=WRF_NO_ERR - return - CASE (-1012) - ReturnString= 'Too many variables requested' - Status=WRF_NO_ERR - return - CASE (-1013) - ReturnString= 'Attempt to close file during a dry run' - Status=WRF_NO_ERR - return - CASE (-1014) - ReturnString= 'Date string not 19 characters in length' - Status=WRF_NO_ERR - return - CASE (-1015) - ReturnString= 'Attempt to read zero length words' - Status=WRF_NO_ERR - return - CASE (-1016) - ReturnString= 'Data type not found' - Status=WRF_NO_ERR - return - CASE (-1017) - ReturnString= 'Badly formatted date string' - Status=WRF_NO_ERR - return - CASE (-1018) - ReturnString= 'Attempt at read during a dry run' - Status=WRF_NO_ERR - return - CASE (-1019) - ReturnString= 'Attempt to get zero words' - Status=WRF_NO_ERR - return - CASE (-1020) - ReturnString= 'Attempt to put zero length words' - Status=WRF_NO_ERR - return - CASE (-1021) - ReturnString= 'NetCDF error' - Status=WRF_NO_ERR - return - CASE (-1022) - ReturnString= 'Requested length <= 1' - Status=WRF_NO_ERR - return - CASE (-1023) - ReturnString= 'More data available than requested' - Status=WRF_NO_ERR - return - CASE (-1024) - ReturnString= 'New date less than previous date' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this warning code.' - Status=WRF_NO_ERR - END SELECT - return -end subroutine ext_ncd_warning_str -!returns message string for all WRF and netCDF warning/error status codes -!Other i/o packages must provide their own routines to return their own status messages -subroutine ext_ncd_error_str( Code, ReturnString, Status) - use wrf_data - use ext_ncd_support_routines - implicit none - include 'netcdf.inc' - include 'wrf_status_codes.h' - integer , intent(in) ::Code - character *(*), intent(out) :: ReturnString - integer, intent(out) ::Status - SELECT CASE (Code) - CASE (-100) - ReturnString= 'Allocation Error' - Status=WRF_NO_ERR - return - CASE (-101) - ReturnString= 'Deallocation Error' - Status=WRF_NO_ERR - return - CASE (-102) - ReturnString= 'Bad File Status' - Status=WRF_NO_ERR - return - CASE (-1004) - ReturnString= 'Variable on disk is not 3D' - Status=WRF_NO_ERR - return - CASE (-1005) - ReturnString= 'Metadata on disk is not 1D' - Status=WRF_NO_ERR - return - CASE (-1006) - ReturnString= 'Time dimension too small' - Status=WRF_NO_ERR - return - CASE DEFAULT - ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & - & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & - & to be calling a package-specific routine to return a message for this error code.' - Status=WRF_NO_ERR - END SELECT - return -end subroutine ext_ncd_error_str diff --git a/src/wrflib/wrf_io_flags.h b/src/wrflib/wrf_io_flags.h deleted file mode 100644 index 2048aff665..0000000000 --- a/src/wrflib/wrf_io_flags.h +++ /dev/null @@ -1,15 +0,0 @@ - integer, parameter :: WRF_FILE_NOT_OPENED = 100 - integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 - integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 - integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 - integer, parameter :: WRF_REAL = 104 - integer, parameter :: WRF_DOUBLE = 105 - integer, parameter :: WRF_FLOAT=WRF_REAL - integer, parameter :: WRF_INTEGER = 106 - integer, parameter :: WRF_LOGICAL = 107 - integer, parameter :: WRF_COMPLEX = 108 - integer, parameter :: WRF_DOUBLE_COMPLEX = 109 - integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 -! This bit is for backwards compatibility with old variants of these flags -! that are still being used in io_grib1 and io_phdf5. It should be removed! - integer, parameter :: WRF_FILE_OPENED_AND_COMMITTED = 102 diff --git a/src/wrflib/wrf_status_codes.h b/src/wrflib/wrf_status_codes.h deleted file mode 100644 index 059d9ea719..0000000000 --- a/src/wrflib/wrf_status_codes.h +++ /dev/null @@ -1,133 +0,0 @@ - -!WRF Error and Warning messages (1-999) -!All i/o package-specific status codes you may want to add must be handled by your package (see below) -! WRF handles these and netCDF messages only - integer, parameter :: WRF_NO_ERR = 0 !no error - integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete - integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found - integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found - integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps - integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found - integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time - integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files - integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch - integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file - integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file - integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file - integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable - integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF - integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle - integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length - integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training - integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists - integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent - integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized - integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths - integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage - integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable - integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP - -!Fatal errors - integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error - integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error - integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status - - -!Package specific errors (1000+) -!Netcdf status codes -!WRF will accept status codes of 1000+, but it is up to the package to handle -! and return the status to the user. - - integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 - integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 - integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 - integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 - integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 - integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 - integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 - integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 - integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 - integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 - integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 - integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 - integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 - integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 - integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 - integer, parameter :: WRF_WARN_NETCDF = -1021 - integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 - integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 - integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 - -! For HDF5 only - integer, parameter :: WRF_HDF5_ERR_FILE = -200 - integer, parameter :: WRF_HDF5_ERR_MD = -201 - integer, parameter :: WRF_HDF5_ERR_TIME = -202 - integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 - integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 - integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 - integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 - integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 - integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 - integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 - integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 - integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 - integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 - integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 - integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 - integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 - integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 - integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 - integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 - integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 - integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 - integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 - - integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 - integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 - integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 - integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 - integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 - integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 - - integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 - integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 - integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 - - integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 - integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 - integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 - integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 - integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 - integer, parameter :: WRF_HDF5_ERR_GROUP = -308 - - integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 - integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 - integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 - integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 - integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 - - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 - - integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 - diff --git a/ush/build.comgsi b/ush/build.comgsi index 6957e8b3ca..cd2a0570b9 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -5,8 +5,9 @@ # Cheyenne: source /glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF # # build commands: -# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON path_to_ProdGSI -# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_UTIL_COM=ON -DBUILD_ENKF_PREPROCESS_ARW=ON" +# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON path_to_GSI +# cmake -DENKF_MODE=WRF -DBUILD_CORELIBS=ON -DBUILD_GSDCLOUD_ARW=ON -DBUILD_UTIL_COM=ON -DBUILD_ENKF_PREPROCESS_ARW=ON path_to_GSI" +# (for global: cmake -D-DENKF_MODE=GFS -DBUILD_CORELIBS=ON path_to_GSI) # make -j8 # @@ -24,12 +25,23 @@ elif [[ -d /glade ]] ; then ### cheyenne source /etc/profile.d/modules.sh modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" + GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274/" + #modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" + #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" + #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" elif [[ -d /work/noaa ]] ; then ### orion modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" else - echo "unknown machine" + echo -e "\nunknown machine" + echo "Please modify build.comgsi at this location" + echo "to load required modules and setup NCEPLIBS and GSILIBS" + ##follow the above examples and delete the following "exit 9" to go forward exit 9 + source /etc/profile.d/modules.sh + modulefile="/my/modulefile.me.GSI_UPP_WRF" + NCEPLIBS="/my/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" + GSILIBS="/my/GSILIBS/b_intel18.0.5_impi2018.4.274/" fi if [ ! -f $modulefile ]; then @@ -44,7 +56,9 @@ if [[ "$NETCDF4" == "1" ]] || [[ "$NETCDF4" == "0" ]]; then fi export BACIO_LIB4=${NCEPLIBS}/lib/libbacio_4.a -#export BUFR_LIBd=${NCEPLIBS}/lib/libbufr_d.a #NCEPLIBS has problems in generateing libbufr +#export BUFR_LIBd=${NCEPLIBS}/lib/libbufr_d.a + export BUFR_LIBd=${GSILIBS}/lib/libbufr_v.a + export GSIWRF_LIB=${GSILIBS}/lib/libWRFLIB.a export CRTM_LIB=${NCEPLIBS}/lib/libcrtm.a export CRTM_INC=${NCEPLIBS}/include export NEMSIO_LIB=${NCEPLIBS}/lib/libnemsio.a From ed8f985168f857519a597ad80610ff5e2ecb4cac Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Fri, 5 Jun 2020 10:57:50 -0600 Subject: [PATCH 07/11] bug fixes on gsdcloud and phil2.f90 --- .gitignore | 1 + src/GSD/gsdcloud/CMakeLists.txt | 2 + src/GSD/gsdcloud/kinds.f90 | 105 -------------------------------- src/GSD/gsdcloud4nmmb/kinds.f90 | 105 -------------------------------- src/gsi/phil2.f90 | 4 +- ush/build.comgsi | 12 ++-- 6 files changed, 11 insertions(+), 218 deletions(-) delete mode 100755 src/GSD/gsdcloud/kinds.f90 delete mode 100755 src/GSD/gsdcloud4nmmb/kinds.f90 diff --git a/.gitignore b/.gitignore index a5309e6b90..4d3244a698 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,2 @@ build*/ +.*.swp diff --git a/src/GSD/gsdcloud/CMakeLists.txt b/src/GSD/gsdcloud/CMakeLists.txt index 3b2ca84f12..9f0c470ef0 100644 --- a/src/GSD/gsdcloud/CMakeLists.txt +++ b/src/GSD/gsdcloud/CMakeLists.txt @@ -2,6 +2,8 @@ cmake_minimum_required(VERSION 2.6) if(BUILD_GSDCLOUD_ARW) file(GLOB GSDCLOUD_SRC ${GSDCLOUD_DIR}/*.f90) set_source_files_properties( ${GSDCLOUD_SRC} COMPILE_FLAGS ${GSDCLOUD_Fortran_FLAGS}) + include_directories( "${PROJECT_BINARY_DIR}/include" ) add_library( ${gsdcloud} STATIC ${GSDCLOUD_SRC} ) set_target_properties( ${gsdcloud} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) + target_link_libraries(${gsdcloud} ${GSISHAREDLIB} ) endif() diff --git a/src/GSD/gsdcloud/kinds.f90 b/src/GSD/gsdcloud/kinds.f90 deleted file mode 100755 index 73fbe3b568..0000000000 --- a/src/GSD/gsdcloud/kinds.f90 +++ /dev/null @@ -1,105 +0,0 @@ -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, private :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, private :: default_real = 2 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/src/GSD/gsdcloud4nmmb/kinds.f90 b/src/GSD/gsdcloud4nmmb/kinds.f90 deleted file mode 100755 index 73fbe3b568..0000000000 --- a/src/GSD/gsdcloud4nmmb/kinds.f90 +++ /dev/null @@ -1,105 +0,0 @@ -module kinds -!$$$ module documentation block -! . . . . -! module: kinds -! prgmmr: treadon org: np23 date: 2004-08-15 -! -! abstract: Module to hold specification kinds for variable declaration. -! This module is based on (copied from) Paul vanDelst's -! type_kinds module found in the community radiative transfer -! model -! -! module history log: -! 2004-08-15 treadon -! -! Subroutines Included: -! -! Functions Included: -! -! remarks: -! The numerical data types defined in this module are: -! i_byte - specification kind for byte (1-byte) integer variable -! i_short - specification kind for short (2-byte) integer variable -! i_long - specification kind for long (4-byte) integer variable -! i_llong - specification kind for double long (8-byte) integer variable -! r_single - specification kind for single precision (4-byte) real variable -! r_double - specification kind for double precision (8-byte) real variable -! r_quad - specification kind for quad precision (16-byte) real variable -! -! i_kind - generic specification kind for default integer -! r_kind - generic specification kind for default floating point -! -! -! attributes: -! language: f90 -! machine: ibm RS/6000 SP -! -!$$$ end documentation block - implicit none - private - -! Integer type definitions below - -! Integer types - integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer - integer, parameter, public :: i_short = selected_int_kind(4) ! short integer - integer, parameter, public :: i_long = selected_int_kind(8) ! long integer - integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer - integer, parameter, public :: i_llong = max( llong_t, i_long ) - -! Expected 8-bit byte sizes of the integer kinds - integer, parameter, public :: num_bytes_for_i_byte = 1 - integer, parameter, public :: num_bytes_for_i_short = 2 - integer, parameter, public :: num_bytes_for_i_long = 4 - integer, parameter, public :: num_bytes_for_i_llong = 8 - -! Define arrays for default definition - integer, parameter, private :: num_i_kinds = 4 - integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & - i_byte, i_short, i_long, i_llong /) - integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & - num_bytes_for_i_byte, num_bytes_for_i_short, & - num_bytes_for_i_long, num_bytes_for_i_llong /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** - integer, parameter, private :: default_integer = 3 ! 1=byte, - ! 2=short, - ! 3=long, - ! 4=llong - integer, parameter, public :: i_kind = integer_types( default_integer ) - integer, parameter, public :: num_bytes_for_i_kind = & - integer_byte_sizes( default_integer ) - - -! Real definitions below - -! Real types - integer, parameter, public :: r_single = selected_real_kind(6) ! single precision - integer, parameter, public :: r_double = selected_real_kind(15) ! double precision - integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision - integer, parameter, public :: r_quad = max( quad_t, r_double ) - -! Expected 8-bit byte sizes of the real kinds - integer, parameter, public :: num_bytes_for_r_single = 4 - integer, parameter, public :: num_bytes_for_r_double = 8 - integer, parameter, public :: num_bytes_for_r_quad = 16 - -! Define arrays for default definition - integer, parameter, private :: num_r_kinds = 3 - integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & - r_single, r_double, r_quad /) - integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & - num_bytes_for_r_single, num_bytes_for_r_double, & - num_bytes_for_r_quad /) - -! Default values -! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** - integer, parameter, private :: default_real = 2 ! 1=single, - ! 2=double, - ! 3=quad - integer, parameter, public :: r_kind = real_kinds( default_real ) - integer, parameter, public :: num_bytes_for_r_kind = & - real_byte_sizes( default_real ) - -end module kinds diff --git a/src/gsi/phil2.f90 b/src/gsi/phil2.f90 index 91e459182d..e17c43f176 100644 --- a/src/gsi/phil2.f90 +++ b/src/gsi/phil2.f90 @@ -741,7 +741,7 @@ end subroutine denest2dx !============================================================================= subroutine getqset5(n,qset5)! [getqset5] !============================================================================= -! Fill the first n rows of 5-row array, qset5, with the quaternions that +! Fill the rows of the n-row array, qset5, with the quaternions that ! represent, for that n, the optimally diverse rotations of a cube in the ! sense that the minimum angular distance between members of the set is as ! large as possible. In each case, the first row contains the identity and @@ -751,7 +751,7 @@ subroutine getqset5(n,qset5)! [getqset5] use pietc, only: u0,u1,u3,o2,r2,or2,phi implicit none integer(i_kind), intent(in ):: n -real(dp),dimension(0:3,5),intent(out):: qset5 +real(dp),dimension(0:3,n),intent(out):: qset5 !----------------------------------------------------------------------------- real(dp),parameter:: u8=8.0_dp,or8=u1/sqrt(u8),sig=u1/phi,chi=r2-u1 real(dp) :: term1,term2,ce,cf,cg,ch,cj,ck,cl diff --git a/ush/build.comgsi b/ush/build.comgsi index cd2a0570b9..31889802a6 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -23,12 +23,12 @@ elif [[ -d /jetmon ]] ; then ### jet NCEPLIBS="/lfs4/BMC/wrfruc/gge/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.4.274/install" elif [[ -d /glade ]] ; then ### cheyenne source /etc/profile.d/modules.sh - modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" - NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" - GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274/" - #modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" - #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" - #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" + #modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" + #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" + #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274/" + modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" + NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" + GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" elif [[ -d /work/noaa ]] ; then ### orion modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" From e68ecdeeba8e0c97d590658f57b6a0b904a92852 Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Fri, 5 Jun 2020 11:44:56 -0600 Subject: [PATCH 08/11] changed kinds.mod to gsd_kinds.mod to avoid conflict with gsi/kinds.mod --- src/GSD/gsdcloud/ARPS_cldLib.f90 | 16 ++-- src/GSD/gsdcloud/BackgroundCld.f90 | 4 +- src/GSD/gsdcloud/BckgrndCC.f90 | 2 +- src/GSD/gsdcloud/CMakeLists.txt | 2 - src/GSD/gsdcloud/PrecipMxr_radar.f90 | 2 +- src/GSD/gsdcloud/PrecipType.f90 | 2 +- src/GSD/gsdcloud/TempAdjust.f90 | 2 +- src/GSD/gsdcloud/adaslib.f90 | 4 +- src/GSD/gsdcloud/build_missing_REFcone.f90 | 2 +- src/GSD/gsdcloud/cloudCover_NESDIS.f90 | 2 +- src/GSD/gsdcloud/cloudCover_Surface.f90 | 2 +- src/GSD/gsdcloud/cloudCover_radar.f90 | 2 +- src/GSD/gsdcloud/cloudLWC.f90 | 4 +- src/GSD/gsdcloud/cloudLayers.f90 | 2 +- src/GSD/gsdcloud/cloudType.f90 | 2 +- src/GSD/gsdcloud/cloud_saturation.f90 | 4 +- src/GSD/gsdcloud/constants.f90 | 2 +- src/GSD/gsdcloud/convert_lghtn2ref.f90 | 2 +- src/GSD/gsdcloud/hydro_mxr_thompson.f90 | 2 +- src/GSD/gsdcloud/kinds.f90 | 105 +++++++++++++++++++++ src/GSD/gsdcloud/map_ctp.f90 | 6 +- src/GSD/gsdcloud/map_ctp_lar.f90 | 2 +- src/GSD/gsdcloud/mthermo.f90 | 14 +-- src/GSD/gsdcloud/pbl_height.f90 | 2 +- src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 | 4 +- src/GSD/gsdcloud/radar_ref2tten.f90 | 2 +- src/GSD/gsdcloud/read_Lightning_cld.f90 | 2 +- src/GSD/gsdcloud/read_NESDIS.f90 | 2 +- src/GSD/gsdcloud/read_Surface.f90 | 2 +- src/GSD/gsdcloud/read_nasalarc_cld.f90 | 4 +- src/GSD/gsdcloud/read_radar_ref.f90 | 2 +- src/GSD/gsdcloud/smooth.f90 | 2 +- src/GSD/gsdcloud/vinterp_radar_ref.f90 | 2 +- ush/build.comgsi | 12 +-- 34 files changed, 163 insertions(+), 60 deletions(-) create mode 100755 src/GSD/gsdcloud/kinds.f90 diff --git a/src/GSD/gsdcloud/ARPS_cldLib.f90 b/src/GSD/gsdcloud/ARPS_cldLib.f90 index b1d6d0d1fe..2fe9c006e5 100644 --- a/src/GSD/gsdcloud/ARPS_cldLib.f90 +++ b/src/GSD/gsdcloud/ARPS_cldLib.f90 @@ -75,7 +75,7 @@ SUBROUTINE get_stability (nz,t_1d,zs_1d,p_mb_1d,kbtm,ktop & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -181,7 +181,7 @@ FUNCTION os_fast(tk,p) ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -268,7 +268,7 @@ SUBROUTINE get_cloudtype(temp_k,dte_dz,cbase_m,ctop_m & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -416,7 +416,7 @@ SUBROUTINE get_sfm_1d (nz,zcb,zctop,zs_1d,p_mb_1d,t_1d,ql,qi,cldt, & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind + use gsd_kinds, only: r_single,i_kind IMPLICIT NONE ! ! @@ -749,7 +749,7 @@ SUBROUTINE pcp_type_3d (nx,ny,nz,temp_3d,rh_3d,p_pa_3d & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -1047,7 +1047,7 @@ SUBROUTINE get_slwc1d (nk,cbase_m,ctop_m,kbase,ktop & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -1220,7 +1220,7 @@ SUBROUTINE slwc_revb(cb_pa,cb_k,gt_pa,gt_k,ct_k, & ! 0 Otherwise ! I_STATUS2 - 1 when valid input data provided from main ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind IMPLICIT NONE real(r_single), intent(in) :: cb_pa,cb_k,gt_pa,gt_k,ct_k @@ -1373,7 +1373,7 @@ FUNCTION vapor(tfp) ! INPUT IS IN DEGREES C. IF GT 0, ASSUMED TO BE DEW POINT. IF ! LESS THAN 0, ASSUMED TO BE FROST POINT. ! ROUTINE CODES GOFF-GRATCH FORMULA - use kinds, only: i_kind,r_kind + use gsd_kinds, only: i_kind,r_kind IMPLICIT NONE real(r_kind), intent(in) :: tfp diff --git a/src/GSD/gsdcloud/BackgroundCld.f90 b/src/GSD/gsdcloud/BackgroundCld.f90 index f72a1b00bf..53ec3e1611 100644 --- a/src/GSD/gsdcloud/BackgroundCld.f90 +++ b/src/GSD/gsdcloud/BackgroundCld.f90 @@ -45,7 +45,7 @@ SUBROUTINE BackgroundCldgfs(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk) !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind use constants, only: rd_over_cp, h1000 use constants, only: rd, grav, half, rad2deg @@ -176,7 +176,7 @@ SUBROUTINE BackgroundCld(mype,lon2,lat2,nsig,tbk,pbk,psbk,q,hbk, & !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind use constants, only: rd_over_cp, h1000 use constants, only: rd, grav, half, rad2deg diff --git a/src/GSD/gsdcloud/BckgrndCC.f90 b/src/GSD/gsdcloud/BckgrndCC.f90 index c5e8bc6d69..57b0246a18 100644 --- a/src/GSD/gsdcloud/BckgrndCC.f90 +++ b/src/GSD/gsdcloud/BckgrndCC.f90 @@ -45,7 +45,7 @@ SUBROUTINE BckgrndCC(nlon,nlat,nsig,tbk,pbk,q,hbk,zh, & ! !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind use constants, only: h1000, rd_over_cp, g_over_rd implicit none diff --git a/src/GSD/gsdcloud/CMakeLists.txt b/src/GSD/gsdcloud/CMakeLists.txt index 9f0c470ef0..3b2ca84f12 100644 --- a/src/GSD/gsdcloud/CMakeLists.txt +++ b/src/GSD/gsdcloud/CMakeLists.txt @@ -2,8 +2,6 @@ cmake_minimum_required(VERSION 2.6) if(BUILD_GSDCLOUD_ARW) file(GLOB GSDCLOUD_SRC ${GSDCLOUD_DIR}/*.f90) set_source_files_properties( ${GSDCLOUD_SRC} COMPILE_FLAGS ${GSDCLOUD_Fortran_FLAGS}) - include_directories( "${PROJECT_BINARY_DIR}/include" ) add_library( ${gsdcloud} STATIC ${GSDCLOUD_SRC} ) set_target_properties( ${gsdcloud} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_INCLUDE_OUTPUT_DIRECTORY} ) - target_link_libraries(${gsdcloud} ${GSISHAREDLIB} ) endif() diff --git a/src/GSD/gsdcloud/PrecipMxr_radar.f90 b/src/GSD/gsdcloud/PrecipMxr_radar.f90 index 13f3fff7d8..cbe889744c 100644 --- a/src/GSD/gsdcloud/PrecipMxr_radar.f90 +++ b/src/GSD/gsdcloud/PrecipMxr_radar.f90 @@ -54,7 +54,7 @@ SUBROUTINE PrecipMxR_radar(mype,nlat,nlon,nsig, & ! use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none integer(i_kind),intent(in):: nlat,nlon,nsig diff --git a/src/GSD/gsdcloud/PrecipType.f90 b/src/GSD/gsdcloud/PrecipType.f90 index beb00dcd84..7ebb889059 100644 --- a/src/GSD/gsdcloud/PrecipType.f90 +++ b/src/GSD/gsdcloud/PrecipType.f90 @@ -44,7 +44,7 @@ SUBROUTINE PrecipType(nlat,nlon,nsig,t_bk,p_bk,q_bk,radar_3d, & ! use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none integer(i_kind),INTENT(IN):: nlat,nlon,nsig diff --git a/src/GSD/gsdcloud/TempAdjust.f90 b/src/GSD/gsdcloud/TempAdjust.f90 index a7f0802750..4e86df1602 100644 --- a/src/GSD/gsdcloud/TempAdjust.f90 +++ b/src/GSD/gsdcloud/TempAdjust.f90 @@ -51,7 +51,7 @@ SUBROUTINE TempAdjust(mype,nlat,nlon,nsig,cldptopt, t_bk, p_bk,w_bk,q_bk, & ! use constants, only: cp,rd_over_cp, h1000, hvap - use kinds, only: r_single,i_kind + use gsd_kinds, only: r_single,i_kind implicit none integer(i_kind),intent(in):: nlat,nlon,nsig diff --git a/src/GSD/gsdcloud/adaslib.f90 b/src/GSD/gsdcloud/adaslib.f90 index 555e7ec6a0..7a7eac0b77 100644 --- a/src/GSD/gsdcloud/adaslib.f90 +++ b/src/GSD/gsdcloud/adaslib.f90 @@ -85,7 +85,7 @@ FUNCTION rh_to_cldcv(rh,hgt) ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind IMPLICIT NONE @@ -436,7 +436,7 @@ END FUNCTION f_qvsat SUBROUTINE getdays(nday,iyear,imonth,iday) - use kinds, only: i_kind + use gsd_kinds, only: i_kind implicit none ! INTEGER(i_kind), intent(in) :: iyear,imonth,iday diff --git a/src/GSD/gsdcloud/build_missing_REFcone.f90 b/src/GSD/gsdcloud/build_missing_REFcone.f90 index 97b7c6863e..7ad7cf54c2 100644 --- a/src/GSD/gsdcloud/build_missing_REFcone.f90 +++ b/src/GSD/gsdcloud/build_missing_REFcone.f90 @@ -50,7 +50,7 @@ SUBROUTINE build_missing_REFcone(mype,nlon,nlat,nsig,krad_bot_in,ref_mos_3d,h_bk !_____________________________________________________________________ ! - use kinds, only: r_kind,i_kind,r_single + use gsd_kinds, only: r_kind,i_kind,r_single implicit none INTEGER(i_kind), intent(in) :: mype diff --git a/src/GSD/gsdcloud/cloudCover_NESDIS.f90 b/src/GSD/gsdcloud/cloudCover_NESDIS.f90 index 68ea71b9e7..9ca6eb6760 100644 --- a/src/GSD/gsdcloud/cloudCover_NESDIS.f90 +++ b/src/GSD/gsdcloud/cloudCover_NESDIS.f90 @@ -65,7 +65,7 @@ SUBROUTINE cloudCover_NESDIS(mype,regional_time,nlat,nlon,nsig,& use constants, only: rd_over_cp, h1000 use constants, only: deg2rad, rad2deg, pi - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none diff --git a/src/GSD/gsdcloud/cloudCover_Surface.f90 b/src/GSD/gsdcloud/cloudCover_Surface.f90 index 55ba970556..40554e9e4c 100644 --- a/src/GSD/gsdcloud/cloudCover_Surface.f90 +++ b/src/GSD/gsdcloud/cloudCover_Surface.f90 @@ -66,7 +66,7 @@ SUBROUTINE cloudCover_Surface(mype,nlat,nlon,nsig,r_radius,thunderRadius,& !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none diff --git a/src/GSD/gsdcloud/cloudCover_radar.f90 b/src/GSD/gsdcloud/cloudCover_radar.f90 index 97be8759c5..f18b95ebb1 100644 --- a/src/GSD/gsdcloud/cloudCover_radar.f90 +++ b/src/GSD/gsdcloud/cloudCover_radar.f90 @@ -44,7 +44,7 @@ SUBROUTINE cloudCover_radar(mype,nlat,nlon,nsig,h_bk,grid_ref, & use constants, only: rd_over_cp, h1000 use constants, only: deg2rad, rad2deg, pi - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none diff --git a/src/GSD/gsdcloud/cloudLWC.f90 b/src/GSD/gsdcloud/cloudLWC.f90 index 92c908b73b..5b5a7cfc82 100644 --- a/src/GSD/gsdcloud/cloudLWC.f90 +++ b/src/GSD/gsdcloud/cloudLWC.f90 @@ -50,7 +50,7 @@ SUBROUTINE cloudLWC_stratiform(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk, & ! use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind implicit none @@ -280,7 +280,7 @@ SUBROUTINE cloudLWC_Cumulus(nlat,nlon,nsig,h_bk,t_bk,p_bk, ! use constants, only: rd_over_cp, h1000 - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none integer(i_kind),intent(in) :: nlat,nlon,nsig diff --git a/src/GSD/gsdcloud/cloudLayers.f90 b/src/GSD/gsdcloud/cloudLayers.f90 index eb2d523968..b446752c26 100644 --- a/src/GSD/gsdcloud/cloudLayers.f90 +++ b/src/GSD/gsdcloud/cloudLayers.f90 @@ -43,7 +43,7 @@ SUBROUTINE cloudLayers(nlat,nlon,nsig,h_bk,zh,cld_cover_3d,cld_type_3d, & !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind + use gsd_kinds, only: r_single,i_kind implicit none diff --git a/src/GSD/gsdcloud/cloudType.f90 b/src/GSD/gsdcloud/cloudType.f90 index 2b97e72509..e3f4e3811d 100644 --- a/src/GSD/gsdcloud/cloudType.f90 +++ b/src/GSD/gsdcloud/cloudType.f90 @@ -47,7 +47,7 @@ SUBROUTINE cloudType(nlat,nlon,nsig,h_bk,t_bk,p_bk,radar_3d, & ! use constants, only: rd_over_cp, h1000, half - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none integer(i_kind),INTENT(IN) :: nlat,nlon,nsig diff --git a/src/GSD/gsdcloud/cloud_saturation.f90 b/src/GSD/gsdcloud/cloud_saturation.f90 index 70e6587b20..fa9fd5cb7a 100644 --- a/src/GSD/gsdcloud/cloud_saturation.f90 +++ b/src/GSD/gsdcloud/cloud_saturation.f90 @@ -53,7 +53,7 @@ SUBROUTINE cloud_saturation(mype,l_conserve_thetaV,i_conserve_thetaV_iternum, & ! use constants, only: rd_over_cp, h1000,one,zero,fv - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind implicit none @@ -292,7 +292,7 @@ function ruc_saturation(Temp,pressure) !_____________________________________________________________________ use constants, only: rd_over_cp, h1000,one,zero - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind ! implicit none real(r_single) :: ruc_saturation diff --git a/src/GSD/gsdcloud/constants.f90 b/src/GSD/gsdcloud/constants.f90 index 9d4263197e..3d213431ed 100755 --- a/src/GSD/gsdcloud/constants.f90 +++ b/src/GSD/gsdcloud/constants.f90 @@ -36,7 +36,7 @@ module constants ! !$$$ end documentation block - use kinds, only: r_single,r_kind,i_kind,r_quad,i_long + use gsd_kinds, only: r_single,r_kind,i_kind,r_quad,i_long implicit none ! set default as private diff --git a/src/GSD/gsdcloud/convert_lghtn2ref.f90 b/src/GSD/gsdcloud/convert_lghtn2ref.f90 index b4acdb89d3..34ba58592d 100644 --- a/src/GSD/gsdcloud/convert_lghtn2ref.f90 +++ b/src/GSD/gsdcloud/convert_lghtn2ref.f90 @@ -40,7 +40,7 @@ SUBROUTINE convert_lghtn2ref(mype,nlon,nlat,nsig,ref_mos_3d,lightning,h_bk) ! !_____________________________________________________________________ ! - use kinds, only: r_kind,i_kind,r_single + use gsd_kinds, only: r_kind,i_kind,r_single implicit none INTEGER(i_kind),intent(in) :: mype diff --git a/src/GSD/gsdcloud/hydro_mxr_thompson.f90 b/src/GSD/gsdcloud/hydro_mxr_thompson.f90 index af7a7a44e1..aebea2ac75 100644 --- a/src/GSD/gsdcloud/hydro_mxr_thompson.f90 +++ b/src/GSD/gsdcloud/hydro_mxr_thompson.f90 @@ -33,7 +33,7 @@ SUBROUTINE hydro_mxr_thompson (nx, ny, nz, t_3d, p_3d, ref_3d, qr_3d, qnr_3d, qs ! !----------------------------------------------------------------------- ! - use kinds, only: r_single, i_kind, r_kind + use gsd_kinds, only: r_single, i_kind, r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- diff --git a/src/GSD/gsdcloud/kinds.f90 b/src/GSD/gsdcloud/kinds.f90 new file mode 100755 index 0000000000..3410f68b43 --- /dev/null +++ b/src/GSD/gsdcloud/kinds.f90 @@ -0,0 +1,105 @@ +module gsd_kinds +!$$$ module documentation block +! . . . . +! module: kinds +! prgmmr: treadon org: np23 date: 2004-08-15 +! +! abstract: Module to hold specification kinds for variable declaration. +! This module is based on (copied from) Paul vanDelst's +! type_kinds module found in the community radiative transfer +! model +! +! module history log: +! 2004-08-15 treadon +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! The numerical data types defined in this module are: +! i_byte - specification kind for byte (1-byte) integer variable +! i_short - specification kind for short (2-byte) integer variable +! i_long - specification kind for long (4-byte) integer variable +! i_llong - specification kind for double long (8-byte) integer variable +! r_single - specification kind for single precision (4-byte) real variable +! r_double - specification kind for double precision (8-byte) real variable +! r_quad - specification kind for quad precision (16-byte) real variable +! +! i_kind - generic specification kind for default integer +! r_kind - generic specification kind for default floating point +! +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + implicit none + private + +! Integer type definitions below + +! Integer types + integer, parameter, public :: i_byte = selected_int_kind(1) ! byte integer + integer, parameter, public :: i_short = selected_int_kind(4) ! short integer + integer, parameter, public :: i_long = selected_int_kind(8) ! long integer + integer, parameter, private :: llong_t = selected_int_kind(16) ! llong integer + integer, parameter, public :: i_llong = max( llong_t, i_long ) + +! Expected 8-bit byte sizes of the integer kinds + integer, parameter, public :: num_bytes_for_i_byte = 1 + integer, parameter, public :: num_bytes_for_i_short = 2 + integer, parameter, public :: num_bytes_for_i_long = 4 + integer, parameter, public :: num_bytes_for_i_llong = 8 + +! Define arrays for default definition + integer, parameter, private :: num_i_kinds = 4 + integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ & + i_byte, i_short, i_long, i_llong /) + integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ & + num_bytes_for_i_byte, num_bytes_for_i_short, & + num_bytes_for_i_long, num_bytes_for_i_llong /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND *** + integer, parameter, private :: default_integer = 3 ! 1=byte, + ! 2=short, + ! 3=long, + ! 4=llong + integer, parameter, public :: i_kind = integer_types( default_integer ) + integer, parameter, public :: num_bytes_for_i_kind = & + integer_byte_sizes( default_integer ) + + +! Real definitions below + +! Real types + integer, parameter, public :: r_single = selected_real_kind(6) ! single precision + integer, parameter, public :: r_double = selected_real_kind(15) ! double precision + integer, parameter, private :: quad_t = selected_real_kind(20) ! quad precision + integer, parameter, public :: r_quad = max( quad_t, r_double ) + +! Expected 8-bit byte sizes of the real kinds + integer, parameter, public :: num_bytes_for_r_single = 4 + integer, parameter, public :: num_bytes_for_r_double = 8 + integer, parameter, public :: num_bytes_for_r_quad = 16 + +! Define arrays for default definition + integer, parameter, private :: num_r_kinds = 3 + integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ & + r_single, r_double, r_quad /) + integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ & + num_bytes_for_r_single, num_bytes_for_r_double, & + num_bytes_for_r_quad /) + +! Default values +! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** + integer, parameter, private :: default_real = 2 ! 1=single, + ! 2=double, + ! 3=quad + integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: num_bytes_for_r_kind = & + real_byte_sizes( default_real ) + +end module gsd_kinds diff --git a/src/GSD/gsdcloud/map_ctp.f90 b/src/GSD/gsdcloud/map_ctp.f90 index 1670ba93ef..df72159bbd 100644 --- a/src/GSD/gsdcloud/map_ctp.f90 +++ b/src/GSD/gsdcloud/map_ctp.f90 @@ -82,7 +82,7 @@ subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,npts !_____________________________________________________________________ ! - use kinds, only: r_kind,r_single,i_kind + use gsd_kinds, only: r_kind,r_single,i_kind use constants, only: zero,one_tenth,one,deg2rad implicit none @@ -228,7 +228,7 @@ subroutine map_ctp (ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_frac,npts end subroutine map_ctp subroutine sorting(d,n,is) - use kinds, only: r_kind,i_kind + use gsd_kinds, only: r_kind,i_kind implicit none integer(i_kind), intent(in) :: n @@ -255,7 +255,7 @@ subroutine sorting(d,n,is) end subroutine sorting subroutine sortmed(p,n,is,f) - use kinds, only: r_kind,i_kind + use gsd_kinds, only: r_kind,i_kind implicit none real(r_kind), intent(inout) :: p(n) integer(i_kind), intent(in) :: n diff --git a/src/GSD/gsdcloud/map_ctp_lar.f90 b/src/GSD/gsdcloud/map_ctp_lar.f90 index c2927869c5..09034dc358 100644 --- a/src/GSD/gsdcloud/map_ctp_lar.f90 +++ b/src/GSD/gsdcloud/map_ctp_lar.f90 @@ -81,7 +81,7 @@ subroutine map_ctp_lar(mype,ib,jb,nx,ny,nn_obs,numsao,data_s,sat_ctp,sat_tem,w_f !_____________________________________________________________________ ! - use kinds, only: r_kind,r_single,i_kind + use gsd_kinds, only: r_kind,r_single,i_kind use constants, only: zero,one_tenth,one,deg2rad implicit none diff --git a/src/GSD/gsdcloud/mthermo.f90 b/src/GSD/gsdcloud/mthermo.f90 index 83b5b7741e..2e2a0b7d39 100644 --- a/src/GSD/gsdcloud/mthermo.f90 +++ b/src/GSD/gsdcloud/mthermo.f90 @@ -36,7 +36,7 @@ function esat(t) ! tions of selected meteorlolgical parameters for cloud physics prob- ! lems," ecom-5475, atmospheric sciences laboratory, u.s. army ! electronics command, white sands missile range, new mexico 88002. - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none real(r_kind),intent(in) :: t real(r_single) :: tk,p1,p2,c1 @@ -58,7 +58,7 @@ function eslo(t) ! for the computation of saturation vapor pressure, journal of applied ! meteorology, vol 16, no. 1 (january), pp. 100-103. ! the polynomial coefficients are a0 through a6. - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none ! real(r_kind), intent(in) :: t @@ -83,7 +83,7 @@ function tda(o,p) ! at pressure p (millibars). the dry adiabat is given by ! potential temperature o (celsius). the computation is based on ! poisson's equation. - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none real(r_kind), intent(in) :: o,p real(r_kind) :: tda @@ -99,7 +99,7 @@ function tmr(w,p) ! table 1 on page 7 of stipanuk (1973). ! ! initialize constants - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none real(r_kind), intent(in) :: w,p real(r_kind) :: tmr @@ -127,7 +127,7 @@ function tsa(os,p) ! b is an empirical constant approximately equal to 0.001 of the latent ! heat of vaporization for water divided by the specific heat at constant ! pressure for dry air. - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none real(r_kind), intent(in) :: os,p real(r_kind) :: tsa @@ -168,7 +168,7 @@ function tw(t,td,p) ! ! ! determine the mixing ratio line thru td and p. - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none real(r_kind), intent(in) :: t,td,p real(r_kind) :: tw @@ -217,7 +217,7 @@ function w(t,p) ! (millibars). if the temperture is input instead of the ! dew point, then saturation mixing ratio (same units) is returned. ! the formula is found in most meteorological texts. - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none real(r_kind), intent(in) :: t,p real(r_kind) :: w diff --git a/src/GSD/gsdcloud/pbl_height.f90 b/src/GSD/gsdcloud/pbl_height.f90 index 6466899f01..e22abd7aa4 100644 --- a/src/GSD/gsdcloud/pbl_height.f90 +++ b/src/GSD/gsdcloud/pbl_height.f90 @@ -39,7 +39,7 @@ SUBROUTINE calc_pbl_height(mype,nlat,nlon,nsig,q_bk,t_bk,p_bk,pblh) !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind implicit none diff --git a/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 b/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 index e25e6a8486..ab12b2fd81 100644 --- a/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 +++ b/src/GSD/gsdcloud/pcp_mxr_ARPSlib.f90 @@ -90,7 +90,7 @@ SUBROUTINE pcp_mxr (nx,ny,nz,t_3d,p_3d ,ref_3d & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -314,7 +314,7 @@ SUBROUTINE pcp_mxr_ferrier (nx,ny,nz,t_3d,p_3d ,ref_3d & ! !----------------------------------------------------------------------- ! - use kinds, only: r_single,i_kind, r_kind + use gsd_kinds, only: r_single,i_kind, r_kind IMPLICIT NONE ! !----------------------------------------------------------------------- diff --git a/src/GSD/gsdcloud/radar_ref2tten.f90 b/src/GSD/gsdcloud/radar_ref2tten.f90 index c423d7bc6e..0acca7ce2f 100644 --- a/src/GSD/gsdcloud/radar_ref2tten.f90 +++ b/src/GSD/gsdcloud/radar_ref2tten.f90 @@ -49,7 +49,7 @@ SUBROUTINE radar_ref2tten(mype,istat_radar,istat_lightning,nlon,nlat,nsig,ref_mo !_____________________________________________________________________ ! use constants, only: rd_over_cp, h1000 - use kinds, only: r_kind,i_kind,r_single + use gsd_kinds, only: r_kind,i_kind,r_single implicit none INTEGER(i_kind),INTENT(IN) :: mype diff --git a/src/GSD/gsdcloud/read_Lightning_cld.f90 b/src/GSD/gsdcloud/read_Lightning_cld.f90 index 89097f72bb..46b02a00d8 100644 --- a/src/GSD/gsdcloud/read_Lightning_cld.f90 +++ b/src/GSD/gsdcloud/read_Lightning_cld.f90 @@ -43,7 +43,7 @@ SUBROUTINE read_Lightning2cld(mype,lunin,istart,jstart, & !_____________________________________________________________________ ! - use kinds, only: r_kind,i_kind, r_single + use gsd_kinds, only: r_kind,i_kind, r_single implicit none integer(i_kind),intent(in) :: lunin diff --git a/src/GSD/gsdcloud/read_NESDIS.f90 b/src/GSD/gsdcloud/read_NESDIS.f90 index 0daca20f24..4d3dd9bf21 100644 --- a/src/GSD/gsdcloud/read_NESDIS.f90 +++ b/src/GSD/gsdcloud/read_NESDIS.f90 @@ -45,7 +45,7 @@ SUBROUTINE read_NESDIS(mype,lunin,numobs,istart,jstart,nlon,nlat, & !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none diff --git a/src/GSD/gsdcloud/read_Surface.f90 b/src/GSD/gsdcloud/read_Surface.f90 index 48a1765a4d..8fb56a8ffc 100644 --- a/src/GSD/gsdcloud/read_Surface.f90 +++ b/src/GSD/gsdcloud/read_Surface.f90 @@ -51,7 +51,7 @@ SUBROUTINE read_Surface(mype,lunin,istart,jstart,nlon,nlat,& !$$$ ! - use kinds, only: r_single,i_kind,r_kind,r_double + use gsd_kinds, only: r_single,i_kind,r_kind,r_double implicit none diff --git a/src/GSD/gsdcloud/read_nasalarc_cld.f90 b/src/GSD/gsdcloud/read_nasalarc_cld.f90 index 557ac81235..efe69c927a 100644 --- a/src/GSD/gsdcloud/read_nasalarc_cld.f90 +++ b/src/GSD/gsdcloud/read_nasalarc_cld.f90 @@ -44,7 +44,7 @@ SUBROUTINE read_NASALaRC(mype,lunin,numLaRC,istart,jstart, & !_____________________________________________________________________ ! - use kinds, only: r_kind,i_kind, r_single + use gsd_kinds, only: r_kind,i_kind, r_single implicit none integer(i_kind),intent(in) :: lunin @@ -182,7 +182,7 @@ SUBROUTINE read_map_nasalarc(mype,lunin,numobs,istart,jstart,nlon,nlat, & !_____________________________________________________________________ ! - use kinds, only: r_single,i_kind,r_kind + use gsd_kinds, only: r_single,i_kind,r_kind implicit none diff --git a/src/GSD/gsdcloud/read_radar_ref.f90 b/src/GSD/gsdcloud/read_radar_ref.f90 index 9f337a6ae1..a53274e2a8 100644 --- a/src/GSD/gsdcloud/read_radar_ref.f90 +++ b/src/GSD/gsdcloud/read_radar_ref.f90 @@ -45,7 +45,7 @@ SUBROUTINE read_radar_ref(mype,lunin,istart,jstart, & ! !_____________________________________________________________________ ! - use kinds, only: r_kind,i_kind + use gsd_kinds, only: r_kind,i_kind implicit none INTEGER(i_kind),intent(in) :: mype diff --git a/src/GSD/gsdcloud/smooth.f90 b/src/GSD/gsdcloud/smooth.f90 index 73f6208091..19372bfdc5 100644 --- a/src/GSD/gsdcloud/smooth.f90 +++ b/src/GSD/gsdcloud/smooth.f90 @@ -38,7 +38,7 @@ SUBROUTINE SMOOTH (FIELD,HOLD,IX,IY,SMTH) !C********************************************************************** - use kinds, only: r_kind,i_kind,r_single + use gsd_kinds, only: r_kind,i_kind,r_single implicit none !C********************************************************************** INTEGER(i_kind),INTENT(IN) :: IX,IY diff --git a/src/GSD/gsdcloud/vinterp_radar_ref.f90 b/src/GSD/gsdcloud/vinterp_radar_ref.f90 index 314aabd781..6638885806 100644 --- a/src/GSD/gsdcloud/vinterp_radar_ref.f90 +++ b/src/GSD/gsdcloud/vinterp_radar_ref.f90 @@ -43,7 +43,7 @@ SUBROUTINE vinterp_radar_ref(mype,nlon,nlat,nsig,Nmsclvl,ref_mos_3d,ref_mosaic31 ! !_____________________________________________________________________ ! - use kinds, only: r_kind,i_kind, r_single + use gsd_kinds, only: r_kind,i_kind, r_single implicit none INTEGER(i_kind), intent(in) :: mype diff --git a/ush/build.comgsi b/ush/build.comgsi index 31889802a6..cd2a0570b9 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -23,12 +23,12 @@ elif [[ -d /jetmon ]] ; then ### jet NCEPLIBS="/lfs4/BMC/wrfruc/gge/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.4.274/install" elif [[ -d /glade ]] ; then ### cheyenne source /etc/profile.d/modules.sh - #modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" - #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" - #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274/" - modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" - NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" - GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" + modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" + NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" + GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274/" + #modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" + #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" + #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" elif [[ -d /work/noaa ]] ; then ### orion modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" From 6e008e57e118dc06b0377b38ccca0ea09100a4c2 Mon Sep 17 00:00:00 2001 From: "guoqing.ge" Date: Fri, 5 Jun 2020 12:00:29 -0600 Subject: [PATCH 09/11] update ush/build.comgsi --- ush/build.comgsi | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/ush/build.comgsi b/ush/build.comgsi index cd2a0570b9..5a04478846 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -13,15 +13,22 @@ dir_root=$(pwd) -if [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then ###hera +################# Hera #################### +if [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.hera.GSI_UPP_WRF" NCEPLIBS="/scratch1/BMC/comgsi/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.0.4/install" -elif [[ -d /jetmon ]] ; then ### jet + GSILIBS="/scratch1/BMC/comgsi/precompiled/GSILIBS/b_intel18.0.5.274_impi2018.0.4/" + +################# Jet #################### +elif [[ -d /jetmon ]] ; then source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.jet.GSI_UPP_WRF" NCEPLIBS="/lfs4/BMC/wrfruc/gge/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.4.274/install" -elif [[ -d /glade ]] ; then ### cheyenne + GSILIBS="/lfs4/BMC/wrfruc/gge/precompiled/GSILIBS/b_intel18.0.5.274_impi2018.4.274" + +################# Cheyenne #################### +elif [[ -d /glade ]] ; then source /etc/profile.d/modules.sh modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" @@ -29,9 +36,13 @@ elif [[ -d /glade ]] ; then ### cheyenne #modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" + +################# Orion #################### elif [[ -d /work/noaa ]] ; then ### orion modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" + +################# Generic #################### else echo -e "\nunknown machine" echo "Please modify build.comgsi at this location" From ab9a18c4742b84b7a10d3e1053d4ca40ce587782 Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Fri, 5 Jun 2020 19:25:22 -0600 Subject: [PATCH 10/11] update build.comgsi for Orion --- ush/build.comgsi | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ush/build.comgsi b/ush/build.comgsi index 5a04478846..2188f015af 100755 --- a/ush/build.comgsi +++ b/ush/build.comgsi @@ -18,7 +18,7 @@ if [[ "`grep -i "hera" /etc/hosts | head -n1`" != "" ]] ; then source /etc/profile.d/modules.sh modulefile="/home/rtrr/PARM_EXEC/modulefiles/modulefile.hera.GSI_UPP_WRF" NCEPLIBS="/scratch1/BMC/comgsi/precompiled/NCEPLIBS/b_intel18.0.5.274_impi2018.0.4/install" - GSILIBS="/scratch1/BMC/comgsi/precompiled/GSILIBS/b_intel18.0.5.274_impi2018.0.4/" + GSILIBS="/scratch1/BMC/comgsi/precompiled/GSILIBS/b_intel18.0.5.274_impi2018.0.4" ################# Jet #################### elif [[ -d /jetmon ]] ; then @@ -32,15 +32,16 @@ elif [[ -d /glade ]] ; then source /etc/profile.d/modules.sh modulefile="/glade/p/ral/jntp/gge/modulefiles/modulefile.cheyenne.GSI_UPP_WRF" NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_intel18.0.5_impi2018.4.274/install" - GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274/" + GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_intel18.0.5_impi2018.4.274" #modulefile="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/modulefile.cheyenne.GSI_UPP_WRF.gnu" #NCEPLIBS="/glade/p/ral/jntp/gge/precompiled/NCEPLIBS/b_gnu8.3.0_openmpi3.1.4/install" #GSILIBS="/glade/p/ral/jntp/gge/precompiled/GSILIBS/b_gnu8.3.0_openmpi3.1.4/" ################# Orion #################### elif [[ -d /work/noaa ]] ; then ### orion - modulefile="/work/noaa/comgsi/modulefiles/modulefile.orion.GSI_UPP_WRF" - #modulefile="/work/noaa/comgsi/modulefiles/modulefile.intel20" + modulefile="/home/gge/modulefiles/modulefile.orion.GSI_UPP_WRF" + NCEPLIBS="/work/noaa/wrfruc/gge/precompiled/NCEPLIBS/b_intel2018.4_impi2018.4/install" + GSILIBS="/work/noaa/wrfruc/gge/precompiled/GSILIBS/b_intel2018.4_impi2018.4" ################# Generic #################### else From a02c47ff2916534f95f8b7d1bd3b0d709a38aed8 Mon Sep 17 00:00:00 2001 From: "Guoqing.Ge" Date: Mon, 8 Jun 2020 21:36:13 -0600 Subject: [PATCH 11/11] added back .gitmodules fix/ libsrc/ for the pull request --- .gitmodules | 7 +++++++ fix | 1 + libsrc | 1 + 3 files changed, 9 insertions(+) create mode 100644 .gitmodules create mode 160000 fix create mode 160000 libsrc diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000000..f4bfd21ee7 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,7 @@ +[submodule "fix"] + path = fix + url = gerrit:GSI-fix + +[submodule "libsrc"] + path = libsrc + url = gerrit:GSI-libsrc diff --git a/fix b/fix new file mode 160000 index 0000000000..f0f7447ff0 --- /dev/null +++ b/fix @@ -0,0 +1 @@ +Subproject commit f0f7447ff01d07e7d9b6efe017a62e26541751cb diff --git a/libsrc b/libsrc new file mode 160000 index 0000000000..21f2383e07 --- /dev/null +++ b/libsrc @@ -0,0 +1 @@ +Subproject commit 21f2383e075a0d0bfd24df60998c061fc4de202a